Subversion Repositories DevTools

Rev

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

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