Subversion Repositories DevTools

Rev

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

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