Subversion Repositories DevTools

Rev

Rev 7268 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
6242 dpurdie 1 
########################################################################
2 
# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.
3 
#
4 
# Module name   : DebianPackager.pl
5 
# Module type   : Makefile system
6 
# Compiler(s)   : Perl
7 
# Environment(s): jats
8 
#
9 
# Description   : This program is invoked by the MakeDebianPackage and MakeRpmPackage
10 
#                 directive that is a part of this package
11 
#
12 
#                 The program will use a user-provided script in order
13 
#                 to create the output Package.
14 
#
15 
#                 The user script may call a number of directives in order to
16 
#                 construct an image of the package being installed.
17 
#
18 
#                 The script specifies Debian/RPM configuration scripts that
19 
#                 will be embedded in the package.
20 
#
21 
#                 This program will:
22 
#                   Construct a filesystem image under control of the directives
23 
#                   within the user script
24 
#
25 
#                   Debian:
26 
#                       Massage the Debian control file
27 
#                       Create a Debian Package
28 
#                       Transfer it to the users 'BIN' directory, where it is available to be packaged.
29 
#
30 
#                   RedHat Package:
31 
#                       Generate rpmBuilder control files
32 
#                       Create the RPM image
33 
#                       Transfer it to the users 'BIN' directory, where it is available to be packaged.
34 
#
35 
#                   TarFile:
36 
#                       Tar Gzip the image
37 
#                       Transfer it to the users 'BIN' directory, where it is available to be packaged.
38 
#
39 
#                 Summary of directives available to the user-script:
40 
#                       Message                 - Display progress text
41 
#                       Verbose                 - Display progress text
42 
#                       AddInitScript           - Add an init script
43 
#                       CatFile                 - Append to a file
44 
#                       ConvertFile             - Convert file(s) to Unix or Dos Text
45 
#                       CopyDir                 - Copy directory tree
46 
#                       CopyFile                - Copy a file
47 
#                       CopyBinFile             - Copy an executable file
48 
#                       CopyLibFile             - Copy a library file
49 
#                       CopyDebPackage          - Copy a Debian Package
50 
#                       CreateDir               - Create a directory
51 
#                       AllFiles                - Specify control and script files
52 
#                       DebianFiles             - Specify control and script files (Debian Only)
53 
#                       RpmFiles                - Specify control and script files (RPM Only)
54 
#                       AllControlFile          - Specify control and script files
55 
#                       DebianControlFile       - Specify control and script files (Debian Only)
56 
#                       RpmControlFile          - Specify control and script files (RPM Only)
57 
#                       AllDepends              - Add Depends entry to control file
58 
#                       DebianDepends           - Add Depends entry to control file (Debian Only)
59 
#                       RpmDepends              - Add Depends entry to control file (RPM Only)
60 
#                       EchoFile                - Place text into a file
61 
#                       MakeSymLink             - Create a symbolic link
62 
#                       PackageDescription      - Specify the package description
63 
#                       ReplaceTags             - Replace Tags on target file
64 
#                       SetFilePerms            - Set file permissions
65 
#                       SetVerbose              - Control progress display
66 
#                       IsProduct               - Flow control
67 
#                       IsPlatform              - Flow control
68 
#                       IsTarget                - Flow control
69 
#                       IsVariant               - Flow control
70 
#                       IsAlias                 - Flow control
71 
#                       RpmSetDefAttr           - Specify default file properties (RPM Only)
72 
#                       RpmSetAttr              - Specify file properties (RPM Only)
73 
#                       SetBaseDir              - Sets base for installed files (RPM Hint for directory ownership)
74 
#                       Section                 - Set current section
75 
#                       PackageVersion          - Return the version of a named package
76 
#                       ExtractTar              - Extract a tar file into the target
77 
#
78 
#                 Thoughts for expansion:
79 
#                       SrcDir                  - Extend path for resolving local files
80 
#
81 
#                   Less used:
82 
#                        ExpandLinkFiles        - Expand .LINK files
83 
#
84 
#                   Internal Use:
85 
#                        FindFiles              - Find a file
86 
#                        ResolveFile            - Resolve a 'local' source file
87 
#                        chmodItem              - Set file or directory permissions
88 
#
89 
#......................................................................#
90 
 
91 
require 5.006_001;
92 
use strict;
93 
use warnings;
94 
 
95 
use Getopt::Long;
96 
use File::Path;
97 
use File::Copy;
98 
use File::Find;
6937 dpurdie 99 
use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
6242 dpurdie 100 
use JatsSystem;
101 
use FileUtils;
102 
use ArrayHashUtils;
103 
use JatsError;
104 
use JatsLocateFiles;
105 
use ReadBuildConfig;
106 
use JatsCopy ();                            # Don't import anything
107 
use PackagerUtils;
108 
 
109 
#
110 
#   Command line options
111 
#
112 
my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
113 
my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
114 
my $opt_vargs;                              # Verbose arg
115 
my $opt_help = 0;
116 
my $opt_manual = 0;
117 
my $opt_clean = 0;
118 
my $opt_interfacedir;
119 
my $opt_package_script;
120 
my $opt_interfaceincdir;
121 
my $opt_interfacelibdir;
122 
my $opt_interfacebindir;
123 
my $opt_libdir;
124 
my $opt_bindir;
125 
my $opt_localincdir;
126 
my $opt_locallibdir;
127 
my $opt_localbindir;
128 
my $opt_pkgdir;
129 
my $opt_pkglibdir;
130 
my $opt_pkgbindir;
131 
my $opt_pkgpkgdir;
132 
my $opt_noarch;
133 
my $opt_tarFile;
134 
my $opt_tarOnly;
6937 dpurdie 135 
my $opt_zipFile;
136 
my $opt_zipOnly;
6242 dpurdie 137 
my $opt_rpm = 0;
138 
my $opt_debian = 0;
139 
my $opt_output;
7398 dpurdie 140 
my $opt_imageOnly;
141 
my $opt_directPkg;
6242 dpurdie 142 
 
143 
#
144 
#   Options marked as 'our' so that they are visible within the users script
145 
#   Don't give the user too much
146 
#
147 
our $opt_platform;
148 
our $opt_type;
149 
our $opt_buildname;
150 
our $opt_buildversion;
151 
our $opt_target;
152 
our $opt_product;
153 
our $opt_name;
6738 dpurdie 154 
our $opt_version;
6242 dpurdie 155 
our $opt_variant;
6738 dpurdie 156 
our $opt_versionprefix;
157 
our $opt_extdesc;
6242 dpurdie 158 
our $opt_pkgarch;
159 
our $opt_rpmRelease = '';
160 
 
161 
#
162 
#   Options derived from script directives
163 
#
164 
my $opt_description;
165 
my $opt_specFile;
166 
 
167 
#
168 
#   Globals
169 
#
170 
my $WorkDirBase;                            # Workspace
171 
my $WorkDirInit;                            # Initial Dir to create file system image within
172 
my $WorkDir;                                # Dir to create file system image within
173 
my $WorkSubDir = '';                        # Diff between $WorkDirInit and $WorkDir
174 
my @ResolveFileList;                        # Cached Package File List
175 
my @ResolveBinFileList;                     # Cached PackageBin File List
176 
my @ResolveDebFileList;                     # Cached PackageDeb File List
177 
my @ResolveLibFileList;                     # Cached PackageLib File List
178 
my %ControlFiles;                           # Control Files
179 
my %ControlFileNames;                       # Control Files by name
180 
my @DependencyList;                         # Package Dependencies
181 
my @ConfigList;                             # Config Files
182 
my %opt_aliases;                            # Cached Alias Names
183 
my @RpmDefAttr = ('-','root','root','-');   # RPM: Default File Attributes
184 
my @RpmAttrList;                            # RPM: File attributes
185 
my %OwnedDirs;                              # RPM: Dirs marked as owned
186 
my $ActiveSection = 1;                      # Indicates if the section is active
187 
 
188 
#-------------------------------------------------------------------------------
189 
# Function        : Main Entry point
190 
#
191 
# Description     : This function will be called when the package is initialised
192 
#                   Extract arguments from the users environment
193 
#
194 
#                   Done here to greatly simplify the user script
195 
#                   There should be no junk in the user script - keep it simple
196 
#
197 
# Inputs          :
198 
#
199 
# Returns         :
200 
#
201 
main();
202 
sub main
203 
{
204 
    my $result = GetOptions (
205 
                'verbose:s'         => \$opt_vargs,
206 
                'clean'             => \$opt_clean,
207 
                'Type=s'            => \$opt_type,
208 
                'BuildName=s'       => \$opt_buildname,                     # Raw Jats Package Name (Do not use)
209 
                'Name=s'            => \$opt_name,                          # Massaged Debian Package Name
6738 dpurdie 210 
                'Version=s'         => \$opt_version,                       # Massaged Debian Version
6242 dpurdie 211 
                'BuildVersion=s'    => \$opt_buildversion,
212 
                'Platform=s'        => \$opt_platform,
213 
                'Target=s'          => \$opt_target,
214 
                'Product=s'         => \$opt_product,
215 
                'InterfaceDir=s'    => \$opt_interfacedir,
216 
                'InterfaceIncDir=s' => \$opt_interfaceincdir,
217 
                'InterfaceLibDir=s' => \$opt_interfacelibdir,
218 
                'InterfaceBinDir=s' => \$opt_interfacebindir,
219 
                'LibDir=s'          => \$opt_libdir,
220 
                'BinDir=s'          => \$opt_bindir,
221 
                'LocalIncDir=s'     => \$opt_localincdir,
222 
                'LocalLibDir=s'     => \$opt_locallibdir,
223 
                'LocalBinDir=s'     => \$opt_localbindir,
224 
                'PackageDir=s'      => \$opt_pkgdir,
225 
                'PackageLibDir=s'   => \$opt_pkglibdir,
226 
                'PackageBinDir=s'   => \$opt_pkgbindir,
227 
                'PackagePkgDir=s'   => \$opt_pkgpkgdir,
6738 dpurdie 228 
                'VersionPrefix:s'   => \$opt_versionprefix,
6242 dpurdie 229 
                'Variant:s'         => \$opt_variant,
6738 dpurdie 230 
                'ExtDesc:s'         => \$opt_extdesc,
6242 dpurdie 231 
                'PkgArch:s'         => \$opt_pkgarch,
232 
                'NoArch'            => \$opt_noarch,
233 
                'tarFile=s'         => \$opt_tarFile,
234 
                'tarOnly'           => \$opt_tarOnly,
6937 dpurdie 235 
                'zipFile=s'         => \$opt_zipFile,
236 
                'zipOnly'           => \$opt_zipOnly,
6242 dpurdie 237 
                'genRpm'            => \$opt_rpm,
238 
                'genDeb'            => \$opt_debian,
239 
                'output=s'          => \$opt_output,
240 
                'script=s'          => \$opt_package_script,
241 
                'rpmRelease=s'      => \$opt_rpmRelease,
7398 dpurdie 242 
                'imageOnly'         => \$opt_imageOnly,
243 
                'directPkg'         => \$opt_directPkg,
6242 dpurdie 244 
    );
245 
    $opt_verbose++ unless ( $opt_vargs eq '@' );
246 
 
247 
    ErrorConfig( 'name'    => 'PackagerUtils',
248 
                 'verbose' => $opt_verbose,
249 
                 'debug'   => $opt_debug );
250 
 
251 
    #
252 
    #   Init the FileSystem Uiltity interface
253 
    #
254 
    InitFileUtils();
255 
 
256 
    #
257 
    #   Ensure that we have all required options
258 
    #
259 
    Error ("Platform not set")                  unless ( $opt_platform );
260 
    Error ("Type not set")                      unless ( $opt_type );
261 
    Error ("BuildName not set")                 unless ( $opt_buildname );
6738 dpurdie 262 
    Error ("BuildVersion not set")              unless ( $opt_buildversion );
6242 dpurdie 263 
    Error ("Package Name not set")              unless ( $opt_name );
6738 dpurdie 264 
    Error ("Package Version not set")           unless ( $opt_version );
6242 dpurdie 265 
    Error ("InterfaceDir not set")              unless ( $opt_interfacedir );
266 
    Error ("Target not set")                    unless ( $opt_target );
267 
    Error ("Product not set")                   unless ( $opt_product );
268 
    Error ("Packaging Script not set")          unless ( $opt_package_script );
269 
 
270 
    #
271 
    #   Read in relevent config information
272 
    #
273 
    ReadBuildConfig ($opt_interfacedir, $opt_platform, '--NoTest' );
274 
 
275 
    #
276 
    #   Build the package image in a directory based on the target being created
277 
    #
278 
    $WorkDirBase = uc("$opt_platform$opt_type.image");
279 
    $WorkDirInit = "$WorkDirBase/$opt_name";
280 
    $WorkDir = $WorkDirInit;
281 
 
7398 dpurdie 282 
    if ($opt_directPkg) {
283 
        #
284 
        #   Package directly into the package being generated
285 
        #   Place stuff into the 'pkg' subdirectory
286 
        #       Ignore the name of the package
287 
        #
288 
        $WorkDirBase = $opt_pkgdir;
289 
        $WorkDirInit = "$WorkDirBase/pkg";
290 
        $WorkDir = $WorkDirInit;
291 
    }
292 
 
6242 dpurdie 293 
    #
294 
    #   Configure the System command to fail on any error
295 
    #
296 
    SystemConfig ( ExitOnError => 1 );
297 
 
298 
    #
299 
    #   Defaults
300 
    #
301 
    $opt_pkgarch = $opt_platform unless ( $opt_pkgarch );
302 
 
303 
    #
304 
    #   Determine build operations
305 
    #
306 
    my $genDebian = $opt_debian;
307 
    my $genRpm = $opt_rpm;
7398 dpurdie 308 
    if ($opt_tarOnly || $opt_zipOnly || $opt_imageOnly || $opt_directPkg) {
6242 dpurdie 309 
        $genDebian = $genRpm = 0;
310 
    }
311 
 
312 
 
313 
    #
314 
    #   Display variables used
315 
    #
316 
    Message    ("= Building Installer ================================================");
317 
    Message    ("        Format: Debian") if ($genDebian);
318 
    Message    ("        Format: RPM") if ($genRpm);
319 
    Message    ("        Format: TGZ") if ($opt_tarFile);
6937 dpurdie 320 
    Message    ("        Format: ZIP") if ($opt_zipFile);
7398 dpurdie 321 
    Message    ("        Format: Image") if ($opt_imageOnly);
322 
    Message    ("        Format: Directly Packaged Image") if ($opt_directPkg);
6242 dpurdie 323 
    Message    ("          Name: $opt_name");
324 
    Message    ("       Package: $opt_buildname");
325 
    Message    ("       Variant: $opt_variant") if ($opt_variant);
6738 dpurdie 326 
    Message    ("       Version: $opt_version");
6242 dpurdie 327 
    Message    ("  Building for: $opt_platform");
328 
    Message    ("        Target: $opt_target") if ( $opt_platform ne $opt_target);
329 
    Message    ("       Product: $opt_product") if ($opt_product ne $opt_platform);
330 
    Message    ("          Type: $opt_type");
331 
    Message    ("   RPM Release: $opt_rpmRelease") if ($opt_rpmRelease);
332 
    Message    ("      Pkg Arch: $opt_pkgarch") if ($opt_pkgarch);
333 
    Verbose    ("       Verbose: $opt_verbose");
334 
    Verbose    ("  InterfaceDir: $opt_interfacedir");
7398 dpurdie 335 
    Message    ("        Output: " . $WorkDirInit )          if ($opt_imageOnly);
336 
    Message    ("        Output: DPKG/pkg" )                 if ($opt_directPkg);
6242 dpurdie 337 
    Message    ("        Output: " . StripDir($opt_output))  if ($genDebian || $genRpm);
338 
    Message    ("        Output: " . StripDir($opt_tarFile)) if $opt_tarFile;
6937 dpurdie 339 
    Message    ("        Output: " . StripDir($opt_zipFile)) if $opt_zipFile;
6242 dpurdie 340 
    Message    ("======================================================================");
341 
 
342 
    #
343 
    #   Perform Clean up
344 
    #   Invoked during "make clean" or "make clobber"
345 
    #
346 
    if ( $opt_clean )
347 
    {
348 
        Message ("Remove packaging directory: $WorkDirInit");
349 
 
350 
        #
351 
        #   Remove the directory for this package
352 
        #   Remove the general work dir - if all packages have been cleaned
353 
        #
354 
        rmtree( $WorkDirBase );
355 
        rmtree ($opt_tarFile) if ( defined($opt_tarFile) && -f $opt_tarFile );
6937 dpurdie 356 
        rmtree ($opt_zipFile) if ( defined($opt_zipFile) && -f $opt_zipFile );
6535 dpurdie 357 
        rmtree ($opt_output) if ( $opt_output && -f $opt_output );
6242 dpurdie 358 
        exit;
359 
    }
360 
 
361 
    #
362 
    #   NoArch sanity test
363 
    #       MUST only build no-arch for production
364 
    #       User MUST do this in the build.pl file
365 
    #
366 
    if ($opt_noarch && $opt_type ne 'P')
367 
    {
368 
        Error ("Installer Packages marked as NoArch (all) must be built ONLY for production",
369 
               "This must be configured in the build.pl" );
370 
    }
371 
 
372 
    #
373 
    #   Clean  out the WORK directory
374 
    #   Always start with a clean slate
375 
    #
376 
    #   Ensure that the base of the directory tree does not have 'setgid'
377 
    #       This will upset the debian packager
378 
    #       This may be an artifact from the users directory and not expected
379 
    #
380 
    rmtree( $WorkDirInit );
381 
    mkpath( $WorkDirInit );
382 
 
383 
    my $perm = (stat $WorkDirInit)[2] & 0777;
384 
    chmod ( $perm & 0777, $WorkDirInit );
385 
 
386 
    #
387 
    #   Invoke the user script to do the hard work
388 
    #       Use abs path to avoid issues:
389 
    #           * '.' not buing in search path
390 
    #           * Script name = DebianPackager.pl
391 
    $opt_package_script = AbsPath($opt_package_script);
392 
    unless (my $return = do $opt_package_script) {
393 
            Error ("Couldn't parse $opt_package_script: $@") if $@;
394 
            Error ("Couldn't do $opt_package_script: $!") unless defined $return;
395 
        };
396 
    $ActiveSection = 1;
397 
 
398 
    #
399 
    #   Now have an image of the directory that we wish to package
400 
    #   Complete the building of the package
401 
    #
402 
    if ($opt_tarFile) {
403 
        BuildTarFile();
404 
        Message ("Created TGZ file");
405 
    }
406 
 
6937 dpurdie 407 
    if ($opt_zipFile) {
408 
        BuildZipFile();
409 
        Message ("Created ZIP file");
410 
    }
411 
 
6242 dpurdie 412 
    #
413 
    #   Create an RPM
414 
    #
415 
    if ($genRpm) {
416 
        BuildRPM ();
417 
        Message ("Created RPM");
418 
    }
419 
 
420 
    #
421 
    #   Create a Debian Package
422 
    #
423 
    if ($genDebian) {
424 
        BuildDebianPackage ();
425 
        Message ("Created Debian Package");
426 
    }
427 
}
428 
 
429 
#-------------------------------------------------------------------------------
430 
# Function        : BuildRPM
431 
#
432 
# Description     : This function will create the Debian Package
433 
#                   and transfer it to the target directory
434 
#
435 
# Inputs          : None
436 
#
437 
# Returns         : Nothing
438 
#
439 
sub BuildRPM
440 
{
441 
    #
442 
    #   Sanity Checks
443 
    #
444 
    Error ("BuildRPM: Release")
445 
        unless ( $opt_rpmRelease );
446 
    Error ("BuildRPM: No Control File or Package Description")
447 
        unless ( exists($ControlFiles{'control'}) || $opt_description );
448 
 
449 
    #
450 
    #   Massage the 'control' file
451 
    #   Generate or Massage
452 
    #
453 
    $opt_specFile = catfile($WorkDirBase, 'RPM.spec' );
454 
    UpdateRedHatControlFile ($ControlFiles{'control'} );
455 
 
456 
    #   Generate a dummy rc file
457 
    my $rcFile = catdir($WorkDirBase,'tmprc');
458 
    TouchFile($rcFile);
459 
 
460 
    #
461 
    #   Run the RPM builder
462 
    #   Expect it to be installed on the build machine
463 
    #
464 
    my $prog = LocateProgInPath( 'rpmbuild', '--All');
465 
    Error ("RPM Packager: The rpmbuild utility is not installed") unless $prog;
466 
    System ($prog, '-bb', $opt_specFile,
467 
                   '--buildroot', AbsPath($WorkDirInit) ,
468 
                   '--define', '_rpmdir ' . StripFileExt($opt_output),
469 
                   '--define', '_rpmfilename ' .  StripDir($opt_output),
470 
                   '--define', '_topdir ' . catfile($WorkDirBase, 'RPMBUILD' ),
471 
                   '--noclean',
472 
                   $opt_verbose ? '-v' : '--quiet',
473 
                   #$opt_noarch ?  '--target=noarch' : undef,
474 
                   '--rcfile', $rcFile ,
475 
                   );
476 
 
477 
 
478 
}
479 
 
480 
#-------------------------------------------------------------------------------
481 
# Function        : BuildDebianPackage
482 
#
483 
# Description     : This function will create the Debian Package
484 
#                   and transfer it to the target directory
485 
#
486 
# Inputs          : None
487 
#
488 
# Returns         : Nothing
489 
#
490 
sub BuildDebianPackage
491 
{
492 
    Error ("BuildDebianPackage: No Control File or Package Description")
493 
        unless ( exists($ControlFiles{'control'}) || $opt_description );
494 
 
495 
    #
496 
    #   Convert the FileSystem Image into a Debian Package
497 
    #       Insert Debian control files
498 
    #
499 
    Verbose ("Copy in the Debian Control Files");
500 
    mkdir ( "$WorkDirInit/DEBIAN" );
501 
 
502 
    #
503 
    #   Copy in all the named Debian Control files
504 
    #       Ignore any control file. It will be done next
505 
    #
506 
    foreach my $key ( keys %ControlFiles )
507 
    {
508 
        next if ($key eq 'control');
509 
        CopyFile ( $ControlFiles{$key}, '/DEBIAN', $key  );
510 
    }
511 
 
512 
    #
513 
    #   Create 'conffiles'
514 
    #       Append to any user provided file
515 
    if ( @ConfigList )
516 
    {
517 
        my $conffiles = "$WorkDirInit/DEBIAN/conffiles";
518 
        Warning("Appending user specified entries to conffiles") if ( -f $conffiles);
519 
        FileAppend( $conffiles, @ConfigList );
520 
    }
521 
 
522 
    #
523 
    #   Massage the 'control' file
524 
    #
525 
    UpdateDebianControlFile ($ControlFiles{'control'} );
526 
 
527 
    #
528 
    #   Mark all files in the debian folder as read-execute
529 
    #
530 
    System ( 'chmod', '-R', 'a+rx', "$WorkDirInit/DEBIAN" );
531 
    System ( 'build_dpkg.sh', '-b', $WorkDirInit);
532 
    System ( 'mv', '-f', "$WorkDirInit.deb", $opt_output );
533 
 
534 
    System ("build_dpkg.sh", '-I', $opt_output) if (IsVerbose(1));
535 
 
536 
}
537 
 
538 
#-------------------------------------------------------------------------------
539 
# Function        : BuildTarFile
540 
#
541 
# Description     : This function will create a TGZ file of the constructed package
542 
#                   Not often used
543 
#
544 
# Inputs          : None
545 
#
546 
# Returns         : Nothing
547 
#
548 
sub BuildTarFile
549 
{
550 
    Verbose ("Create TGZ file containing body of the package");
551 
    System ('tar',
552 
            '--create',
553 
            '--auto-compress',
554 
            '--owner=0' ,
555 
            '--group=0' ,
556 
            '--one-file-system' ,
557 
            '--exclude=./DEBIAN' ,
558 
            '-C', $WorkDirInit,
559 
            '--file', $opt_tarFile,
560 
            '.'
561 
            );
562 
}
563 
 
564 
#-------------------------------------------------------------------------------
6937 dpurdie 565 
# Function        : BuildZipFile
566 
#
567 
# Description     : This function will create a ZIP file of the constructed package
568 
#                   Not often used
569 
#
570 
#                   Tricky bit is excluding the DEBIAN directory
571 
#
572 
# Inputs          : None
573 
#
574 
# Returns         : Nothing
575 
#
576 
sub BuildZipFile
577 
{
578 
    Verbose ("Create ZIP file containing body of the package");
579 
 
580 
    my $zip = Archive::Zip->new();
581 
    $zip->addTree( $WorkDirInit, '', sub { $_ !~ m~^DEBIAN$~ } );
582 
    if ( $zip->writeToFileNamed($opt_zipFile) != AZ_OK ) {
583 
        Error("Canot create ZIP file");
584 
    }
585 
}
586 
 
587 
#-------------------------------------------------------------------------------
6242 dpurdie 588 
# Function        : Section
589 
#
590 
# Description     : Allows the Package file to be split into section
591 
#                   This direcive is always active.
592 
#
593 
# Inputs          : Selector
594 
#                       ALL     - Active
595 
#                       RPM     - Active section when building an RPM
596 
#                       DEBIAN  - Active section if build a Debian package
597 
#                       TAR     - Active section if building a TAR
6937 dpurdie 598 
#                       ZIP     - Active section if building a ZIP
6242 dpurdie 599 
#
600 
# Returns         : Nothing
601 
#                   Will fkag to indicate if directives are active.
602 
#
603 
sub Section
604 
{
605 
    my $newActiveSection;
606 
    my $flip = sub {
607 
        my ($val, $mode) = @_;
608 
        if ( defined $mode) {
609 
            return $val ? 0 : 1;
610 
        }
611 
        return $val;
612 
    };
613 
 
614 
    $newActiveSection = 1 unless (@_);
615 
    foreach my $arg ( @_)
616 
    {
617 
        if ($arg =~ m/^(!)*DEBIAN/i) {
618 
            $newActiveSection = 1 if  $flip->($opt_debian, $1);
619 
 
620 
        } elsif ($arg =~ m/^(!)*RPM/i) {
621 
            $newActiveSection = 1 if  $flip->($opt_rpm, $1);
622 
 
623 
        } elsif ($arg =~ m/^(!)*TAR/i) {
624 
            $newActiveSection = 1 if $flip->($opt_tarFile, $1);
625 
 
6937 dpurdie 626 
        } elsif ($arg =~ m/^(!)*ZIP/i) {
627 
            $newActiveSection = 1 if $flip->($opt_zipFile, $1);
628 
 
6242 dpurdie 629 
        } elsif (uc($arg) eq 'ALL') {
630 
            $newActiveSection = 1;
631 
 
632 
        } elsif ( $arg eq 1  ) {
633 
                $newActiveSection = 1;
634 
 
635 
        } elsif ( $arg eq 0  ) {
636 
 
637 
        } else {
638 
            Warning ("Section: Unknown argument $arg");
639 
        }
640 
    }
641 
 
642 
    $ActiveSection = $newActiveSection ? 1: 0;
643 
    Verbose ("Section State: $ActiveSection");
644 
 
645 
}
646 
 
647 
#-------------------------------------------------------------------------------
648 
# Function        : UpdateDebianControlFile
649 
#
650 
# Description     : Update the Debian 'control' file to fix up various fields
651 
#                   within the file.
652 
#
653 
#                   If the files has not been specified, then a basic control
654 
#                   file will be provided.
655 
#
656 
#                   This routine knows where the control file will be placed
657 
#                   within the output work space.
658 
#
659 
# Inputs          : $src            - Path to source file
660 
#                   Uses global variables
661 
#
662 
# Returns         : Nothing
663 
#
664 
sub UpdateDebianControlFile
665 
{
666 
    my($src) = @_;
667 
    return 1 unless ($ActiveSection);
668 
    my $dst = "$WorkDirInit/DEBIAN/control";
669 
 
670 
    unless ( $src )
671 
    {
672 
        CreateDebianControlFile();
673 
        return;
674 
    }
675 
 
676 
    #
677 
    #   User has provided a control file
678 
    #       Tweak the internals
679 
    #
680 
    Verbose ("UpdateDebianControlFile: $dst" );
681 
    $src = ResolveFile( 0, $src );
682 
 
683 
    #   Calc depends line
684 
    my $depData = join (', ', @DependencyList );
685 
 
686 
    open (SF, '<', $src) || Error ("UpdateDebianControlFile: Cannot open:$src, $!");
687 
    open (DF, '>', $dst) || Error ("UpdateDebianControlFile: Cannot create:$dst, $!");
688 
    while ( <SF> )
689 
    {
690 
        s~\s*$~~;
691 
        if ( m~^Package:~ ) {
692 
            $_ = "Package: $opt_name";
693 
 
694 
        } elsif ( m~^Version:~ ) {
6738 dpurdie 695 
            $_ = "Version: $opt_version";
6242 dpurdie 696 
 
697 
        } elsif ( m~^Architecture:~ ) {
698 
            $_ = "Architecture: $opt_pkgarch";
699 
 
700 
        } elsif ( $opt_description && m~^Description:~ ) {
701 
            $_ = "Description: $opt_description";
702 
 
703 
        } elsif ( m~^Depends:~ ) {
704 
            $_ = "Depends: $depData";
705 
            $depData = '';
706 
        }
707 
        print DF $_ , "\n";
708 
    }
709 
 
710 
    close (SF);
711 
    close (DF);
712 
 
713 
    #
714 
    #   Warn if Depends section is needed
715 
    #
716 
    Error ("No Depends section seen in user control file")
717 
        if ($depData);
718 
}
719 
 
720 
#-------------------------------------------------------------------------------
721 
# Function        : CreateDebianControlFile
722 
#
723 
# Description     : Create a basic debian control file
724 
#
725 
# Inputs          : Uses global variables
726 
#
727 
# Returns         :
728 
#
729 
sub CreateDebianControlFile
730 
{
731 
    return 1 unless ($ActiveSection);
732 
    my $dst = "$WorkDirInit/DEBIAN/control";
733 
 
734 
    Verbose ("CreateDebianControlFile: $dst" );
735 
 
736 
    my $depData = join (', ', @DependencyList );
737 
 
738 
    open (DF, '>', $dst) || Error ("CreateDebianControlFile: Cannot create:$dst");
739 
    print DF "Package: $opt_name\n";
6738 dpurdie 740 
    print DF "Version: $opt_version\n";
6242 dpurdie 741 
    print DF "Section: main\n";
742 
    print DF "Priority: standard\n";
743 
    print DF "Architecture: $opt_pkgarch\n";
744 
    print DF "Essential: No\n";
745 
    print DF "Maintainer: Vix Technology\n";
746 
    print DF "Description: $opt_description\n";
747 
    print DF "Depends: $depData\n" if ($depData);
748 
 
749 
    close (DF);
750 
}
751 
 
752 
#-------------------------------------------------------------------------------
753 
# Function        : UpdateRedHatControlFile
754 
#
755 
# Description     : Update the Redhat 'control' file to fix up various fields
756 
#                   within the file.
757 
#
758 
#                   If the files has not been specified, then a basic control
759 
#                   (spec) file will be provided.
760 
#                   Various tags will be replaced
761 
#                       tag_name
762 
#                       tag_version
763 
#                       tag_buildarch
764 
#                       tag_release
765 
#                       tag_description
766 
#                       tag_requires
767 
#                       tag_filelist
768 
#
769 
# Inputs          : $src            - Path to source file
770 
#                   Uses global variables
771 
#
772 
# Returns         : Nothing
773 
#
774 
sub UpdateRedHatControlFile
775 
{
776 
    my($src) = @_;
777 
    return 1 unless ($ActiveSection);
778 
    my $dst = $opt_specFile;
779 
    unless ( $src )
780 
    {
781 
        CreateRedHatControlFile();
782 
        return;
783 
    }
784 
 
785 
    #
786 
    #   User has provided a control file
787 
    #       Tweak the internals
788 
    #
789 
    Verbose ("UpdateRedHatControlFile: $dst" );
790 
    $src = ResolveFile( 0, $src );
791 
 
792 
    my @depList = @DependencyList;
793 
    my $cleanSeen;
794 
 
795 
    open (my $sf, '<', $src) || Error ("UpdateRedHatControlFile: Cannot open:$src, $!");
796 
    open (my $df, '>', $dst) || Error ("UpdateRedHatControlFile: Cannot create:$dst, $!");
797 
    while ( <$sf> )
798 
    {
799 
        s~\s*$~~;
800 
        if ( m~^tag_Name~i ) {
801 
            $_ = "Name: $opt_name";
802 
 
803 
        } elsif ( m~^tag_Version~i ) {
6738 dpurdie 804 
            $_ = "Version: $opt_version";
6242 dpurdie 805 
 
806 
        } elsif ( m~^tag_BuildArch~i ) {
807 
            $_ = "BuildArch: $opt_pkgarch";
808 
 
809 
        } elsif ( m~^tag_Release~i ) {
810 
            $_ = "Release: $opt_rpmRelease";
811 
 
812 
        } elsif ( $opt_description && m~^tag_Description~i ) {
813 
            print $df "%description\n";
814 
            print $df "$opt_description\n";
815 
            $_ = undef;
816 
 
817 
        } elsif ( m~^tag_Requires~i ) {
818 
            foreach my $item (@depList) {
819 
                print $df "Requires:       $item\n";
820 
            }
821 
            $_ = undef;
822 
            @depList = ();
823 
 
824 
        } elsif ( m~^tag_filelist~i ) {
825 
            GenerateRedHatFileList ($df);
826 
            $_ = undef;
827 
 
828 
        } elsif ( m~^%clean~i ) {
829 
            $cleanSeen  = 1;
830 
        }
831 
        print $df ($_ , "\n") if defined ($_);
832 
    }
833 
 
834 
    close ($sf);
835 
    close ($df);
836 
 
837 
    #
838 
    #   Warn if Depends section is needed
839 
    #
840 
    Error ("No %clean section seen in user control file") unless $cleanSeen;
841 
    Error ("No Requires tag seen in user control file") if (@depList);
842 
}
843 
 
844 
#-------------------------------------------------------------------------------
845 
# Function        : CreateRedHatControlFile
846 
#
847 
# Description     : Create a binary RedHat spec file
848 
#
849 
# Inputs          : Uses global variables
850 
#
851 
# Returns         :
852 
#
853 
sub CreateRedHatControlFile
854 
{
855 
    #
856 
    #   Generate the RPM spec file
857 
    #
858 
    open (my $sf, '>', $opt_specFile) || Error ("RPM Spec File: Cannot create: $opt_specFile, $!");
859 
 
860 
    # Standard tags
861 
    print $sf ("# Standard SPEC Tags\n");
862 
    print $sf "Summary:        Installer for the $opt_name Package\n";
863 
    print $sf "Name:           $opt_name\n";
6738 dpurdie 864 
    print $sf "Version:        $opt_version\n";
6242 dpurdie 865 
    print $sf "Release:        $opt_rpmRelease\n";
866 
    print $sf "License:        COPYRIGHT - VIX IP PTY LTD (\"VIX\"). ALL RIGHTS RESERVED.\n";
867 
    print $sf "Source:         None\n";
868 
    print $sf "BuildArch:      $opt_pkgarch\n";
869 
    print $sf "Group:          VIX/System\n";
870 
    print $sf "Vendor:         Vix Technology\n";
871 
    print $sf "Autoreq:        No\n";
872 
    #
873 
    #   Requires tags
874 
    #
875 
    print $sf "\n# Dependencies\n" if @DependencyList;
876 
    foreach my $item (@DependencyList) {
877 
        print $sf "Requires:       $item\n";
878 
    }
879 
 
880 
    print $sf "\n";
881 
    print $sf "%description\n";
882 
    print $sf "$opt_description\n";
883 
 
884 
    print $sf "\n";
885 
    print $sf "%clean\n";
886 
 
887 
    #
888 
    #   Insert various scripts
889 
    #
890 
    my $insertRpmControlFile = sub {
891 
        my ($sname, $cname) = @_;
892 
        if ( my $src = $ControlFiles{$cname} ) {
893 
            print $sf "\n";
894 
            print $sf '%' . $sname . "\n";
895 
            open ( my $cf, '<', $src ) || Error ("BuildRPM: Cannot open:$src, $!");
896 
            while ( <$cf> ) {
897 
                $_ =~ s~\%~%%~g;
898 
                print $sf $_;
899 
            }
900 
            close ($cf);
901 
            print $sf "\n";
902 
        }
903 
    };
904 
 
905 
    #   Run the PreInstall script as %pretrans
906 
    #       %pretrans is the only script that can terminate the RPM installation
907 
    &$insertRpmControlFile ('pretrans', 'preinst');
908 
    &$insertRpmControlFile ('post',     'postinst');
909 
    &$insertRpmControlFile ('preun',    'prerm');
910 
    &$insertRpmControlFile ('postun',   'postrm');
911 
 
912 
    #
7268 dpurdie 913 
    #   On many packages the RPM "Checking for unpackaged file(s)"
914 
    #   can take a long while (minutes). It can't be disabled
915 
    #   but it can be made faster by disabling compression of the RPM
916 
    #
917 
    print $sf "\n%define _unpackaged_files_terminate_build 0\n";
918 
    print $sf "\n%define _source_payload w0.gzdio\n";
919 
    print $sf "\n%define _binary_payload w0.gzdio\n";
920 
 
921 
    #
6242 dpurdie 922 
    #   Insert the list of files to be processed
923 
    #       Can't use /* as this will mess with permissions of the root directory.
924 
    #       Can list Top Level directories and then use *
925 
    #
926 
    print $sf "\n%files\n";
927 
    print $sf "%defattr(",join (',', @RpmDefAttr),")\n";
928 
    GenerateRedHatFileList ($sf);
929 
    print $sf "\n";
930 
    close ($sf);
931 
}
932 
 
933 
#-------------------------------------------------------------------------------
934 
# Function        : GenerateRedHatFileList
935 
#
936 
# Description     : Internal function
937 
#                   Generate a file list to be inserted into an RPM spec file
938 
#
939 
# Inputs          : $fd     - File descriptor.
940 
#                             Function will write directly to the output
941 
#
942 
# Returns         : Nothing
943 
#
944 
sub GenerateRedHatFileList
945 
{
946 
    my ($fd) = @_;
947 
 
948 
    #
949 
    #   Sanity Test
950 
    #
951 
    Warning ("No directories has been marked as 'Owned'",
952 
             "Under RedHat a directory must be 'owned' by a package so that it can be removed.",
953 
             "This ownership may be in that package or a 'Required' package.",
954 
             "This ownership may be shared or exclusive.",
955 
             ) unless scalar keys %OwnedDirs;
956 
 
957 
    #
958 
    #   Flag files and directories with attributes
959 
    #
960 
    my %Attrs;
961 
    my %Dirs;
962 
    foreach my $item ( @RpmAttrList ) {
963 
        my $file =  $item->[0];
964 
        my $full_path = $WorkDirInit . $file;
965 
        $Attrs{$file} =  '%attr(' . join(',',@{$item}[1..3] ) . ')';
966 
        $Dirs{$file} = '%dir' if (-d $full_path);
967 
    }
968 
 
969 
    #
970 
    #   Flag configuration files ( ConfFile )
971 
    #
972 
    my %Configs;
973 
    foreach my $item (@ConfigList) {
974 
        $Configs{$item} = '%config';
975 
    }
976 
 
977 
    #
978 
    #   Internal subroutine to pretty-print a file/dirname with attributes
979 
    #       $path   - path element
980 
    #       $isDir  - True if a directory
981 
    #
982 
    my $printer = sub {
983 
        my ($path, $isDir) = @_;
984 
        my $attrText =  delete $Attrs{$path};
985 
        my $confText =  delete $Configs{$path};
986 
        my $dirText  =  delete $Dirs{$path};
987 
        $dirText = '%dir' if $isDir;
988 
 
989 
        my $txt;
990 
        my $joiner = '';
991 
        $path = '"' . $path . '"';
992 
        foreach ($attrText,$dirText,$confText, $path) {
993 
            next unless $_;
994 
            $txt .= $joiner . $_;
995 
            $joiner = ' ';
996 
        }
997 
        print $fd ("$txt\n");
998 
    };
999 
 
1000 
    #
1001 
    #   List all files in the tree
1002 
    #       If we use wildcards we get interpackage dependency issues
1003 
    #       Process files and directories
1004 
    #
1005 
    my $search =  JatsLocateFiles->new( '--Recurse', '--NoFullPath', '--DirsToo' );
1006 
    my @flist = $search->search($WorkDirInit);
1007 
    foreach (@flist) {
1008 
        my $file = '/' . $_;
1009 
        my $full_path = $WorkDirInit . $file;
1010 
        my $isDir = (-d $full_path) || 0;
1011 
 
1012 
        #
1013 
        #   Determine if the element is within a known RootDir
1014 
        #
1015 
        my $inRoot = 0;
1016 
        my $isOwner = 0;
1017 
        foreach (keys %OwnedDirs) {
1018 
            if ($file =~ m~^$_~) {
1019 
                $inRoot = 1;
1020 
                $isOwner = $OwnedDirs {$_};
1021 
                last;
1022 
            }
1023 
        }
1024 
 
1025 
        #
1026 
        #   Ignore directories that are not within a RootDir
1027 
        #
1028 
        unless ($inRoot) {
1029 
            next if $isDir;
1030 
        }
1031 
 
1032 
        #
1033 
        #   Ignore directories that are not within an 'owned' directory
1034 
        #
1035 
        if ( !$isOwner && $isDir ) {
1036 
            next;
1037 
        }
1038 
 
1039 
        &$printer($file, $isDir);
1040 
    }
1041 
 
1042 
    #
1043 
    #   Sanity tests
1044 
    #   We should have process all the Configs and Attributes
1045 
    #
1046 
    if ( (keys %Configs) || ( keys %Attrs))
1047 
    {
1048 
        Error ("Internal Error. Unprocessed Config or Attributes.",
1049 
               keys %Configs, keys %Attrs );
1050 
    }
1051 
 
1052 
}
1053 
 
1054 
#-------------------------------------------------------------------------------
1055 
# Function        : SetVerbose
1056 
#
1057 
# Description     : Set the level of verbosity
1058 
#                   Display activity
1059 
#
1060 
# Inputs          : Verbosity level
1061 
#                       0 - Use makefile verbosity (Default)
1062 
#                       1..2
1063 
#
1064 
# Returns         :
1065 
#
1066 
sub SetVerbose
1067 
{
1068 
    return 1 unless ($ActiveSection);
1069 
    my ($level) = @_;
1070 
 
1071 
    $level = $opt_verbose unless ( $level );
1072 
    $opt_verbose = $level;
1073 
    ErrorConfig( 'verbose' => $level);
1074 
}
1075 
 
1076 
#-------------------------------------------------------------------------------
1077 
# Function        : SetBaseDir
1078 
#
1079 
# Description     : Sets the root directory for all directories
1080 
#                   Used to simplify scripts
1081 
#
1082 
# Inputs          : $path           - Absolute path. Now within the RootDir
1083 
#                   @options        - As for CreateDir
1084 
#
1085 
# Returns         : Nothing
1086 
#                   Sets $WorkDir
1087 
#
1088 
sub SetBaseDir
1089 
{
1090 
    my ($path, @opts) = @_;
1091 
    return 1 unless ($ActiveSection);
1092 
 
1093 
    my $rootdir = $path || '/';
1094 
    $rootdir = '/' . $rootdir;
1095 
    $rootdir =~ s~/+~/~g;
1096 
    Verbose ("Setting RootDir: $rootdir");
1097 
 
1098 
    #
1099 
    #   Create the directory
1100 
    #
1101 
    $WorkDir = $WorkDirInit;
1102 
    CreateDir ($rootdir, @opts);
1103 
    $WorkSubDir = $rootdir;
1104 
    $WorkDir = $WorkDirInit . $rootdir;
1105 
}
1106 
 
1107 
#-------------------------------------------------------------------------------
1108 
# Function        : DebianFiles
1109 
#                   RpmFiles
1110 
#                   AllFiles
1111 
#
1112 
# Description     : Name Debian and RPM builder control files
1113 
#                   May be called multiple times
1114 
#
1115 
# Inputs          :   $fName    - Name under which the function is being called
1116 
#                     Options
1117 
#                       --Control=file
1118 
#                       --PreRm=file
1119 
#                       --PostRm=file
1120 
#                       --PreInst=file
1121 
#                       --PostInst=file
1122 
#                       --SimpleSharedLibs
1123 
#
1124 
#
1125 
# Returns         : Nothing
1126 
#
1127 
sub MULTI_Files
1128 
{
1129 
    my $fName = shift;
1130 
    return 1 unless ($ActiveSection);
1131 
    Verbose ("Specify Installer Control Files and Scripts");
1132 
    foreach  ( @_ )
1133 
    {
1134 
        if ( m/^--Control=(.+)/i ) {
1135 
            MULTI_ControlFile($fName, 'control',$1)
1136 
 
1137 
        } elsif ( m/^--PreRm=(.+)/i ) {
1138 
            MULTI_ControlFile($fName, 'prerm',$1)
1139 
 
1140 
        } elsif ( m/^--PostRm=(.+)/i ) {
1141 
            MULTI_ControlFile($fName, 'postrm',$1)
1142 
 
1143 
        } elsif ( m/^--PreInst=(.+)/i ) {
1144 
            MULTI_ControlFile($fName, 'preinst',$1)
1145 
 
1146 
        } elsif ( m/^--PostInst=(.+)/i ) {
1147 
            MULTI_ControlFile($fName, 'postinst',$1)
1148 
 
1149 
        } elsif ( m/^--SimpleSharedLibs/i ) {
1150 
 
1151 
            my $file = catfile($WorkDirBase, 'ldconfig.sh' );
1152 
 
1153 
            open (my $df, '>', $file) || Error ("$fName: Cannot create:$file");
1154 
            print $df "#!/bin/sh\n";
1155 
            print $df "/sbin/ldconfig\n";
1156 
            print $df "exit 0\n";
1157 
            close $df;
1158 
 
1159 
            MULTI_ControlFile($fName, 'postinst',$file);
1160 
            MULTI_ControlFile($fName, 'postrm',$file);
1161 
 
1162 
        } else {
1163 
            Error ("$fName: Unknown option: $_");
1164 
        }
1165 
    }
1166 
}
1167 
 
1168 
#-------------------------------------------------------------------------------
1169 
# Function        : DebianControlFile
1170 
#                   RpmControlFile
1171 
#                   AllControlFile
1172 
#
1173 
# Description     : Add special control files to the Debian/RedHat Installer
1174 
#                   Not useful for embedded installers
1175 
#
1176 
#                   More general than DebianFiles() or RpmFiles
1177 
#
1178 
# Inputs          : name            - Target Name
1179 
#                                     If the name starts with 'package.' then it will be replaced
1180 
#                                     with the name of the current package
1181 
#                                     Ideally: prerm, postrm, preinst, postinst
1182 
#                   file            - Source File Name
1183 
#                   options         - Options include
1184 
#                                       --FromPackage
1185 
#
1186 
# Returns         :
1187 
#
1188 
sub MULTI_ControlFile
1189 
{
1190 
    my ($fName, $name, $file, @options) = @_;
1191 
    return 1 unless ($ActiveSection);
1192 
    my $fromPackage = 0;
1193 
 
1194 
    #
1195 
    #   Process options
1196 
    foreach ( @options)
1197 
    {
1198 
        if (m~^--FromPackage~) {
1199 
            $fromPackage = 1;
1200 
        }
1201 
        else  {
1202 
            ReportError(("$fName: Unknown argument: $_"));
1203 
        }
1204 
    }
1205 
    ErrorDoExit();
1206 
 
1207 
    #
1208 
    #   Some control files need to have the package name prepended
1209 
    #
1210 
    $name =~ s~^package\.~$opt_name.~;
1211 
 
1212 
    #
1213 
    #   Only allow one file of each type
1214 
    #       Try to protect the user by testing for names by lowercase
1215 
    #
1216 
    my $simpleName = lc($name);
1217 
    Error("$fName: Multiple definitions for '$name' not allowed")
1218 
        if (exists $ControlFileNames{$simpleName});
1219 
 
1220 
    my $filePath = ResolveFile($fromPackage, $file);
1221 
 
1222 
    #
1223 
    #   Add info to data structures
1224 
    #
1225 
    $ControlFiles{$name} = $filePath;
1226 
    $ControlFileNames{$simpleName} = $name;
1227 
}
1228 
 
1229 
#-------------------------------------------------------------------------------
1230 
# Function        : DebianDepends
1231 
#                   RpmDepends
1232 
#                   AllDepends
1233 
#
1234 
# Description     : This directive allows simple dependency information to be
1235 
#                   inserted into the control file
1236 
#
1237 
#                   Names will be massaged into conforming names.
1238 
#
1239 
#                   Not useful in embedded system
1240 
#
1241 
# Inputs          : Entry             - A dependency entry
1242 
#                   ...               - More entries
1243 
#                   Options
1244 
#                       --Raw          - Prevent name modification
1245 
#                       --NoRaw        - Enable name modification
1246 
#
1247 
#
1248 
# Returns         : Nothing
1249 
#
1250 
sub MULTI_Depends
1251 
{
1252 
    return 1 unless ($ActiveSection);
1253 
    shift;
1254 
    my $raw = 0;
1255 
 
1256 
    #
1257 
    #   Convert the provided name into a canonical name
1258 
    #   Simplifies use when using both RPM and Debian
1259 
    foreach ( @_)
1260 
    {
1261 
        if (m~^--(No)?Raw~i) {
1262 
            $raw = ! defined($1);
1263 
            next;
1264 
        }
1265 
        my $name = $_;
1266 
        $name = canonicalName($_, $opt_rpm ? 'RPM' : 'DEBIAN' , 1) unless $raw;
1267 
        push @DependencyList, $name;
1268 
    }
1269 
 
1270 
}
1271 
 
1272 
#-------------------------------------------------------------------------------
1273 
# Function        : PackageDescription
1274 
#
1275 
# Description     : Specify the Package Description
1276 
#                   Keep it short
1277 
#
1278 
# Inputs          : $description
1279 
#
1280 
# Returns         :
1281 
#
1282 
sub PackageDescription
1283 
{
1284 
    return 1 unless ($ActiveSection);
1285 
    ($opt_description) = @_;
1286 
}
1287 
 
1288 
#-------------------------------------------------------------------------------
1289 
# Function        : MakeSymLink
1290 
#
1291 
# Description     : Create a symlink - with error detection
1292 
#
1293 
# Inputs          : old_file    - Link Target
1294 
#                                 Path to the link target
1295 
#                                 If an ABS path is provided, the routine will
1296 
#                                 attempt to create a relative link.
1297 
#                   new_file    - Relative to the output work space
1298 
#                                 Path to where the 'link' file will be created
1299 
#                   Options     - Must be last
1300 
#                                 --NoClean         - Don't play with links
1301 
#                                 --NoDotDot        - Don't create symlinks with ..
1302 
#
1303 
# Returns         : Nothing
1304 
#
1305 
sub MakeSymLink
1306 
{
1307 
    my $no_clean;
1308 
    my $no_dot;
1309 
    my @args;
1310 
    return 1 unless ($ActiveSection);
1311 
 
1312 
    #
1313 
    #   Extract options
1314 
    #
1315 
    foreach ( @_ )
1316 
    {
1317 
        if ( m/^--NoClean/i ) {
1318 
            $no_clean = 1;
1319 
 
1320 
        } elsif ( m/^--NoDotDot/i ) {
1321 
            $no_dot = 1;
1322 
 
1323 
        } elsif ( m/^--/ ) {
1324 
            Error ("MakeSymLink: Unknown option: $_");
1325 
 
1326 
        } else {
1327 
            push @args, $_;
1328 
        }
1329 
    }
1330 
 
1331 
    my ($old_file, $new_file) = @args;
1332 
 
1333 
    my $tfile = $WorkDir . '/' . $new_file;
1334 
    $tfile =~ s~//~/~;
1335 
    Verbose ("Symlink $old_file -> $new_file" );
1336 
 
1337 
    #
1338 
    #   Create the directory in which the link will be placed
1339 
    #   Remove any existing file of the same name
1340 
    #
1341 
    my $dir = StripFileExt( $tfile );
1342 
    mkpath( $dir) unless -d $dir;
1343 
    unlink $tfile;
1344 
 
1345 
    #
1346 
    #   Determine a good name of the link
1347 
    #   Convert to a relative link in an attempt to prune them
1348 
    #
1349 
    my $sfile = $old_file;
1350 
    unless ( $no_clean )
1351 
    {
1352 
        $sfile = CalcRelPath( StripFileExt( $new_file ), $old_file );
1353 
        $sfile = $old_file if ( $no_dot && $sfile =~ m~^../~ );
1354 
    }
1355 
 
1356 
    my $result = symlink $sfile, $tfile;
1357 
    Error ("Cannot create symlink. $old_file -> $new_file") unless ( $result );
1358 
}
1359 
 
1360 
#-------------------------------------------------------------------------------
1361 
# Function        : CopyFile
1362 
#
1363 
# Description     : Copy a file to a target dir
1364 
#                   Used for text files, or files with fixed names
1365 
#
1366 
# Inputs          : $src
1367 
#                   $dst_dir    - Within the output workspace
1368 
#                   $dst_name   - Output Name [Optional]
1369 
#                   Options     - Common Copy Options
1370 
#
1371 
# Returns         : Full path to destination file
1372 
#
1373 
sub CopyFile
1374 
{
1375 
    return 1 unless ($ActiveSection);
1376 
    CopyFileCommon( \&ResolveFile, @_ );
1377 
}
1378 
 
1379 
#-------------------------------------------------------------------------------
1380 
# Function        : CopyBinFile
1381 
#
1382 
# Description     : Copy a file to a target dir
1383 
#                   Used for executable programs. Will look in places where
1384 
#                   programs are stored.
1385 
#
1386 
# Inputs          : $src
1387 
#                   $dst_dir    - Within the output workspace
1388 
#                   $dst_name   - Output Name [Optional]
1389 
#
1390 
#                   Options:
1391 
#                       --FromPackage
1392 
#                       --SoftLink=xxxx
1393 
#                       --LinkFile=xxxx
1394 
#
1395 
# Returns         : Full path to destination file
1396 
#
1397 
sub CopyBinFile
1398 
{
1399 
    return 1 unless ($ActiveSection);
1400 
    CopyFileCommon( \&ResolveBinFile, @_ );
1401 
}
1402 
 
1403 
#-------------------------------------------------------------------------------
1404 
# Function        : CopyLibFile
1405 
#
1406 
# Description     : Copy a file to a target dir
1407 
#                   Used for shared programs. Will look in places where
1408 
#                   shared libraries are stored.
1409 
#
1410 
# Inputs          : $src        - Base for 'realname' (no lib, no extension)
1411 
#                   $dst_dir    - Within the output workspace
1412 
#                   $dst_name   - Output Name [Optional, but not suggested]
1413 
#
1414 
# Returns         : Full path to destination file
1415 
#
1416 
# Notes           : Copying 'lib' files
1417 
#                   These are 'shared libaries. There is no provision for copying
1418 
#                   static libraries.
1419 
#
1420 
#                   The tool will attempt to copy a well-formed 'realname' library
1421 
#                   The soname of the library should be constructed on the target
1422 
#                   platform using ldconfig.
1423 
#                   There is no provision to copy the 'linker' name
1424 
#
1425 
#                   Given a request to copy a library called 'fred', then the
1426 
#                   well formed 'realname' will be:
1427 
#                           libfred[P|D|]].so.nnnnn
1428 
#                   where:
1429 
#                           nnnn is the library version
1430 
#                           [P|D|] indicates Production, Debug or None
1431 
#
1432 
#                   The 'soname' is held within the realname form of the library
1433 
#                   and will be created by lsconfig.
1434 
#
1435 
#                   The 'linkername' would be libfred[P|D|].so. This is only
1436 
#                   needed when linking against the library.
1437 
#
1438 
#
1439 
#                   The routine will also recognize Windows DLLs
1440 
#                   These are of the form fred[P|D|].nnnnn.dll
1441 
#
1442 
sub CopyLibFile
1443 
{
1444 
    return 1 unless ($ActiveSection);
1445 
    CopyFileCommon( \&ResolveLibFile, @_ );
1446 
}
1447 
 
1448 
#-------------------------------------------------------------------------------
1449 
# Function        : CopyDebianPackage
1450 
#
1451 
# Description     : Copy a Debian Package to a target dir
1452 
#                   Will look in places where Debian Packages are stored.
1453 
#
1454 
# Inputs          : $src        - BaseName for 'Debian Package' (no version, no extension)
1455 
#                   $dst_dir    - Within the output workspace
1456 
#                   Optional arguments embedded into the BaseName
1457 
#                   --Arch=XXXX         - Architecture - if not current
1458 
#                   --Product=XXXX      - Product - if required
1459 
#                   --Debug             - If not the current type
1460 
#                   --Prod              - If not the current type
1461 
#
1462 
# Returns         : Full path to destination file
1463 
#
1464 
# Notes           : Copying Debian Packages from external packages
1465 
#
1466 
#                   The tool will attempt to copy a well-formed debian packages
1467 
#                   These are:
1468 
#
1469 
#                       "BaseName_VersionString[_Product]_Arch${PkgType}.deb";
1470 
#
1471 
#                   Where 'Product' is optional (and rare)
1472 
#                   Where 'PkgType' is P or D or nothing
1473 
#                   Where 'Arch' may be 'all'
1474 
#
1475 
#                   The routine will locate Debian packages in
1476 
#                       - The root of the package
1477 
#                       - bin/TARGET[P|D/]
1478 
#                       - bin/Arch[P|D]
1479 
#
1480 
#
1481 
sub CopyDebianPackage
1482 
{
1483 
    return 1 unless ($ActiveSection);
1484 
    CopyFileCommon( \&ResolveDebPackage, '--FromPackage', @_ );
1485 
}
1486 
 
1487 
#-------------------------------------------------------------------------------
1488 
# Function        : CopyFileCommon
1489 
#
1490 
# Description     : Common ( internal File Copy )
1491 
#
1492 
# Inputs          : $resolver           - Ref to function to resolve source file
1493 
#                   $src                - Source File Name
1494 
#                   $dst_dir            - Target Dir
1495 
#                   $dst_name           - Target Name (optional)
1496 
#                   Options
1497 
#                   Options:
1498 
#                       --FromPackage
1499 
#                       --FromBuild
1500 
#                       --SoftLink=xxxx
1501 
#                       --LinkFile=xxxx
1502 
#                       --ConfFile
1503 
#                       --Platform=xxxx[,yyyyy]
1504 
#
1505 
# Returns         :
1506 
#
1507 
sub CopyFileCommon
1508 
{
1509 
    my $from_package = 0;
1510 
    my $isa_linkfile = 0;
1511 
    my $isa_configFile = 0;
1512 
    my @llist;
1513 
    my @args;
1514 
    my @platforms;
1515 
 
1516 
    #
1517 
    #   Parse options
1518 
    #
1519 
    foreach ( @_ )
1520 
    {
1521 
        if ( m/^--FromPackage/ ) {
1522 
            $from_package = 1;
1523 
 
1524 
        } elsif ( m/^--FromBuild/ ) {
1525 
            $from_package = 0;
1526 
 
1527 
        } elsif ( m/^--LinkFile/ ) {
1528 
            $isa_linkfile = 1;
1529 
 
1530 
        } elsif ( m/^--ConfFile/i ) {
1531 
            $isa_configFile = 1;
1532 
 
1533 
        } elsif ( m/^--SoftLink=(.+)/ ) {
1534 
            push @llist, $1;
1535 
 
1536 
        } elsif ( m/^--Platform=(.+)/ ) {
1537 
            push @platforms, split(',', $1 );
1538 
 
1539 
        } elsif ( m/^--/ ) {
1540 
            Error ("FileCopy: Unknown option: $_");
1541 
 
1542 
        } else {
1543 
            push @args, $_;
1544 
        }
1545 
    }
1546 
 
1547 
    #
1548 
    #   Extract non-options.
1549 
    #   These are the bits that are left over
1550 
    #
1551 
    my ($resolver, $src, $dst_dir, $dst_name ) = @args;
1552 
 
1553 
    #
1554 
    #   Clean up dest_dir. Must start with a / and not end with one
1555 
    #
1556 
    $dst_dir = "/$dst_dir/";
1557 
    $dst_dir =~ s~/+~/~g;
1558 
    $dst_dir =~ s~/$~~;
1559 
 
1560 
    Verbose ("CopyFile: $src, $dst_dir, " . ($dst_name || ''));
1561 
    foreach $src ( &$resolver( $from_package, $src, \@platforms ) )
1562 
    {
1563 
        my $dst_fname = $dst_name ? $dst_name : StripDir($src);
1564 
        my $dst_file = "$dst_dir/$dst_fname";
1565 
        Verbose ("CopyFile: Copy $src, $dst_file" );
1566 
 
1567 
 
1568 
        #
1569 
        #   LinkFiles are special
1570 
        #   They get concatenated to any existing LINKS File
1571 
        #
1572 
        if ( $isa_linkfile )
1573 
        {
1574 
            CatFile ( $src, "$dst_dir/.LINKS" );
1575 
        }
1576 
        else
1577 
        {
1578 
            mkpath( "$WorkDir$dst_dir", 0, 0775);
1579 
            unlink ("$WorkDir$dst_file");
1580 
            System ('cp','-f', $src, "$WorkDir$dst_file" );
1581 
 
1582 
            foreach my $lname ( @llist )
1583 
            {
1584 
                $lname = $dst_dir . '/' . $lname unless ( $lname =~ m ~^/~ );
1585 
                MakeSymLink( $dst_file ,$lname);
1586 
            }
1587 
        }
1588 
 
1589 
        #
1590 
        #   ConfigFiles are marked so that they can be handled by the debain installer
1591 
        #
1592 
        if ($isa_configFile)
1593 
        {
1594 
            push @ConfigList, $WorkSubDir . $dst_file;
1595 
        }
1596 
    }
1597 
}
1598 
 
1599 
#-------------------------------------------------------------------------------
1600 
# Function        : ExtractTar
1601 
#
1602 
# Description     : Extract a tar file into a target directory
1603 
#                   Useful for massive structures and those with embedded symlinks
1604 
#                   Performs an implicit merge
1605 
#                   Will create output root if it does not exist
1606 
#
1607 
# Inputs          : $srcTar      - Source Tar file
1608 
#                   $dst_dir     - Within the output workspace
1609 
#                   Options
1610 
#                       --Source=Name           - Source via Symbolic Name
1611 
#                       --FromPackage           - Source via package roots
1612 
#                       --Strip=nn              - Strip nn path elements from the dir
1613 
#
1614 
# Returns         :
1615 
#
1616 
sub ExtractTar
1617 
{
1618 
    my ($srcTar, $dst_dir, @opts) = @_;
1619 
    my $userSrcTar = $srcTar;
1620 
    my $opt_source;
1621 
    my $opt_package;
1622 
    my $opt_strip;
1623 
    my $opt_base;
1624 
    my $from_interface;
1625 
    my $dname = StripDir($userSrcTar);
1626 
    my $errConfig = ErrorReConfig( prefix => "ExtractTar($dname): ");
1627 
    #
1628 
    #   Setup the basic options
1629 
    #       May be altered as we parse user options
1630 
    #
1631 
    $dst_dir = $WorkDir . '/' . $dst_dir;
1632 
    $dst_dir =~ s~//~/~;
1633 
 
1634 
    #
1635 
    #   Scan and collect user options
1636 
    #
1637 
    foreach  ( @opts )
1638 
    {
1639 
        Verbose2 ("$_");
1640 
        if ( m/^--Source=(.+)/ ) {
1641 
            Error ("Source directory can only be specified once")
1642 
                if ( defined $opt_source );
1643 
            $opt_source = $1;
1644 
 
1645 
        } elsif ( m/^--FromPackage/ ) {
1646 
            Error ("FromPackage can only be specified once")
1647 
                if ( defined $opt_package );
1648 
            $opt_package = 1;
1649 
 
1650 
        } elsif ( m/^--Strip=(\d+)$/i ) {
1651 
            Error ("Strip can only be specified once")
1652 
                if ( defined $opt_package );
1653 
            $opt_strip = $1;
1654 
 
1655 
        } else {
1656 
            Error ("Unknown option: $_" );
1657 
        }
1658 
    }
1659 
 
1660 
    #
1661 
    #   All options have been gathered. Now process some of them
1662 
    #
1663 
    Error ("Cannot use both --Source and --FromPackage: $srcTar") if ($opt_source && $opt_package);
1664 
 
1665 
    #
1666 
    #   Convert a symbolic path into a physical path
1667 
    #
1668 
    if ($opt_source)
1669 
    {
1670 
        Verbose2 ("Determine Source: $opt_source");
1671 
 
1672 
        $opt_source = lc($opt_source);
1673 
        my %ExtractTarSymbolic = (
1674 
            'interfaceincdir'   => $opt_interfaceincdir,
1675 
            'interfacelibdir'   => $opt_interfacelibdir,
1676 
            'interfacebindir'   => $opt_interfacebindir,
1677 
            'libdir'            => $opt_libdir,
1678 
            'bindir'            => $opt_bindir,
1679 
            'localincdir'       => $opt_localincdir,
1680 
            'locallibdir'       => $opt_locallibdir,
1681 
            'localbindir'       => $opt_localbindir,
1682 
            'packagebindir'     => $opt_pkgbindir,
1683 
            'packagelibdir'     => $opt_pkglibdir,
1684 
            'packagepkgdir'     => $opt_pkgpkgdir,
1685 
            'packagedir'        => $opt_pkgdir,
1686 
        );
1687 
 
1688 
        if ( exists $ExtractTarSymbolic{$opt_source} )
1689 
        {
1690 
            $opt_base = $ExtractTarSymbolic{$opt_source};
1691 
 
1692 
            #
1693 
            #   If sourceing from interface, then follow
1694 
            #   symlinks in the copy. All files will be links anyway
1695 
            #
1696 
            $from_interface = 1
1697 
                if ( $opt_source =~ m~^interface~ );
1698 
        }
1699 
        else
1700 
        {
1701 
            DebugDumpData ("ExtractTarSymbolic", \%ExtractTarSymbolic);
1702 
            Error ("Unknown Source Name: $opt_source" );
1703 
        }
1704 
    }
1705 
 
1706 
    #
1707 
    #   Locate the path within an external package
1708 
    #
1709 
    if ($opt_package)
1710 
    {
1711 
        Verbose2 ("FromPackage: $srcTar");
1712 
 
1713 
        my @path;
1714 
        my @scanned;
1715 
        foreach my $entry ( getPackageList() )
1716 
        {
1717 
            my $base = $entry->getBase(3);
1718 
            next unless ( defined $base );
1719 
            push @scanned, $base;
1720 
            if ( -f $base . '/' . $srcTar )
1721 
            {
1722 
                push @path, $base;
1723 
                $from_interface = 1
1724 
                    if ( $entry->{'TYPE'} eq 'interface' );
1725 
            }
1726 
        }
1727 
 
1728 
        if ( $#path < 0 )
1729 
        {
1730 
            Error ("Cannot find source dir in any package: $userSrcTar", @scanned);
1731 
        }
1732 
 
1733 
        Error ("Requested path found in mutiple packages: $userSrcTar",
1734 
                @path ) if ( $#path > 0 );
1735 
        $opt_base = pop @path;
1736 
 
1737 
        #
1738 
        #   If sourceing from interface, then follow symlinks in the copy.
1739 
        #   All files will be links anyway
1740 
        #
1741 
        #   This is a very ugly test for 'interface'
1742 
        #
1743 
        $from_interface = 1
1744 
            if ( $opt_base =~ m~/interface/~ );
1745 
    }
1746 
 
1747 
    #
1748 
    #   Create the full source path
1749 
    #   May be: from a package, from a known directory, from a local directory
1750 
    #
1751 
    $srcTar = $opt_base . '/' . $srcTar if ( $opt_base );
1752 
    $srcTar =~ s~//~/~g;
1753 
 
1754 
    Verbose ("$srcTar, $dst_dir");
1755 
    Error ("Tar File not found: $userSrcTar") unless ( -f $srcTar );
1756 
 
1757 
    #
1758 
    #   Create the output path if it does not exist
1759 
    #
1760 
    mkpath( $dst_dir ) unless -d $dst_dir;
1761 
 
1762 
    #
1763 
    #   Generate and execute the tar command
1764 
    #
1765 
    my @cmd = qw (tar -x --keep-old-files);
1766 
    push @cmd, '-f', $srcTar;
1767 
    push (@cmd, qw(-v --show-transformed-names)) if ($opt_verbose > 2);
1768 
    push (@cmd, "--strip=$opt_strip") if (defined $opt_strip);
1769 
    push @cmd, '-C', $dst_dir;
1770 
    System (@cmd);
1771 
}
1772 
 
1773 
 
1774 
#-------------------------------------------------------------------------------
1775 
# Function        : CopyDir
1776 
#
1777 
# Description     : Copy a directory to a target dir
1778 
#
1779 
# Inputs          : $src_dir    - Local to the user
1780 
#                                 Symbolic Name
1781 
#                   $dst_dir    - Within the output workspace
1782 
#                   Options
1783 
#                       --Merge                 - Don't delete first
1784 
#                       --Source=Name           - Source via Symbolic Name
1785 
#                       --FromPackage           - Source via package roots
6535 dpurdie 1786 
#                       --FromPackage:Name      - Source via specified package roots
6242 dpurdie 1787 
#                       --NoIgnoreDbgFiles      - Do not ignore .dbg and .debug files in dir copy
1788 
#                       --IfPresent             - Not an error if the path cannot be found
1789 
#                       --ConfFile              - Mark transferred files as config files
1790 
#                       --Flatten               - Copy all to one directory
1791 
#                       --FilterOut=xxx         - Ignore files. DOS Wildcard
1792 
#                       --FilterOutRe=xxx       - Ignore files. Regular expression name
1793 
#                       --FilterOutDir=xxx      - Ignore directories. DOS Wilcard
1794 
#                       --FilterOutDirRe=xxx    - Ignore directories. Regular expression name
1795 
#                       --SkipTLF               - Ignore files in the Top Level Directory
1796 
#                       --NoRecurse             - Only process files in the Top Level Directory
1797 
#                       --FilterIn=xxx          - Include files. DOS Wildcard
1798 
#                       --FilterInRe=xxx        - Include files. Regular expression name
1799 
#                       --FilterInDir=xxx       - Include directories. DOS Wilcard
1800 
#                       --FilterInDirRe=xxx     - Include directories. Regular expression name
1801 
#
1802 
# Returns         :
1803 
#
1804 
sub CopyDir
1805 
{
1806 
    my ($src_dir, $dst_dir, @opts) = @_;
1807 
    my $opt_base;
1808 
    my $from_interface = 0;
1809 
    my $ignoreDbg = 1;
1810 
    my $ignoreNoDir;
1811 
    my $user_src_dir = $src_dir;
1812 
    my $opt_source;
1813 
    my $opt_package;
6535 dpurdie 1814 
    my $opt_package_name;
6242 dpurdie 1815 
    my @fileList;
1816 
    my $isFiltered;
1817 
    return 1 unless ($ActiveSection);
1818 
 
1819 
    #
1820 
    #   Setup the basic copy options
1821 
    #       May be altered as we parse user options
1822 
    #
1823 
    my %copyOpts;
1824 
    $copyOpts{'IgnoreDirs'} = ['.svn', '.git', '.cvs', '.hg'];
1825 
    $copyOpts{'Ignore'} = ['.gbedir', '_gbedir'];
1826 
    $copyOpts{'Log'} = 1 if ( $opt_verbose > 1 );
1827 
    $copyOpts{'DeleteFirst'} = 1;
1828 
 
1829 
    $dst_dir = $WorkDir . '/' . $dst_dir;
1830 
    $dst_dir =~ s~//~/~;
1831 
 
1832 
    #
1833 
    #   Scan and collect user options
1834 
    #
1835 
    foreach  ( @opts )
1836 
    {
1837 
        Verbose2 ("CopyDir: $_");
1838 
        if ( m/^--Merge/ ) {
1839 
            $copyOpts{'DeleteFirst'} = 0;
1840 
 
1841 
        } elsif ( m/^--Source=(.+)/ ) {
1842 
            Error ("Source directory can only be specified once")
1843 
                if ( defined $opt_source );
1844 
            $opt_source = $1;
1845 
 
6535 dpurdie 1846 
        } elsif ( m/^--FromPackage:(.+)/ ) {
1847 
            Error ("FromPackage can only be specified once")
1848 
                if ( defined $opt_package );
1849 
            $opt_package = 1;
1850 
            $opt_package_name = $1;
1851 
 
6242 dpurdie 1852 
        } elsif ( m/^--FromPackage/ ) {
1853 
            Error ("FromPackage can only be specified once")
1854 
                if ( defined $opt_package );
1855 
            $opt_package = 1;
1856 
 
1857 
        } elsif ( m/^--NoIgnoreDbgFiles/ ) {
1858 
            $ignoreDbg = 0;
1859 
 
1860 
        } elsif ( m/^--IfPresent/ ) {
1861 
            $ignoreNoDir = 1;
1862 
 
1863 
        } elsif ( m/^--ConfFile/i ) {
1864 
            $copyOpts{'FileList'} = \@fileList;
1865 
 
1866 
        } elsif ( m/^--Flatten/i ) {
1867 
            $copyOpts{'Flatten'} = 1;
1868 
 
1869 
        } elsif ( m/^--FilterOut=(.+)/i ) {
1870 
            push (@{$copyOpts{'Ignore'}}, $1);
1871 
            $isFiltered = 1;
1872 
 
1873 
        } elsif ( m/^--FilterOutRe=(.+)/i ) {
1874 
            push (@{$copyOpts{'IgnoreRE'}}, $1);
1875 
            $isFiltered = 1;
1876 
 
1877 
        } elsif ( m/^--FilterOutDir=(.+)/i ) {
1878 
            push (@{$copyOpts{'IgnoreDirs'}}, $1);
1879 
            $isFiltered = 1;
1880 
 
1881 
        } elsif ( m/^--FilterOutDirRe=(.+)/i ) {
1882 
            push (@{$copyOpts{'IgnoreDirsRE'}}, $1);
1883 
            $isFiltered = 1;
1884 
 
1885 
        } elsif ( m/^--FilterIn=(.+)/i ) {
1886 
            push (@{$copyOpts{'Match'}}, $1);
1887 
            $isFiltered = 1;
1888 
 
1889 
        } elsif ( m/^--FilterInRe=(.+)/i ) {
1890 
            push (@{$copyOpts{'MatchRE'}}, $1);
1891 
            $isFiltered = 1;
1892 
 
1893 
        } elsif ( m/^--FilterInDir=(.+)/i ) {
1894 
            push (@{$copyOpts{'MatchDirs'}}, $1);
1895 
            $isFiltered = 1;
1896 
 
1897 
        } elsif ( m/^--FilterInDirRe=(.+)/i ) {
1898 
            push (@{$copyOpts{'MatchDirsRE'}}, $1);
1899 
            $isFiltered = 1;
1900 
 
1901 
        } elsif ( m/^--SkipTLF$/i ) {
1902 
            $copyOpts{'SkipTLF'} = 1;
1903 
 
1904 
        } elsif ( m/^--NoRecurse$/i ) {
1905 
            $copyOpts{'NoSubDirs'} = 1;
1906 
 
1907 
        } else {
1908 
            Error ("CopyDir: Unknown option: $_" );
1909 
        }
1910 
    }
1911 
 
1912 
    #
1913 
    #   All options have been gathered. Now process some of them
1914 
    #
1915 
    Error ("CopyDir: Cannot use both --Source and --FromPackage: $src_dir") if ($opt_source && $opt_package);
1916 
 
1917 
    #
1918 
    #   Convert a symbolic path into a physical path
1919 
    #
1920 
    if ($opt_source)
1921 
    {
1922 
        Verbose2 ("CopyDir: Determine Source: $opt_source");
1923 
 
1924 
        $opt_source = lc($opt_source);
1925 
        my %CopyDirSymbolic = (
1926 
            'interfaceincdir'   => $opt_interfaceincdir,
1927 
            'interfacelibdir'   => $opt_interfacelibdir,
1928 
            'interfacebindir'   => $opt_interfacebindir,
1929 
            'libdir'            => $opt_libdir,
1930 
            'bindir'            => $opt_bindir,
1931 
            'localincdir'       => $opt_localincdir,
1932 
            'locallibdir'       => $opt_locallibdir,
1933 
            'localbindir'       => $opt_localbindir,
1934 
            'packagebindir'     => $opt_pkgbindir,
1935 
            'packagelibdir'     => $opt_pkglibdir,
1936 
            'packagepkgdir'     => $opt_pkgpkgdir,
1937 
            'packagedir'        => $opt_pkgdir,
1938 
        );
1939 
 
1940 
        if ( exists $CopyDirSymbolic{$opt_source} )
1941 
        {
1942 
            $opt_base = $CopyDirSymbolic{$opt_source};
1943 
 
1944 
            #
1945 
            #   If sourceing from interface, then follow
1946 
            #   symlinks in the copy. All files will be links anyway
1947 
            #
1948 
            $from_interface = 1
1949 
                if ( $opt_source =~ m~^interface~ );
1950 
        }
1951 
        else
1952 
        {
1953 
            DebugDumpData ("CopyDirSymbolic", \%CopyDirSymbolic);
1954 
            Error ("CopyDir: Unknown Source Name: $opt_source" );
1955 
        }
1956 
    }
1957 
 
1958 
    #
1959 
    #   Locate the path within an external package
1960 
    #
1961 
    if ($opt_package)
1962 
    {
1963 
        Verbose2 ("CopyDir: FromPackage: $src_dir");
1964 
 
1965 
        my @path;
1966 
        foreach my $entry ( getPackageList() )
1967 
        {
6535 dpurdie 1968 
            #
1969 
            #   Locate the named package if specified
1970 
            #
1971 
            if (defined $opt_package_name) {
1972 
                next unless ($opt_package_name eq $entry->getName() || uc($opt_package_name) eq $entry->getUnifiedName() );
1973 
            }
1974 
 
6242 dpurdie 1975 
            my $base = $entry->getBase(3);
1976 
            next unless ( defined $base );
6535 dpurdie 1977 
            if ( folderHasFiles( $base . '/' . $src_dir) )
6242 dpurdie 1978 
            {
1979 
                push @path, $base;
1980 
                $from_interface = 1
1981 
                    if ( $entry->{'TYPE'} eq 'interface' );
1982 
            }
1983 
        }
1984 
 
1985 
        if ( $#path < 0 )
1986 
        {
1987 
            Error ("CopyDir: Cannot find source dir in any package: $user_src_dir") unless ($ignoreNoDir);
1988 
            Message ("CopyDir: Optional path not found: $user_src_dir");
1989 
            return;
1990 
        }
1991 
 
1992 
        Error ("CopyDir: Requested path found in mutiple packages: $user_src_dir",
1993 
                @path ) if ( $#path > 0 );
1994 
        $opt_base = pop @path;
1995 
 
1996 
        #
1997 
        #   If sourceing from interface, then follow symlinks in the copy.
1998 
        #   All files will be links anyway
1999 
        #
2000 
        #   This is a very ugly test for 'interface'
2001 
        #
2002 
        $from_interface = 1
2003 
            if ( $opt_base =~ m~/interface/~ );
2004 
 
2005 
    }
2006 
 
2007 
    #
2008 
    #   Create the full source path
2009 
    #   May be: from a package, from a known directory, from a local directory
2010 
    #
2011 
 
2012 
    $src_dir = $opt_base . '/' . $src_dir if ( $opt_base );
2013 
    $src_dir =~ s~//~/~g;
2014 
    $src_dir =~ s~/$~~;
2015 
 
2016 
    Verbose ("CopyDir: $src_dir, $dst_dir");
2017 
    unless ( -d $src_dir )
2018 
    {
2019 
        Error ("CopyDir: Directory not found: $user_src_dir") unless ($ignoreNoDir);
2020 
        Message ("CopyDir: Optional path not found: $user_src_dir");
2021 
        return;
2022 
    }
2023 
 
2024 
    #
2025 
    #   Continue to configure the copy options
2026 
    #
2027 
    push (@{$copyOpts{'Ignore'}}, '*.debug', '*.dbg') if $ignoreDbg;
2028 
    $copyOpts{'DuplicateLinks'} = 1 unless ( $from_interface );
2029 
    $copyOpts{'EmptyDirs'} = 1 unless ($isFiltered);
2030 
 
2031 
    #
2032 
    #   Transfer the directory
2033 
    #
2034 
    JatsCopy::CopyDir ( $src_dir, $dst_dir, \%copyOpts );
2035 
 
2036 
    #
2037 
    #   If requested, mark files as config files
2038 
    #   Must remove the DebianWorkDir prefix
2039 
    #
2040 
    if(@fileList)
2041 
    {
2042 
        Verbose ("Mark all transfered files as ConfFiles");
2043 
        my $removePrefix = length ($WorkDir);
2044 
        foreach my $file (@fileList)
2045 
        {
2046 
            push @ConfigList, substr($file, $removePrefix);
2047 
        }
2048 
    }
2049 
 
2050 
    #
2051 
    #   Expand link files that may have been copied in
2052 
    #
2053 
    Verbose ("Locate LINKFILES in $WorkDir");
2054 
    ExpandLinkFiles();
2055 
}
2056 
 
2057 
#-------------------------------------------------------------------------------
2058 
# Function        : AddInitScript
2059 
#
2060 
# Description     : Add an Init Script to the target
2061 
#                   Optionally create start and stop links
2062 
#
2063 
# Inputs          : $script     - Name of the init script
2064 
#                   $start      - Start Number
2065 
#                   $stop       - Stop Number
2066 
#                   Options:
2067 
#                       --NoCopy        - Don't copy the script, just add links
2068 
#                       --Afc           - Place in AFC init area
2069 
#                       --FromPackage   - Source is in a package
6535 dpurdie 2070 
#                       --Hibernate     - Add hibernate symlink
2071 
#                       --Resume        - Add resume symlink
6547 dpurdie 2072 
#                       --Sk100Mode     - Force SK100 Mode
6242 dpurdie 2073 
#
2074 
# Returns         :
2075 
#
2076 
sub AddInitScript
2077 
{
2078 
    my $no_copy;
2079 
    my $basedir = "";
2080 
    my @args;
2081 
    my $from_package = 0;
6535 dpurdie 2082 
    my $hibernate = 0;
2083 
    my $resume = 0;
6988 sdenys 2084 
    my $sk100 = ($opt_target eq 'SK100');
6547 dpurdie 2085 
    my $afcMode;
2086 
 
6242 dpurdie 2087 
    return 1 unless ($ActiveSection);
2088 
 
2089 
    # This directive is only available on the VIX platforms
2090 
    #   Kludgey test - at the moment
2091 
    #
6547 dpurdie 2092 
    if ($opt_pkgarch =~ m~i386~) {
6242 dpurdie 2093 
        Error ("AddInitScript is not supported on this platform");
2094 
    }
2095 
 
2096 
    #
2097 
    #   Process and Remove options
2098 
    #
2099 
    foreach  ( @_ )
2100 
    {
2101 
        if ( m/^--NoCopy/ ) {
2102 
            $no_copy = 1;
2103 
 
2104 
        } elsif ( m/^--Afc/ ) {
2105 
            $basedir = "/afc";
6547 dpurdie 2106 
            $afcMode = 1;
6242 dpurdie 2107 
 
2108 
        } elsif ( m/^--FromPackage/ ) {
2109 
            $from_package = 1;
2110 
 
6535 dpurdie 2111 
        } elsif ( m/^--Hibernate=(.*)/ ) {
2112 
            $hibernate = $1;
2113 
 
2114 
        } elsif ( m/^--Resume=(.*)/ ) {
2115 
            $resume = $1;
2116 
 
6547 dpurdie 2117 
        } elsif ( m/^--SK100/i ) {
2118 
            $sk100 = 1;
2119 
 
2120 
        } elsif ( m/^--NoSK100/i ) {
2121 
            $sk100 = 0;
2122 
 
6242 dpurdie 2123 
        } elsif ( m/^--/ ) {
2124 
            Error ("AddInitScript: Unknown option: $_");
2125 
 
2126 
        } else {
2127 
            push @args, $_;
2128 
 
2129 
        }
2130 
    }
2131 
 
2132 
    my( $script, $start, $stop ) = @args;
2133 
    Error ("No script file specified") unless ( $script );
2134 
    Warning("AddInitScript: No start or stop index specified") unless ( $start || $stop );
2135 
    Verbose ("AddInitScript: $script, " . ($start || 'No Start') . ", " . ($stop || 'No Stop'));
6547 dpurdie 2136 
    Error ("Resume script not supported") if ($resume && !$sk100);
2137 
    Error ("Hibernate script not supported") if ($hibernate && !$sk100);
2138 
    Error ("AFC mode not supported on SK100 (@args)") if ( $sk100 && $afcMode );
6242 dpurdie 2139 
    $script = ResolveFile($from_package, $script );
6547 dpurdie 2140 
 
2141 
    my $tdir = $sk100 ?  "/etc/init.d/init.vix.d" : "/etc/init.d/init.d";
2142 
    $tdir = catdir($basedir, $tdir);
6242 dpurdie 2143 
    my $base = StripDir($script);
6689 dpurdie 2144 
    unless ($no_copy) {
2145 
        CopyFile( $script, $tdir );
2146 
        SetFilePerms('a+rx', catfile($tdir,$base));
2147 
    }
6242 dpurdie 2148 
 
2149 
    my $link;
6547 dpurdie 2150 
    my $linkPath = $sk100 ? "/etc/init.d/init.vix.d/" : "/etc/init.d/";
2151 
    $linkPath = catdir($basedir, $linkPath) . '/';
2152 
    Verbose("InitScript: ", $base, $tdir, $linkPath);
2153 
 
6535 dpurdie 2154 
    if ( $start ) {
2155 
        $link = sprintf ("${linkPath}S%2.2d%s", $start, $base );
6242 dpurdie 2156 
        MakeSymLink( "$tdir/$base", $link);
2157 
    }
2158 
 
6535 dpurdie 2159 
    if ( $stop ) {
2160 
        $link = sprintf ("${linkPath}K%2.2d%s", $stop, $base );
6242 dpurdie 2161 
        MakeSymLink( "$tdir/$base", $link);
2162 
    }
6535 dpurdie 2163 
 
2164 
    if ( $hibernate ) {
2165 
        $link = sprintf ("${linkPath}H%2.2d%s", $hibernate, $base );
2166 
        MakeSymLink( "$tdir/$base", $link);
2167 
    }
2168 
 
2169 
    if ( $resume ) {
2170 
        $link = sprintf ("${linkPath}R%2.2d%s", $resume, $base );
2171 
        MakeSymLink( "$tdir/$base", $link);
2172 
    }
2173 
 
6547 dpurdie 2174 
    # In SK100 mode
2175 
    #   init script must be placed in rc.local.d and must be sources and
2176 
    #   a start stop resume or suspend function must be implemented.
6535 dpurdie 2177 
    # For VIX these functions will call existing initscripts already package in
2178 
    # a vix folder.
6547 dpurdie 2179 
    if ( $sk100 ) {
2180 
 
2181 
        my $rcLocal =  "/etc/init.d/rc.local.d";
2182 
        my $rcLocalFile = catfile( $rcLocal, $base);
2183 
        my $rcWorkFile = catfile($WorkDir, $rcLocalFile );
2184 
        my $fh;
2185 
        CreateDir($rcLocal);
2186 
 
2187 
        Message ("creating service file: $rcLocalFile");
2188 
        unless (open $fh,'>', $rcWorkFile) {
2189 
            Error ("Failed to create Service file in $rcLocal, $!");
6535 dpurdie 2190 
        }
6547 dpurdie 2191 
        print $fh "#!/bin/sh\n# $base service file\n\n";
2192 
        print $fh "start() {\n    [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base start\n}\n";
2193 
        print $fh "stop() {\n    [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base stop\n}\n";
2194 
        print $fh "suspend() {\n    [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base suspend\n}\n";
2195 
        print $fh "resume() {\n    [ -e /etc/init.d/init.vix.d/$base ] && /etc/init.d/init.vix.d/$base resume\n}\n";
2196 
        close $fh;
6689 dpurdie 2197 
        SetFilePerms('a+rx', $rcLocalFile);
6535 dpurdie 2198 
    }
6547 dpurdie 2199 
 
2200 
    return 1;
6242 dpurdie 2201 
}
2202 
 
2203 
#-------------------------------------------------------------------------------
2204 
# Function        : CatFile
2205 
#
2206 
# Description     : Copy a file to the end of a file
2207 
#
2208 
# Inputs          : $src
2209 
#                   $dst    - Within the output workspace
2210 
#
2211 
# Returns         :
2212 
#
2213 
sub CatFile
2214 
{
2215 
    my ($src, $dst) = @_;
2216 
    return 1 unless ($ActiveSection);
2217 
 
2218 
    $dst = $WorkDir . '/' . $dst;
2219 
    $dst =~ s~//~/~;
2220 
    Verbose ("CatFile: $src, $dst");
2221 
    $src = ResolveFile(0, $src );
2222 
 
2223 
    open (SF, '<', $src)  || Error ("CatFile: Cannot open $src");
2224 
    open (DF, '>>', $dst) || Error ("CatFile: Cannot create:$dst");
2225 
    while ( <SF> )
2226 
    {
2227 
        print DF $_;
2228 
    }
2229 
    close (SF);
2230 
    close (DF);
2231 
}
2232 
 
2233 
#-------------------------------------------------------------------------------
2234 
# Function        : EchoFile
2235 
#
2236 
# Description     : Echo simple text to a file
2237 
#
2238 
# Inputs          : $file   - Within the output workspace
2239 
#                   $text
2240 
#
2241 
# Returns         :
2242 
#
2243 
sub EchoFile
2244 
{
2245 
    my ($file, $text) = @_;
2246 
    return 1 unless ($ActiveSection);
2247 
    Verbose ("EchoFile: $file");
2248 
 
2249 
    $file = $WorkDir . '/' . $file;
2250 
    $file =~ s~//~/~;
2251 
 
2252 
    unlink $file;
2253 
    open (DT, ">", $file ) || Error ("Cannot create $file");
2254 
    print DT  $text || Error ("Cannot print to $file");
2255 
    close DT;
2256 
}
2257 
 
2258 
#-------------------------------------------------------------------------------
2259 
# Function        : ConvertFiles
2260 
#
2261 
# Description     : This sub-routine is used to remove all carrage return\line
2262 
#                   feeds from a line and replace them with the platform
2263 
#                   specific equivalent chars.
2264 
#
2265 
#                   We let PERL determine what characters are written to the
2266 
#                   file base on the  platform you are running on.
2267 
#
2268 
#                   i.e. LF    for unix
2269 
#                        CR\LF for win32
2270 
#
2271 
# Inputs          : outPath                 - Output directory
2272 
#                   flist                   - List of files in that directory
2273 
#                   or
2274 
#                   SearchOptions           - Search options to find files
2275 
#                                           --Recurse
2276 
#                                           --NoRecurse
2277 
#                                           --FilterIn=xxx
2278 
#                                           --FilterInRe=xxx
2279 
#                                           --FilterOut=xxx
2280 
#                                           --FilterOutRe=xxx
2281 
#                   Common options
2282 
#                                           --Dos
2283 
#                                           --Unix
2284 
#
2285 
#
2286 
# Returns         : 1
2287 
#
2288 
sub ConvertFiles
2289 
{
2290 
    my @uargs;
2291 
    return 1 unless ($ActiveSection);
2292 
    my $lineEnding = "\n";
2293 
    my ($dosSet, $unixSet);
2294 
    my $search =  JatsLocateFiles->new( '--NoRecurse' );
2295 
 
2296 
    #
2297 
    #   Process user arguments extracting options
2298 
    #
2299 
    foreach  ( @_ )
2300 
    {
2301 
        if ( m~^--Recurse~ ) {
2302 
            $search->recurse(1);
2303 
 
2304 
        } elsif ( m~^--NoRecurse~) {
2305 
            $search->recurse(0);
2306 
 
2307 
        } elsif ( /^--FilterOut=(.*)/ ) {
2308 
            $search->filter_out($1);
2309 
 
2310 
        } elsif ( /^--FilterOutRe=(.*)/ ) {
2311 
            $search->filter_out_re($1);
2312 
 
2313 
        } elsif ( /^--FilterIn=(.*)/ ) {
2314 
            $search->filter_in($1);
2315 
 
2316 
        } elsif ( /^--FilterInRe=(.*)/ ) {
2317 
            $search->filter_in_re($1);
2318 
 
2319 
        } elsif ( m~^--Dos~) {
2320 
            $lineEnding = "\r\n";
2321 
            $dosSet = 1;
2322 
 
2323 
        } elsif ( m~^--Unix~) {
2324 
            $lineEnding = "\n";
2325 
            $unixSet = 1;
2326 
 
2327 
        } elsif ( m~^--~) {
2328 
            Error ("ConvertFiles: Unknown option: $_");
2329 
 
2330 
        } else {
2331 
            push @uargs, $_;
2332 
        }
2333 
    }
2334 
 
2335 
    #
2336 
    #   Process non-option arguments
2337 
    #       - Base dir
2338 
    #       - List of files
2339 
    #
2340 
    my ($outPath, @flist) = @uargs;
2341 
    Error ("ConvertFiles: Target Dir must be specified" ) unless ( $outPath );
2342 
 
2343 
    #
2344 
    #   Sanity Tests
2345 
    #
2346 
    Error ("ConvertFiles: --Dos and --Unix are mutually exclusive" ) if ( $dosSet && $unixSet );
2347 
 
2348 
 
2349 
    #
2350 
    # Convert output path to physical path
2351 
    #
2352 
    my $topDir = catdir($WorkDir, $outPath);
2353 
    Verbose("ConvertFiles: topDir: $topDir");
2354 
    Error ("ConvertFiles: Path does not exist", $topDir) unless ( -e $topDir );
2355 
    Error ("ConvertFiles: Path is not a directory", $topDir) unless ( -d $topDir );
2356 
 
2357 
    #
2358 
    #   Need to determine if we are searching or simply using a file list
2359 
    #   There are two forms of the functions. If any of the search options have
2360 
    #   been used then we assume that we are searchine
2361 
    #
2362 
    if ( $search->has_filter() )
2363 
    {
2364 
        Error ("ConvertFiles: Cannot mix search options with named files") if ( @flist );
2365 
        @flist = $search->search($topDir);
2366 
    }
2367 
    Error ("ConvertFiles: No files specified") unless ( @flist );
2368 
 
2369 
    #
2370 
    #   Process all named files
2371 
    #
2372 
    foreach my $file ( @flist )
2373 
    {
2374 
 
2375 
        # this is our file that we want to clean.
2376 
        my ($ifileLoc) = "$topDir/$file";
2377 
        my ($tfileLoc) = "$topDir/$file\.tmp";
2378 
        Verbose("ConvertFiles: $file");
2379 
 
2380 
        # we will check to see if the file exists.
2381 
        #
2382 
        my $ifile;
2383 
        my $tfile;
2384 
        if ( -f "$ifileLoc" )
2385 
        {
2386 
            open ($ifile, "< $ifileLoc" ) or
2387 
                Error("Failed to open file [$ifileLoc] : $!");
2388 
 
2389 
            open ($tfile, "> $tfileLoc" ) or
2390 
                Error("Failed to open file [$tfileLoc] : $!");
2391 
            binmode $tfile;
2392 
 
2393 
            while ( <$ifile> )
2394 
            {
2395 
                s~[\n\r]+$~~;               # Chomp
2396 
                print $tfile "$_" . $lineEnding;
2397 
            }
2398 
        }
2399 
        else
2400 
        {
2401 
            Error("ConvertFiles [$ifileLoc] does not exist.");
2402 
        }
2403 
 
2404 
        close $ifile;
2405 
        close $tfile;
2406 
 
2407 
 
2408 
        # lets replace our original file with the new one
2409 
        #
2410 
        if(File::Copy::move("$tfileLoc", "$ifileLoc"))
2411 
        {
2412 
            Verbose2("ConvertFiles: Renamed [$tfileLoc] to [$ifileLoc] ...");
2413 
        }
2414 
        else
2415 
        {
2416 
            Error("ConvertFiles: Failed to rename file [$tfileLoc] to [$ifileLoc]: $!");
2417 
        }
2418 
    }
2419 
 
2420 
    return 1;
2421 
}
2422 
 
2423 
#----------------------------------------------------------------------------
2424 
# Function        : ReplaceTags
2425 
#
2426 
# Description     : This sub-routine is used to replace Tags in one or more files
2427 
#
2428 
# Inputs          : outPath                 - Output directory
2429 
#                   flist                   - List of files in that directory
2430 
#                   or
2431 
#                   SearchOptions           - Search options to find files
2432 
#                                           --Recurse
2433 
#                                           --NoRecurse
2434 
#                                           --FilterIn=xxx
2435 
#                                           --FilterInRe=xxx
2436 
#                                           --FilterOut=xxx
2437 
#                                           --FilterOutRe=xxx
2438 
#                   Common options
2439 
#                                           --Tag=Tag,Replace
2440 
#
2441 
#
2442 
# Returns         : 1
2443 
#
2444 
sub ReplaceTags
2445 
{
2446 
    return 1 unless ($ActiveSection);
2447 
    my @uargs;
2448 
    my $search =  JatsLocateFiles->new( '--NoRecurse' );
2449 
    my @tagsList;
2450 
    my $tagSep = ',';
2451 
    my @tagOrder;
2452 
    my %tagData;
2453 
 
2454 
    #
2455 
    #   Process user arguments extracting options
2456 
    #
2457 
    foreach  ( @_ )
2458 
    {
2459 
        if ( m~^--Recurse~ ) {
2460 
            $search->recurse(1);
2461 
 
2462 
        } elsif ( m~^--NoRecurse~) {
2463 
            $search->recurse(0);
2464 
 
2465 
        } elsif ( /^--FilterOut=(.*)/ ) {
2466 
            $search->filter_out($1);
2467 
 
2468 
        } elsif ( /^--FilterOutRe=(.*)/ ) {
2469 
            $search->filter_out_re($1);
2470 
 
2471 
        } elsif ( /^--FilterIn=(.*)/ ) {
2472 
            $search->filter_in($1);
2473 
 
2474 
        } elsif ( /^--FilterInRe=(.*)/ ) {
2475 
            $search->filter_in_re($1);
2476 
 
2477 
        } elsif ( m~^--Tag=(.*)~) {
2478 
            push @tagsList, $1;
2479 
 
2480 
        } elsif ( m~^--~) {
2481 
            Error ("ReplaceTags: Unknown option: $_");
2482 
 
2483 
        } else {
2484 
            push @uargs, $_;
2485 
        }
2486 
    }
2487 
 
2488 
    #
2489 
    #   Process non-option arguments
2490 
    #       - Base dir
2491 
    #       - List of files
2492 
    #
2493 
    my ($outPath, @flist) = @uargs;
2494 
    Error ("ReplaceTags: Target Dir must be specified" ) unless ( $outPath );
2495 
 
2496 
    #
2497 
    #   Sanity Tests
2498 
    #
2499 
    Error ("ReplaceTags: No tags specified" ) unless ( @tagsList );
2500 
 
2501 
    #
2502 
    # Convert output path to physical path
2503 
    #
2504 
    my $topDir = catdir($WorkDir, $outPath);
2505 
    Verbose("ReplaceTags: topDir: $topDir");
2506 
    Error ("ReplaceTags: Path does not exist", $topDir) unless ( -e $topDir );
2507 
    Error ("ReplaceTags: Path is not a directory", $topDir) unless ( -d $topDir );
2508 
 
2509 
    #
2510 
    #   Convert Tags into pairs for latter use
2511 
    #
2512 
    my $sep = quotemeta ($tagSep );
2513 
    foreach my $tag ( @tagsList )
2514 
    {
2515 
        my ($tname,$tvalue) = split ( $sep, $tag, 2 );
2516 
        Error ("No tag value in: $tag" ) unless ( defined $tvalue );
2517 
        Error ("Duplicate Tag: $tname" ) if ( exists $tagData{$tname} );
2518 
        Verbose ("Tag: $tname :: $tvalue");
2519 
        push @tagOrder, $tname;
2520 
        $tagData{$tname} = $tvalue;
2521 
    }
2522 
 
2523 
    #
2524 
    #   Need to determine if we are searching or simply using a file list
2525 
    #   There are two forms of the functions. If any of the search options have
2526 
    #   been used then we assume that we are searchine
2527 
    #
2528 
    if ( $search->has_filter() )
2529 
    {
2530 
        Error ("ReplaceTags: Cannot mix search options with named files") if ( @flist );
2531 
        @flist = $search->search($topDir);
2532 
    }
2533 
    Error ("ReplaceTags: No files specified") unless ( @flist );
2534 
 
2535 
    #
2536 
    #   Process all named files
2537 
    #
2538 
    foreach my $file ( @flist )
2539 
    {
2540 
 
2541 
        # this is our file that we want to clean.
2542 
        my ($ifileLoc) = "$topDir/$file";
2543 
        my ($tfileLoc) = "$topDir/$file\.tmp";
2544 
        Verbose("ReplaceTags: $file");
2545 
 
2546 
        # we will check to see if the file exists.
2547 
        #
2548 
        my $ifile;
2549 
        my $tfile;
2550 
        if ( -f "$ifileLoc" )
2551 
        {
2552 
            open ($ifile, "< $ifileLoc" ) or
2553 
                Error("Failed to open file [$ifileLoc] : $!");
2554 
 
2555 
            open ($tfile, "> $tfileLoc" ) or
2556 
                Error("Failed to open file [$tfileLoc] : $!");
2557 
 
2558 
            while ( <$ifile> )
2559 
            {
2560 
                s~[\n\r]+$~~;               # Chomp
2561 
 
2562 
                #
2563 
                #   Perform tag replacement
2564 
                #
2565 
                foreach my $tag ( @tagOrder )
2566 
                {
2567 
                    my $value = $tagData{$tag};
2568 
                    if ( s~$tag~$value~g )
2569 
                    {
2570 
                        Verbose2("Replaced: $tag with $value");
2571 
                    }
2572 
                }
2573 
 
2574 
                print $tfile "$_\n";
2575 
            }
2576 
        }
2577 
        else
2578 
        {
2579 
            Error("ReplaceTags [$ifileLoc] does not exist.");
2580 
        }
2581 
 
2582 
        close $ifile;
2583 
        close $tfile;
2584 
 
2585 
 
2586 
        # lets replace our original file with the new one
2587 
        #
2588 
        if(File::Copy::move("$tfileLoc", "$ifileLoc"))
2589 
        {
2590 
            Verbose2("ReplaceTags: Renamed [$tfileLoc] to [$ifileLoc] ...");
2591 
        }
2592 
        else
2593 
        {
2594 
            Error("ReplaceTags: Failed to rename file [$tfileLoc] to [$ifileLoc]: $!");
2595 
        }
2596 
    }
2597 
 
2598 
    return 1;
2599 
}
2600 
 
2601 
#-------------------------------------------------------------------------------
2602 
# Function        : SetFilePerms
2603 
#
2604 
# Description     : Set file permissions on one or more files or directories
2605 
#                   Use SetPermissions
2606 
#
2607 
# Inputs          : $perm           - Perm Mask
2608 
#                   @paths          - List of paths/files to process
2609 
#                   Options
2610 
#                       --Recurse   - Recurse subdirs
2611 
#
2612 
# Returns         :
2613 
#
2614 
sub SetFilePerms
2615 
{
2616 
 
2617 
    return 1 unless ($ActiveSection);
2618 
    my @args;
2619 
    my $perms;
2620 
    my $recurse = 0;
2621 
 
2622 
    #
2623 
    #   Process and Remove options
2624 
    #
2625 
    foreach  ( @_ )
2626 
    {
2627 
        if ( m/^--Recurse/ ) {
2628 
            $recurse = 1;
2629 
 
2630 
        } elsif ( m/^--/ ) {
2631 
            Error ("SetFilePerms: Unknown option: $_");
2632 
 
2633 
        } else {
2634 
            push @args, $_;
2635 
 
2636 
        }
2637 
    }
2638 
 
2639 
    $perms = shift @args;
2640 
    Error ("SetFilePerms: No Permissions" ) unless ( $perms );
2641 
 
2642 
    foreach my $path ( @args )
2643 
    {
2644 
        Verbose ("Set permissions; $perms, $path");
2645 
        my $full_path = $WorkDir . '/' . $path;
2646 
        if ( -f $full_path )
2647 
        {
2648 
            System ('chmod', $perms, $full_path );
2649 
        }
2650 
        elsif ( -d $full_path )
2651 
        {
2652 
            System ('chmod', '-R', $perms, $full_path ) if ($recurse);
2653 
            System ('chmod', $perms, $full_path ) unless ($recurse);
2654 
        }
2655 
        else
2656 
        {
2657 
            Warning("SetFilePerms: Path not found: $path");
2658 
        }
2659 
    }
2660 
    return 1;
2661 
}
2662 
 
2663 
#-------------------------------------------------------------------------------
2664 
# Function        : SetPermissions
2665 
#
2666 
# Description     : Called to set permissions of files/dirs in a directory structure.
2667 
#                   With no options sets DirTag and all files/dirs in it to perms
2668 
#
2669 
# Inputs          : path        - The directory tag to start setting permissions on
2670 
#                   Options     - See below
2671 
#
2672 
#   Required Options:
2673 
#       One or both of
2674 
#               --FilePerms=    Sets the permissions of files to this permission.
2675 
#                               If not supplied then no files have their permissions changed
2676 
#               --DirPerms=     Sets the permissions of directories to this permission
2677 
#                               If not supplied then no directories have their permissions changed
2678 
#       OR
2679 
#               --Perms=        Sets the permissions of both files and directories to this permissions
2680 
#                               Equivalent to supplying both --FilePerms=X && --DirPerms=X
2681 
#
2682 
#   Options:
2683 
#               --RootOnly      Only sets the permissions on the 'path' directory/file,
2684 
#                               all other options ignored
2685 
#               --SkipRoot      Does not set permissions on the 'path' directory/file,
2686 
#                               obviously mutually exlusive with --RootOnly
2687 
#
2688 
#       Any option supported by JatsLocateFiles.
2689 
#       Some of these include:
2690 
#
2691 
#               --Recurse       Recurse the directory tree.  Does a depth first recurse so that all
2692 
#                               dir entries are processed before the dir itself (default)
2693 
#               --NoRecurse     Dont recurse
2694 
#               --FilterIn=     Apply permissions to files/directories that matches this value.
2695 
#               --FilterInRe=   Perl RE's can be used (Not Shell wildcards) and this option
2696 
#                               can be supplied mulitple times
2697 
#               --FilterOut=    Dont apply permissions to any files/directories matching this value
2698 
#               --FilterOutRe=  Perl RE's can be used (Not Shell wildcards) and this option
2699 
#                               can be supplied mulitple times
2700 
#
2701 
#                               FilterIn is applied before FilterOut.  If Recurse is specified
2702 
#                               the directory will be recursed regardless of these filters, however
2703 
#                               the filter will be applied when it comes time to chmod the dir
2704 
#
2705 
#------------------------------------------------------------------------------
2706 
sub SetPermissions
2707 
{
2708 
    return 1 unless ($ActiveSection);
2709 
    my ( $path, $filePerms, $dirPerms, $someDone );
2710 
    my ( $rootOnly, $skipRoot ) = ( 0, 0 );
2711 
 
2712 
    my $search =  JatsLocateFiles->new( '--Recurse', '--DirsToo' );
2713 
 
2714 
    foreach ( @_ )
2715 
    {
2716 
        if ( m/^--Perms=(.*)/ ) {
2717 
            $filePerms = $1;
2718 
            $dirPerms = $1;
2719 
 
2720 
        } elsif (m/^--FilePerms=(.*)/ )  {
2721 
            $filePerms = $1;
2722 
 
2723 
        } elsif ( m/^--DirPerms=(.*)/ )  {
2724 
            $dirPerms = $1;
2725 
 
2726 
        }  elsif ( m/^--RootOnly/ ) {
2727 
            $rootOnly = 1;
2728 
 
2729 
        } elsif ( m/^--SkipRoot/ )  {
2730 
            $skipRoot = 1;
2731 
 
2732 
        } elsif ( m/^--Filter/ && $search->option( $_ ) ) {
2733 
            Verbose2 ("Search Option: $_" );
2734 
 
2735 
        } elsif ( m/^--Recurse|--NoRecurse/ && $search->option( $_ ) ) {
2736 
            Verbose2 ("Search Option: $_" );
2737 
 
2738 
        } elsif (m/^--/ ) {
2739 
            Error ("SetPermissions: Unknown option: $_");
2740 
 
2741 
        } else  {
2742 
            Error("SetPermissions 'path' already set", "Path: $_") if ( $path );
2743 
            $path = $_;
2744 
        }
2745 
    }
2746 
 
2747 
    #
2748 
    #   Sanity test
2749 
    #
2750 
    Error("SetPermissions called with out a 'path' parameter") if ( !defined($path) );
2751 
    Error("SetPermissions called with out any Permissions specified") if ( !defined($filePerms) && !defined($dirPerms) );
2752 
    Error("SetPermissions: Options --RootOnly & --SkipRoot are mutually exclusive" ) if ( $rootOnly && $skipRoot );
2753 
 
2754 
 
2755 
    #   Convert the target directory name into a physical path
2756 
    #   User specifies '/' as the root of the image
2757 
    #   User specifies 'name' as relateve to the root of the image
2758 
    #
2759 
    my $topDir = $WorkDir . '/' . $path;
2760 
    $topDir =~ s~/+$~~;
2761 
 
2762 
    Verbose("SetPermissions: Called with options " . join(", ", @_));
2763 
 
2764 
    #
2765 
    #   Only set perms on the root directory
2766 
    #       This is a trivial operation
2767 
    #
2768 
    if ( $rootOnly )
2769 
    {
2770 
        $someDone += chmodItem( $topDir, $filePerms, $dirPerms );
2771 
    }
2772 
    else
2773 
    {
2774 
        #
2775 
        #   Create a list of files/dirs to process
2776 
        #
2777 
        my @elements = $search->search( $topDir );
2778 
 
2779 
        foreach my $dirEntry ( @elements )
2780 
        {
2781 
            my $fullPath = "$topDir/$dirEntry";
2782 
 
2783 
            # A dir and we dont have dirperms, so skip
2784 
            if ( -d $fullPath && !defined($dirPerms) )
2785 
            {
2786 
                Verbose2("SetPermissions: Skipping dir $fullPath as we have no dir permissions");
2787 
                next;
2788 
            }
2789 
 
2790 
            # A file and we dont have fileperms, so skip
2791 
            if ( -f $fullPath && !defined($filePerms) )
2792 
            {
2793 
                Verbose2("SetPermissions: Skipping file $fullPath as we have no file permissions");
2794 
                next;
2795 
            }
2796 
 
2797 
            # a file or a dir and have the right permissions and we are not recursing
2798 
            if ( -f $fullPath || -d $fullPath )
2799 
            {
2800 
                $someDone += chmodItem( $fullPath, $filePerms, $dirPerms );
2801 
            }
2802 
            else
2803 
            {
2804 
                Warning("SetPermissions: Skipping $fullPath as its not a file or directory");
2805 
            }
2806 
        }
2807 
 
2808 
        #
2809 
        #   Process the topDir
2810 
        #   May not be modified if --SkipRoot has been requested
2811 
        #
2812 
        if ( !$skipRoot && -e $topDir )
2813 
        {
2814 
            $someDone += chmodItem( $topDir, $filePerms, $dirPerms );
2815 
        }
2816 
    }
2817 
 
2818 
    #   Final warning
2819 
    #
2820 
    Warning ("SetPermissions: No files located", "Args: @_") unless ( $someDone );
2821 
}
2822 
 
2823 
#************ INTERNAL USE ONLY  **********************************************
2824 
# Function        : chmodItem
2825 
#
2826 
# Description     : Internal
2827 
#                   chmod a file or a folder
2828 
#
2829 
# Inputs          : item                        - Item to mod
2830 
#                   filePerms                   - File perms
2831 
#                   dirPerms                    - dire perms
2832 
#
2833 
# Returns         : 1   - Item modified
2834 
#                   0   - Item not modified
2835 
#
2836 
#************ INTERNAL USE ONLY  **********************************************
2837 
sub chmodItem
2838 
{
2839 
    my ($item, $filePerms, $dirPerms) = @_;
2840 
 
2841 
    if ( -d $item && defined $dirPerms)
2842 
    {
2843 
        Verbose("SetPermissions: $dirPerms : $item");
2844 
        System ('chmod', $dirPerms, $item );
2845 
        return 1;
2846 
    }
2847 
 
2848 
    if ( -f $item  && defined $filePerms)
2849 
    {
2850 
        Verbose("SetPermissions: $filePerms : $item");
2851 
        System ('chmod', $filePerms, $item );
2852 
        return 1;
2853 
    }
2854 
 
2855 
    return 0;
2856 
}
2857 
 
2858 
 
2859 
#-------------------------------------------------------------------------------
2860 
# Function        : CreateDir
2861 
#
2862 
# Description     : Create a directory within the target workspace
2863 
#
2864 
# Inputs          : $path           - Name of the target directory
2865 
#                   @opts           - Options
2866 
#                     --Owner       - Tells RPM Builder that this package. Owns this directory
2867 
#
2868 
# Returns         : Nothing
2869 
#
2870 
sub CreateDir
2871 
{
2872 
    my ($path, @opts) = @_;
2873 
    return 1 unless ($ActiveSection);
2874 
    Verbose ("Create Dir: $path");
2875 
    my $owner  = 0;
2876 
    foreach ( @opts) {
2877 
        if (m~^--Owner~i ) {
2878 
            $owner = 1;
2879 
        } else {
2880 
            ReportError ("SetBaseDir: Unknown option: $_");
2881 
        }
2882 
    }
2883 
    ErrorDoExit();
2884 
 
2885 
    $path =~ s~^/+~~;
2886 
    $path = '/' . $path;
2887 
    $OwnedDirs{$path} = $owner if $owner;
2888 
    mkpath( $WorkDir . $path );
2889 
}
2890 
 
2891 
#-------------------------------------------------------------------------------
2892 
# Function        : RpmSetDefAttr
2893 
#
2894 
# Description     : RPM only: Set the defAttr values
2895 
#
2896 
# Inputs          : Expect 4 or less argument
2897 
#                       The default permissions, or "mode" for files.
2898 
#                       The default user id.
2899 
#                       The default group id.
2900 
#                       The default permissions, or "mode" for directories.
2901 
#
2902 
sub RpmSetDefAttr
2903 
{
2904 
    return 1 unless ($ActiveSection);
2905 
    return 1 unless $opt_rpm;
2906 
    my @args = @_;
2907 
    Error ("RpmSetDefAttr: Expecting 4 arguments") if (scalar @args ne 4);
2908 
    @RpmDefAttr = @_;
2909 
    return 1;
2910 
}
2911 
 
2912 
#-------------------------------------------------------------------------------
2913 
# Function        : RpmSetAttr
2914 
#
2915 
# Description     : RPM Only : Specify specific file attributes
2916 
#
2917 
# Inputs          : $file - file to target
2918 
#                   $mode - File mode to place on the file (optional)
2919 
#                   $user - user name to place on the file  (optional)
2920 
#                   $group  - group name to place eon the file (optional)
2921 
#
2922 
sub RpmSetAttr
2923 
{
2924 
    return 1 unless ($ActiveSection);
2925 
    return 1 unless $opt_rpm;
2926 
    my ($file, $mode, $user, $group, @extra) = @_;
2927 
    Error ("RpmSetAttr: Too many arguments") if @extra;
2928 
 
2929 
    #
2930 
    #   Validate the file
2931 
    #
2932 
    $file = '/' . $file;
2933 
    $file =~ s~//~/~g;
2934 
    my $full_path = $WorkDir . $file;
2935 
    Error ("RpmSetAttr: File not found: $WorkSubDir$file") unless (-x $full_path );
2936 
 
2937 
    my @data;
2938 
    $data[0] = $WorkSubDir . $file;
2939 
    $data[1] = $mode || '-';
2940 
    $data[2] = $user || '-';
2941 
    $data[3] = $group ||'-';
2942 
    push @RpmAttrList, \@data;
2943 
    return 1;
2944 
}
2945 
 
2946 
 
2947 
#-------------------------------------------------------------------------------
2948 
# Function        : IsProduct
2949 
#                   IsPlatform
2950 
#                   IsTarget
2951 
#                   IsVariant
2952 
#                   IsAlias
2953 
#                   IsDebian
2954 
#                   IsRpm
2955 
#                   IsTar
6937 dpurdie 2956 
#                   IsZip
6242 dpurdie 2957 
#
2958 
# Description     : This function allows some level of control in the
2959 
#                   packaging scripts. It will return true if the current
2960 
#                   product is listed.
2961 
#
2962 
#                   Ugly after thought
2963 
#
2964 
#                   Intended use:
2965 
#                       Xxxxxx(...) if (IsProduct( 'aaa',bbb' );
2966 
#
2967 
# Inputs          : products    - a list of products to compare against
2968 
#
2969 
# Returns         : True if the current build is for one of the listed products
2970 
#
2971 
sub IsProduct
2972 
{
2973 
    foreach ( @_ )
2974 
    {
2975 
        return 1 if ( $opt_product eq $_ );
2976 
    }
2977 
    return 0;
2978 
}
2979 
 
2980 
sub IsPlatform
2981 
{
2982 
    foreach ( @_ )
2983 
    {
2984 
        return 1 if ( $opt_platform eq $_ );
2985 
    }
2986 
    return 0;
2987 
}
2988 
 
2989 
sub IsTarget
2990 
{
2991 
    foreach ( @_ )
2992 
    {
2993 
        return 1 if ( $opt_target eq $_ );
2994 
    }
2995 
    return 0;
2996 
}
2997 
 
2998 
sub IsVariant
2999 
{
3000 
    foreach ( @_ )
3001 
    {
3002 
        return 1 if ( $opt_variant eq $_ );
3003 
    }
3004 
    return 0;
3005 
}
3006 
 
3007 
sub IsAlias
3008 
{
3009 
 
3010 
    #
3011 
    #   Get the aliases from the build info
3012 
    #   This function was introduced late so its not always available
3013 
    #
3014 
    Error("IsAlias not supported in this version of JATS")
3015 
        unless (defined &ReadBuildConfig::getAliases);
3016 
    #
3017 
    #   Create an hash of aliases to simplify testing
3018 
    #   Do it once and cache the results
3019 
    #
3020 
    unless (%opt_aliases) {
3021 
        %opt_aliases = map { $_ => 1 } getAliases();
3022 
    }
3023 
 
3024 
    foreach ( @_ )
3025 
    {
3026 
        return 1 if ( exists $opt_aliases{$_} );
3027 
    }
3028 
    return 0;
3029 
}
3030 
 
3031 
sub IsDebian()
3032 
{
3033 
    return $opt_debian ? 1 : 0;
3034 
}
3035 
 
3036 
sub IsRpm()
3037 
{
3038 
    return $opt_rpm ? 1 : 0;
3039 
}
3040 
 
3041 
sub IsTar()
3042 
{
3043 
    return $opt_tarFile ? 1 : 0;
3044 
}
3045 
 
6937 dpurdie 3046 
sub IsZip()
3047 
{
3048 
    return $opt_zipFile ? 1 : 0;
3049 
}
3050 
 
3051 
 
6242 dpurdie 3052 
#-------------------------------------------------------------------------------
3053 
# Function        : PackageVersion
3054 
#
3055 
# Description     : Return the version of the named package
3056 
#
3057 
# Inputs          : pkgName - Name of the package
3058 
#                   Options
3059 
#                       --format=SomeString. The text replacements
3060 
#                           {VERSION}
3061 
#                           {VERSIONNUMVER}
3062 
#                           {PROJECT}
3063 
#                           {NAME}
3064 
#                           {TYPE}
3065 
#                           {ARCH}
3066 
#
3067 
# Returns         : A string
3068 
#
3069 
sub PackageVersion
3070 
{
3071 
    my ($pkgName, @args) = @_;
3072 
    my ($version, $versionNumber, $project, $format);
3073 
 
3074 
    foreach ( @args)
3075 
    {
3076 
        if (m~^--format=(.+)~i) {
3077 
            $format = $1
3078 
        } else {
3079 
            Error ("PackageVersion: Unknown option: $_")
3080 
        }
3081 
    }
3082 
 
3083 
    foreach my $entry ( getPackageList() )
3084 
    {
3085 
        if ($entry->getName() eq $pkgName ) {
3086 
            $version = $entry->getVersion();
3087 
            ($versionNumber = $version ) =~ s~\.[^.]+$~~;
3088 
            ($project = $version ) =~ s~.*\.~~;
3089 
            last;
3090 
        }
3091 
    }
3092 
 
3093 
    Error ("PackageVersion: $pkgName is not a dependent package") unless defined $version;
3094 
 
3095 
    #
3096 
    #   Format the string
3097 
    #
3098 
    if ($format) {
3099 
        $format =~ s~{NAME}~$pkgName~g;
3100 
        $format =~ s~{VERSION}~$version~g;
3101 
        $format =~ s~{VERSIONNUMBER}~$versionNumber~g;
3102 
        $format =~ s~{PROJECT}~$project~g;
3103 
        $format =~ s~{TYPE}~$opt_type~g;
3104 
        $format =~ s~{ARCH}~$opt_pkgarch~g;
3105 
 
3106 
        $version = $format;
3107 
    }
3108 
 
3109 
    return $version;
3110 
}
3111 
 
3112 
 
3113 
#************ INTERNAL USE ONLY  **********************************************
3114 
# Function        : FindFiles
3115 
#
3116 
# Description     : Locate files within a given dir tree
3117 
#
3118 
# Inputs          : $root           - Base of the search
3119 
#                   $match          - Re to match
3120 
#
3121 
# Returns         : A list of files that match
3122 
#
3123 
#************ INTERNAL USE ONLY  **********************************************
3124 
my @FIND_LIST;
3125 
my $FIND_NAME;
3126 
 
3127 
sub FindFiles
3128 
{
3129 
    my ($root, $match ) = @_;
3130 
    Verbose2("FindFiles: Root: $root, Match: $match");
3131 
 
3132 
    #
3133 
    #   Becareful of closure, Must use globals
3134 
    #
3135 
    @FIND_LIST = ();
3136 
    $FIND_NAME = $match;
3137 
    File::Find::find( \&find_files, $root);
3138 
 
3139 
    #
3140 
    #   Find callback program
3141 
    #
3142 
    sub find_files
3143 
    {
3144 
        my $item =  $File::Find::name;
3145 
 
3146 
        return if ( -d $File::Find::name );
3147 
        return unless ( $_ =~ m~$FIND_NAME~ );
3148 
        push @FIND_LIST, $item;
3149 
    }
3150 
    return @FIND_LIST;
3151 
}
3152 
 
3153 
#-------------------------------------------------------------------------------
3154 
# Function        : CalcRelPath
3155 
#
3156 
# Description     : Return the relative path to the current working directory
3157 
#                   as provided in $Cwd
3158 
#
3159 
# Inputs          : $Cwd - Base dir
3160 
#                   $base - Path to convert
3161 
#
3162 
# Returns         : Relative path from the $Cwd
3163 
#
3164 
sub CalcRelPath
3165 
{
3166 
    my ($Cwd, $base) = @_;
3167 
 
3168 
    my @base = split ('/', $base );
3169 
    my @here = split ('/', $Cwd );
3170 
    my $result;
3171 
 
3172 
    Debug("RelPath: Source: $base");
3173 
 
3174 
    return $base unless ( $base =~ m~^/~ );
3175 
 
3176 
    #
3177 
    #   Remove common bits from the head of both lists
3178 
    #
3179 
    while ( $#base >= 0 && $#here >= 0 && $base[0] eq $here[0] )
3180 
    {
3181 
        shift @base;
3182 
        shift @here;
3183 
    }
3184 
 
3185 
    #
3186 
    #   Need to go up some directories from here and then down into base
3187 
    #
3188 
    $result = '../' x ($#here + 1);
3189 
    $result .= join ( '/', @base);
3190 
    $result = '.' unless ( $result );
3191 
    $result =~ s~//~/~g;
3192 
    $result =~ s~/$~~;
3193 
 
3194 
    Debug("RelPath: Result: $result");
3195 
    return $result;
3196 
}
3197 
 
3198 
#-------------------------------------------------------------------------------
6535 dpurdie 3199 
# Function        : folderHasFiles
3200 
#
3201 
# Description     : Detect empty folders
3202 
#
3203 
# Inputs          : dirname - Path to examine
3204 
#
3205 
# Returns         : TRUE - Is a folder and it has files
3206 
#
3207 
 
3208 
sub folderHasFiles {
3209 
    my $dirname = shift;
3210 
    my $rv = 0;
6937 dpurdie 3211 
    my $dh;
3212 
    return 0 unless -d $dirname;
6535 dpurdie 3213 
 
6937 dpurdie 3214 
    opendir($dh, $dirname) || return 0;
3215 
    while (my $file = readdir $dh)
6535 dpurdie 3216 
    {
6937 dpurdie 3217 
        next unless (defined $file);
3218 
        next if ($file eq "." || $file eq "..");
6535 dpurdie 3219 
        $rv = 1;
3220 
        last;
3221 
    }
3222 
    closedir $dh;
3223 
    return $rv;
3224 
}
3225 
 
3226 
#-------------------------------------------------------------------------------
6242 dpurdie 3227 
# Function        : ExpandLinkFiles
3228 
#
3229 
# Description     : Look for .LINK files in the output image and expand
3230 
#                   the links into softlinks
3231 
#
3232 
# Inputs          : None
3233 
#                   The routine works on the $WorkDir directory tree
3234 
#
3235 
# Returns         : Nothing
3236 
#                   Will remove .LINKS files that are processed
3237 
#
3238 
sub ExpandLinkFiles
3239 
{
3240 
    return 1 unless ($ActiveSection);
3241 
    foreach my $linkfile ( FindFiles( $WorkDir, ".LINKS" ))
3242 
    {
3243 
        next if ( $linkfile =~ m~/\.svn/~ );
3244 
        my $BASEDIR = StripFileExt( $linkfile );
3245 
        $BASEDIR =~ s~^$WorkDir/~~;
3246 
        Verbose "Expand links: $BASEDIR";
3247 
 
3248 
        open (LF, "<", $linkfile ) || Error ("Cannot open link file: $linkfile" );
3249 
        while ( <LF> )
3250 
        {
3251 
            chomp;
3252 
            next if ( m~^#~ );
3253 
            next unless ( $_ );
3254 
            my ($link, $file) = split;
3255 
 
3256 
            MakeSymLink($file ,"$BASEDIR/$link", '--NoDotDot' );
3257 
        }
3258 
        close (LF);
3259 
        unlink $linkfile;
3260 
    }
3261 
}
3262 
 
3263 
#************ INTERNAL USE ONLY  **********************************************
3264 
# Function        : ResolveFile
3265 
#
3266 
# Description     : Determine where the source for a file is
3267 
#                   Will look in (default):
3268 
#                       Local directory
3269 
#                       Local Include
3270 
#                   Or  (FromPackage)
3271 
#                       Our Package directory
3272 
#                       Interface directory (BuildPkgArchives)
3273 
#                       Packages (LinkPkgArchive)
3274 
#
3275 
#                   Will scan 'parts' subdirs
3276 
#
3277 
# Inputs          : $from_package       - 0 - Local File
3278 
#                   $file
3279 
#                   $refPlatforms       - Not used
3280 
#
3281 
# Returns         : Path
3282 
#
3283 
#************ INTERNAL USE ONLY  **********************************************
3284 
sub ResolveFile
3285 
{
3286 
    my ($from_package, $file,$refPlatforms) = @_;
3287 
    my $wildcard = ($file =~ /[*?]/);
3288 
    my @path;
3289 
 
3290 
    #
3291 
    #   Determine the paths to search
3292 
    #
3293 
    if ( $from_package )
3294 
    {
3295 
        unless ( @ResolveFileList )
3296 
        {
3297 
            push @ResolveFileList, $opt_pkgdir;
3298 
            foreach my $entry ( getPackageList() )
3299 
            {
3300 
                push @ResolveFileList, $entry->getBase(3);
3301 
            }
3302 
        }
3303 
        @path = @ResolveFileList;
3304 
    }
3305 
    else
3306 
    {
3307 
        @path = ('.', $opt_localincdir);
3308 
    }
3309 
 
3310 
    #   Determine a full list of 'parts' to search
3311 
    #       Default: Provided within the build information
3312 
    #       User   : Can provide a list
3313 
    my @parts = getPlatformPartsList($refPlatforms);
3314 
 
3315 
    my @done;
3316 
    foreach my $root (  @path )
3317 
    {
3318 
        foreach my $subdir ( @parts )
3319 
        {
3320 
            my $sfile;
3321 
            $sfile = "$root/$subdir/$file";
3322 
            $sfile =~ s~//~/~g;
3323 
            $sfile =~ s~^./~~g;
3324 
            Verbose2("LocateFile: $sfile, $root, $subdir");
3325 
            if ( $wildcard )
3326 
            {
3327 
                push @done, glob ( $sfile );
3328 
            }
3329 
            else
3330 
            {
3331 
                push @done, $sfile if ( -f $sfile || -l $sfile )
3332 
            }
3333 
        }
3334 
    }
3335 
 
3336 
    DisplaySearchPath('ResolveFile', $file, \@parts, undef, \@path) unless (@done) ;
3337 
 
3338 
    Warning ("ResolveFile: Multiple instances of file found. Only first is used", @done)
3339 
        if ( $#done > 0 && ! $wildcard && !wantarray );
3340 
 
3341 
    return wantarray ? @done : $done[0];
3342 
}
3343 
 
3344 
#-------------------------------------------------------------------------------
3345 
# Function        : ResolveBinFile
3346 
#
3347 
# Description     : Determine where the source for a BIN file is
3348 
#                   Will look in (default):
3349 
#                       Local directory
3350 
#                       Local Include
3351 
#                   Or  (FromPackage)
3352 
#                       Our Package directory
3353 
#                       Interface directory (BuildPkgArchives)
3354 
#                       Packages (LinkPkgArchive)
3355 
#                   Will scan 'parts' subdirs (default)
3356 
#                   May scan user-provided parts (cross platform packaging)
3357 
#
3358 
# Inputs          : $from_package       - 0 - Local File
3359 
#                   $file
3360 
#                   $refPlatforms       - (optional) Ref to an array of platforms to scan
3361 
#
3362 
# Returns         : Path
3363 
#
3364 
sub ResolveBinFile
3365 
{
3366 
    my ($from_package, $file, $refPlatforms) = @_;
3367 
    my @path;
3368 
    my @types;
3369 
    my $wildcard = ($file =~ /[*?]/);
3370 
 
3371 
    #
3372 
    #   Determine the paths to search
3373 
    #
3374 
    if ( $from_package )
3375 
    {
3376 
        unless ( @ResolveBinFileList )
3377 
        {
3378 
            push @ResolveBinFileList, $opt_pkgdir . '/bin';
3379 
            foreach my $entry ( getPackageList() )
3380 
            {
3381 
                if ( my $path = $entry->getBase(3) )
3382 
                {
3383 
                    $path .= '/bin';
3384 
                    push @ResolveBinFileList, $path if ( -d $path );
3385 
                }
3386 
            }
3387 
        }
3388 
        @path = @ResolveBinFileList;
3389 
        @types = ($opt_type, '');
3390 
    }
3391 
    else
3392 
    {
3393 
        @path = ($opt_bindir, $opt_localbindir);
3394 
        @types = '';
3395 
    }
3396 
 
3397 
    #
3398 
    #   Determine a full list of 'parts' to search
3399 
    #       Default: Provided within the build information
3400 
    #       User   : Can provide a list
3401 
    #
3402 
    my @parts = getPlatformPartsList($refPlatforms);
3403 
 
3404 
    my @done;
3405 
    foreach my $root (  @path )
3406 
    {
3407 
        foreach my $subdir ( @parts )
3408 
        {
3409 
            foreach my $type ( @types )
3410 
            {
3411 
                my $sfile;
3412 
                $sfile = "$root/$subdir$type/$file";
3413 
                $sfile =~ s~//~/~g;
3414 
                Verbose2("LocateBinFile: $sfile");
3415 
                if ( $wildcard )
3416 
                {
3417 
                    foreach  ( glob ( $sfile ) )
3418 
                    {
3419 
                        # Ignore .dbg (vix) and .debug (qt) files.
3420 
                        next if ( m~\.dbg$~ );
3421 
                        next if ( m~\.debug$~ );
3422 
                        push @done, $_;
3423 
                    }
3424 
                }
3425 
                else
3426 
                {
3427 
                    push @done, $sfile if ( -f $sfile || -l $sfile )
3428 
                }
3429 
            }
3430 
        }
3431 
    }
3432 
 
3433 
    #
3434 
    #   Pretty display the search path - on error
3435 
    #       Will not return.
3436 
    #
3437 
    DisplaySearchPath('ResolveBinFile', $file, \@parts, \@types, \@path) unless (@done) ;
3438 
 
3439 
    if ( $#done > 0 && ! $wildcard )
3440 
    {
3441 
        Warning ("ResolveBinFile: Multiple instances of file found. Only first is used", @done);
3442 
        splice (@done, 1);
3443 
    }
3444 
 
3445 
    return wantarray ? @done : $done[0];
3446 
}
3447 
 
3448 
#-------------------------------------------------------------------------------
3449 
# Function        : ResolveLibFile
3450 
#
3451 
# Description     : Determine where the source for a LIB file is
3452 
#                   Will look in (default):
3453 
#                       Local directory
3454 
#                       Local Include
3455 
#                   Or  (FromPackage)
3456 
#                       Our Package directory
3457 
#                       Interface directory (BuildPkgArchives)
3458 
#                       Packages (LinkPkgArchive)
3459 
#                   Will scan 'parts' subdirs
3460 
#
3461 
# Inputs          : $from_package   - 0:Local File
3462 
#                   $file           - Basename for a 'realname'
3463 
#                                     Do not provide 'lib' or '.so' or version info
3464 
#                                     May contain embedded options
3465 
#                                       --Dll           - Use Windows style versioned DLL
3466 
#                                       --VersionDll    - Use the versioned DLL
3467 
#                                       --3rdParty      - Use exact name provided
3468 
#                   $refPlatforms       - Ref to an array of platforms to scan
3469 
#
3470 
# Returns         : Path
3471 
#
3472 
sub ResolveLibFile
3473 
{
3474 
    my ($from_package, $file, $refPlatforms) = @_;
3475 
    my $wildcard = ($file =~ /[*?]/);
3476 
    my @options;
3477 
    my $num_dll;
3478 
    my @types;
3479 
    my @path;
3480 
    #
3481 
    #   Extract options from file
3482 
    #
3483 
    $num_dll = 0;
3484 
    ($file, @options) = split ( ',', $file);
3485 
    foreach ( @options )
3486 
    {
3487 
        if ( m/^--Dll/ ) {
3488 
            $num_dll = 1;
3489 
        } elsif ( m/^--VersionDll/ ) {
3490 
            $num_dll = 2;
3491 
        } elsif ( m/^--3rdParty/ ) {
3492 
            $num_dll = 3;
3493 
        } else {
3494 
            Error ("Unknown suboption to ResolveLibFile: $_" );
3495 
        }
3496 
    }
3497 
 
3498 
    #
3499 
    #   Determine the paths to search
3500 
    #
3501 
    if ( $from_package )
3502 
    {
3503 
        unless ( @ResolveLibFileList )
3504 
        {
3505 
            push @ResolveLibFileList, $opt_pkgdir . '/lib';
3506 
            foreach my $entry ( getPackageList() )
3507 
            {
3508 
                push @ResolveLibFileList, $entry->getLibDirs(3);
3509 
            }
3510 
        }
3511 
        @path = @ResolveLibFileList;
3512 
    }
3513 
    else
3514 
    {
3515 
        @path = ($opt_libdir, $opt_locallibdir);
3516 
    }
3517 
 
3518 
    #   Determine a full list of 'parts' to search
3519 
    #       Default: Provided within the build information
3520 
    #       User   : Can provide a list
3521 
    my @parts = getPlatformPartsList($refPlatforms);
3522 
 
3523 
    @types = ( $opt_type, '');
3524 
 
3525 
    my @done;
3526 
    foreach my $root (  @path )
3527 
    {
3528 
        foreach my $type ( @types )
3529 
        {
3530 
            foreach my $subdir ( @parts )
3531 
            {
3532 
                my $sfile;
3533 
                my $exact;
3534 
                if ( $num_dll == 2 ) {
3535 
                    $sfile = $file . $type . '.*.dll' ;
3536 
                } elsif ( $num_dll == 1 ) {
3537 
                    $sfile = $file . $type . '.dll' ;
3538 
                    $exact = 1;
3539 
                } elsif ( $num_dll == 3 ) {
3540 
                    $sfile = $file;
3541 
                    $exact = 1;
3542 
                } else {
3543 
                    $sfile = "lib" . $file . $type . '.so.*';
3544 
                }
3545 
 
3546 
                $sfile = "$root/$subdir/$sfile";
3547 
                $sfile =~ s~//~/~g;
3548 
                Verbose2("LocateLibFile: $sfile");
3549 
                if ( $exact )
3550 
                {
6689 dpurdie 3551 
                    UniquePush(\@done, $sfile) if ( -f $sfile || -l $sfile );
6242 dpurdie 3552 
                }
3553 
                elsif ($num_dll)
3554 
                {
3555 
                    push @done, glob ( $sfile );
3556 
                }
3557 
                else
3558 
                {
3559 
                    #
3560 
                    #   Looking for .so files
3561 
                    #   Filter out the soname so files
3562 
                    #   Assume that the soname is shorter than the realname
3563 
                    #       Ignore .dbg (vix) and .debug (qt) files.
3564 
                    #
3565 
                    my %sieve;
3566 
                    foreach ( glob ( $sfile )  )
3567 
                    {
3568 
                        next if ( m~\.dbg$~ );
3569 
                        next if ( m~\.debug$~ );
3570 
                        m~(.*\.so\.)([\d\.]*\d)$~;
3571 
                        if ( $1 )
3572 
                        {
3573 
                            my $file = $1;
3574 
                            my $len = exists $sieve{$file} ? length($sieve{$file}) : 0;
3575 
                            $sieve{$file} = $_
3576 
                                if ( $len == 0 || length($_) > $len );
3577 
                        }
3578 
                    }
3579 
 
3580 
                    push @done, values %sieve;
3581 
                }
3582 
            }
3583 
        }
3584 
    }
3585 
 
3586 
    DisplaySearchPath('ResolveLibFile', $file, \@parts, \@types, \@path) unless (@done) ;
3587 
 
3588 
    if ( $#done > 0 && ! $wildcard )
3589 
    {
3590 
        Warning ("ResolveLibFile: Multiple instances of file found. Only first is used", @done);
3591 
        splice (@done, 1);
3592 
    }
3593 
    return wantarray ? @done : $done[0];
3594 
}
3595 
 
3596 
#-------------------------------------------------------------------------------
3597 
# Function        : ResolveDebPackage
3598 
#
3599 
# Description     : Determine where the source for a Debian Package is
3600 
#                   Will look in (default):
3601 
#                       Local directory
3602 
#                       Local Include
3603 
#                   Or  (FromPackage)
3604 
#                       Our Package directory
3605 
#                       Interface directory (BuildPkgArchives)
3606 
#                       Packages (LinkPkgArchive)
3607 
#
3608 
# Inputs          : $from_package   - 0:Local File
3609 
#                   $baseName       - Basename for a 'DebianPackage'
3610 
#                                     Do not provide version info, architecture or suffix
3611 
#                                     May contain embedded options
3612 
#                                       --Arch=XXX      - Specify alternate architcuture
3613 
#                                       --Product=YYYY  - Specify product family
3614 
#                                       --Debug         - Use alternate build type
3615 
#                                       --Prod          - Use alternate build type
3616 
#                   $refPlatforms       - Ref to an array of platforms to scan
3617 
#
3618 
# Returns         : Path
3619 
#
3620 
sub ResolveDebPackage
3621 
{
3622 
    my ($from_package, $file, $refPlatforms) = @_;
3623 
    my @path;
3624 
    my $arch;
3625 
    my $product;
3626 
    my $buildType;
3627 
    my @types;
3628 
    my $baseName;
3629 
    my @options;
3630 
 
3631 
    #
3632 
    #   Extract options from file
3633 
    #
3634 
    ($baseName, @options) = split ( ',', $file);
3635 
    foreach ( @options )
3636 
    {
3637 
        if ( m/^--Arch=(.+)/ ) {
3638 
            $arch=$1;
3639 
        } elsif ( m/^--Product=(.+)/ ) {
3640 
            $product = $1;
3641 
        } elsif ( m/^--Debug/ ) {
3642 
            Error ("ResolveDebPackage: Cannot specify --Prod and --Debug") if defined $buildType;
3643 
            $buildType = 'D';
3644 
        } elsif ( m/^--Prod/ ) {
3645 
            Error ("ResolveDebPackage: Cannot specify --Prod and --Debug") if defined $buildType;
3646 
            $buildType = 'P';
3647 
        } else {
3648 
            Error ("Unknown suboption to ResolveDebPackage: $_" );
3649 
        }
3650 
    }
3651 
 
3652 
    #
3653 
    #   Insert defaults
3654 
    #
3655 
    $buildType = $opt_type unless ($buildType);
3656 
    $arch = $opt_target unless ($arch);
3657 
 
3658 
    #
3659 
    #   Determine the paths to search
3660 
    #
3661 
    if ( $from_package )
3662 
    {
3663 
        unless ( @ResolveDebFileList )
3664 
        {
3665 
            push @ResolveDebFileList,  $opt_pkgdir, $opt_pkgdir . '/bin';
3666 
            foreach my $entry ( getPackageList() )
3667 
            {
3668 
                if ( my $path = $entry->getBase(3) )
3669 
                {
3670 
                    push @ResolveDebFileList, $path if ( -d $path );
3671 
 
3672 
                    $path .= '/bin';
3673 
                    push @ResolveDebFileList, $path if ( -d $path );
3674 
                }
3675 
            }
3676 
        }
3677 
        @path = @ResolveDebFileList;
3678 
        @types = ($buildType, '');
3679 
    }
3680 
    else
3681 
    {
3682 
        @path = ($opt_bindir, $opt_localbindir);
3683 
        @types = ($buildType, '');
3684 
    }
3685 
 
3686 
    #
3687 
    #   The debian  package name is
3688 
    #   In packages BIN dir
3689 
    #       (BaseName)_VersionString(_Product)(_Arch).deb
3690 
    #
3691 
    #   In root of package
3692 
    #       (BaseName)_VersionString(_Product)(_Arch)(_Type).deb
3693 
    #
3694 
    #
3695 
    #   The package may be found in
3696 
    #       Package Root
3697 
    #       Package bin directory
3698 
    #
3699 
    $file = $baseName . '_*';
3700 
    if (defined $product) {
3701 
        $file .= ( '_' . $product)
3702 
        }
3703 
    $file .= '_' . $arch;
3704 
 
3705 
    #   Determine a full list of 'parts' to search
3706 
    #       Default: Provided within the build information
3707 
    #       User   : Can provide a list
3708 
    my @parts = getPlatformPartsList($refPlatforms);
3709 
 
3710 
    my @done;
3711 
    foreach my $root (  @path )
3712 
    {
3713 
        foreach my $subdir ( @parts )
3714 
        {
3715 
            foreach my $type ( @types )
3716 
            {
3717 
                my $sfile;
3718 
                $sfile = "$root/$subdir$type/$file";
3719 
                $sfile =~ s~//~/~g;
3720 
                foreach my $type2 ( @types )
3721 
                {
3722 
                    my $tfile = $sfile;
3723 
                    $tfile .= '_' . $type2 if $type2;
3724 
                    $tfile .= '.deb';
3725 
                    Verbose2("ResolveDebPackage: $tfile");
3726 
                    foreach  ( glob ( $tfile ) )
3727 
                    {
3728 
                        push @done, $_;
3729 
                    }
3730 
                }
3731 
            }
3732 
        }
3733 
    }
3734 
 
3735 
    DisplaySearchPath('ResolveDebPackage', $file, \@parts, \@types, \@path) unless (@done) ;
3736 
 
3737 
    if ( $#done > 0 )
3738 
    {
3739 
        Error ("ResolveDebPackage: Multiple instances of Package found.", @done);
3740 
    }
3741 
    return wantarray ? @done : $done[0];
3742 
}
3743 
 
3744 
#-------------------------------------------------------------------------------
3745 
# Function        : prettyArray
3746 
#
3747 
# Description     : Generate a quoted string from an array
3748 
#
3749 
# Inputs          : Array Ref
3750 
#
3751 
# Returns         : A string
3752 
#
3753 
sub prettyArray
3754 
{
3755 
    my ($arrayRef) = @_;
3756 
    return join(',', map { qq!"$_"! }  @{$arrayRef})
3757 
}
3758 
 
3759 
#-------------------------------------------------------------------------------
3760 
# Function        : DisplaySearchPath
3761 
#
3762 
# Description     : Pretty display of the search path
3763 
#                   Error display
3764 
#
3765 
# Inputs          : $name   - Function Name
3766 
#                   $file   - Base filename being searched
3767 
#                   $parts  - Ref to array of parts searched
3768 
#                   $types  - Ref to array of types searched - may be undef
3769 
#                   $path   - Ref to array of paths searched
3770 
#
3771 
# Returns         : Will not return
3772 
#
3773 
sub DisplaySearchPath
3774 
{
3775 
    my ($name, $file, $parts, $types, $path) = @_;
3776 
    my @text;
3777 
 
3778 
    push @text, $name . ': File not found: ' . $file;
3779 
    push @text, 'Search Platforms: ' . prettyArray($parts);
3780 
    push @text, 'Search Types: ' . prettyArray($types) if defined $types;
3781 
    push @text, 'Search Path:', @$path;
3782 
    Error (@text);
3783 
}
3784 
 
3785 
#-------------------------------------------------------------------------------
3786 
# Function        : getPlatformPartsList
3787 
#
3788 
# Description     : Determine a full list of 'parts' to search
3789 
#                       Default: Provided within the build information
3790 
#                       User   : Can provide a list
3791 
#
3792 
# Inputs          : $refPlatforms - Ref to an array of user provided platforms
3793 
#                                   If provided will override the internal list
3794 
#
3795 
# Returns         : An array
3796 
#
3797 
sub getPlatformPartsList
3798 
{
3799 
    my ($refPlatforms) = @_;
3800 
    my @parts;
3801 
 
3802 
    if ($refPlatforms && scalar @{$refPlatforms}) {
3803 
        @parts = @{$refPlatforms};
3804 
 
3805 
    } else {
3806 
        @parts = getPlatformParts ();
3807 
    }
3808 
    push @parts, '';
3809 
    return @parts;
3810 
}
3811 
 
3812 
#-------------------------------------------------------------------------------
3813 
# Function        : AUTOLOAD
3814 
#
3815 
# Description     : Intercept unknown user directives and issue a nice error message
3816 
#                   This is a simple routine to report unknown user directives
3817 
#                   It does not attempt to distinguish between user errors and
3818 
#                   programming errors. It assumes that the program has been
3819 
#                   tested. The function simply report filename and line number
3820 
#                   of the bad directive.
3821 
#
3822 
# Inputs          : Original function arguments ( not used )
3823 
#
3824 
# Returns         : This function does not return
3825 
#
3826 
our $AUTOLOAD;
3827 
sub AUTOLOAD
3828 
{
3829 
    my $fname = $AUTOLOAD;
3830 
    $fname =~ s~^main::~~;
3831 
    my ($package, $filename, $line) = caller;
3832 
    my $prefix;
3833 
 
3834 
    #
3835 
    #   Some directives are applicable to Rpm and/or Debian only
3836 
    #   If a directive starts with Rpm, Debian or All, then invoke
3837 
    #   the underlying directive iff we are process a Debian/Rpm file
3838 
    #
3839 
    #   The underlying directive will start with MULTI_
3840 
    #   It will be called with the first argument being the name of the function
3841 
    #   that it is being called as.
3842 
    #
3843 
    $fname =~ m~^(Rpm|Debian|All)(.*)~;
3844 
    if (defined $1) {
3845 
        my $type = $1;
3846 
        my $tfname = 'MULTI_' . $2;
3847 
        my $fRef = \&{$tfname};
3848 
 
3849 
        if (defined &{$tfname}) {
3850 
            if ($type eq 'Rpm') {
3851 
                $fRef->($fname, @_) if $opt_rpm;
3852 
 
3853 
            } elsif ($type eq 'Debian') {
3854 
                $fRef->($fname, @_) if $opt_debian;
3855 
 
3856 
            } elsif ($type eq 'All') {
3857 
                $fRef->($fname, @_);
3858 
            }
3859 
            return 1;
3860 
        }
3861 
    }
3862 
 
3863 
    Error ("Directive not known or not allowed in this context: $fname",
3864 
           "Directive: $fname( @_ );",
3865 
           "File: " . RelPath($filename) . ", Line: $line" );
3866 
}
3867 
 
3868 
1;
3869