Subversion Repositories DevTools

Rev

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