Subversion Repositories DevTools

Rev

Go to most recent revision | Details | Last modification | View Log | RSS feed

Rev Author Line No. Line
407 dpurdie 1
########################################################################
3921 dpurdie 2
# Copyright (C) 1998-2013 Vix Technology, All rights reserved
407 dpurdie 3
#
3921 dpurdie 4
# Module name   : DebianPackager.pl
407 dpurdie 5
# Module type   : Makefile system
3921 dpurdie 6
# Compiler(s)   : Perl
407 dpurdie 7
# Environment(s): jats
8
#
9
# Description   : This program is invoked by the MakeDebianPackage
10
#                 directive, that is a part of this package
11
#
12
#                 The program will use a user-provided script in order
13
#                 to create a Debian 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 configuration scaripts 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
#                   Massage the Debian control file
26
#
27
#                   Create a Debian Package
28
#
29
#                   Transfer it to the users 'BIN' directory, where it is
30
#                   available to be packaged.
31
#
32
#                 Summary of directives available to the user-script:
33
#                       AddInitScript           - Add an init script
34
#                       CatFile                 - Append to a file
35
#                       CopyDir                 - Copy directory tree
36
#                       CopyFile                - Copy a file
37
#                       CopyBinFile             - Copy an executable file
38
#                       CopyLibFile             - Copy a library file
39
#                       CreateDir               - Create a directory
40
#                       DebianFiles             - Specify control and script files
41
#                       EchoFile                - Place text into a file
42
#                       MakeSymLink             - Create a symbolic link
43
#                       PackageDescription      - Specify the package description
44
#                       SetFilePerms            - Set file permissions
45
#                       SetVerbose              - Control progress display
46
#                       IsProduct               - Flow control
47
#                       IsPlatform              - Flow control
48
#                       IsTarget                - Flow control
427 dpurdie 49
#                       IsVariant               - Flow control
407 dpurdie 50
#
51
#                 Thoughts for expansion:
52
#                       ConvertFile             - Option to convert file(s) to Unix Text
53
#                       ReplaceTags             - Replace Tags on target file
54
#                       SrcDir                  - Extend path for resolving local files
55
#
56
#                   Less used:
57
#                        ExpandLinkFiles        - Expand .LINK files
58
#
59
#                   Internal Use:
60
#                        FindFiles              - Find a file
61
#                        ResolveFile            - Resolve a 'local' source file
62
#                        
63
#......................................................................#
64
 
411 dpurdie 65
require 5.006_001;
407 dpurdie 66
use strict;
67
use warnings;
68
 
69
use Getopt::Long;
70
use File::Path;
71
use File::Copy;
72
use File::Find;
73
use JatsSystem;
74
use FileUtils;
75
use JatsError;
76
use ReadBuildConfig;
423 dpurdie 77
use JatsCopy ();                            # Don't import anything
407 dpurdie 78
 
79
#
80
#   Globals
81
#
425 dpurdie 82
my $DebianWorkDirBase;                      # Workspace
407 dpurdie 83
my $DebianWorkDir;                          # Dir to create file system image within
84
 
85
#
86
#   Command line options
87
#
88
my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
89
my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
90
my $opt_vargs;                              # Verbose arg
91
my $opt_help = 0;
92
my $opt_manual = 0;
93
my $opt_clean = 0;
94
my $opt_platform;
95
my $opt_type;
96
my $opt_buildname;
97
my $opt_buildversion;
98
my $opt_interfacedir;
99
my $opt_target;
100
my $opt_product;
101
my $opt_package_script;
102
my $opt_interfaceincdir;
103
my $opt_interfacelibdir;
104
my $opt_interfacebindir;
105
my $opt_libdir;
106
my $opt_bindir;
107
my $opt_localincdir;
108
my $opt_locallibdir;
109
my $opt_localbindir;
110
my $opt_pkgdir;
111
my $opt_pkglibdir;
112
my $opt_pkgbindir;
113
my $opt_pkgpkgdir;
114
my $opt_output;
417 dpurdie 115
my $opt_name;
427 dpurdie 116
my $opt_variant;
3921 dpurdie 117
my $opt_pkgarch;
407 dpurdie 118
 
119
#
120
#   Options derived from script directives
121
#
122
my $opt_control = '';
123
my $opt_prerm = '';
124
my $opt_postrm = '';
125
my $opt_preinst = '';
126
my $opt_postinst = '';
127
my $opt_description;
128
 
415 dpurdie 129
#
130
#   Globals
131
#
132
my @ResolveFileList;                    # Cached Package File List
133
my @ResolveBinFileList;                 # Cached PackageBin File List
134
my @ResolveLibFileList;                 # Cached PackageLib File List
407 dpurdie 135
 
136
#-------------------------------------------------------------------------------
137
# Function        : Main Entry point
138
#
139
# Description     : This function will be called when the package is initialised
140
#                   Extract arguments from the users environment
141
#
142
#                   Done here to greatly simplify the user script
143
#                   There should be no junk in the user script - keep it simple
144
#
145
# Inputs          :
146
#
147
# Returns         : 
148
#
149
main();
150
sub main
151
{
152
    my $result = GetOptions (
153
                "verbose:s"         => \$opt_vargs,
154
                "clean"             => \$opt_clean,
155
                "Type=s"            => \$opt_type,
4105 dpurdie 156
                "BuildName=s"       => \$opt_buildname,                     # Raw Jats Package Name (Do not use)
157
                "Name=s"            => \$opt_name,                          # Massaged Debian Package Name
407 dpurdie 158
                "BuildVersion=s"    => \$opt_buildversion,
159
                "Platform=s"        => \$opt_platform,
160
                "Target=s"          => \$opt_target,
161
                "Product=s"         => \$opt_product,
162
                "DebianPackage=s"   => \$opt_package_script,
163
                "InterfaceDir=s"    => \$opt_interfacedir,
164
                "InterfaceIncDir=s" => \$opt_interfaceincdir,
165
                "InterfaceLibDir=s" => \$opt_interfacelibdir,
166
                "InterfaceBinDir=s" => \$opt_interfacebindir,
167
                "LibDir=s"          => \$opt_libdir,
168
                "BinDir=s"          => \$opt_bindir,
169
                "LocalIncDir=s"     => \$opt_localincdir,
170
                "LocalLibDir=s"     => \$opt_locallibdir,
171
                "LocalBinDir=s"     => \$opt_localbindir,
172
                "PackageDir=s"      => \$opt_pkgdir,
173
                "PackageLibDir=s"   => \$opt_pkglibdir,
174
                "PackageBinDir=s"   => \$opt_pkgbindir,
175
                "PackagePkgDir=s"   => \$opt_pkgpkgdir,
176
                "Output=s"          => \$opt_output,
427 dpurdie 177
                "Variant:s"         => \$opt_variant,
3921 dpurdie 178
                "PkgArch:s"         => \$opt_pkgarch,
407 dpurdie 179
    );
180
 
181
    $opt_verbose++ unless ( $opt_vargs eq '@' );
182
 
183
    ErrorConfig( 'name'    => 'DebianUtils',
184
                 'verbose' => $opt_verbose,
185
                 'debug'   => $opt_debug );
186
 
187
    #
188
    #   Init the FileSystem Uiltity interface
189
    #
190
    InitFileUtils();
191
 
192
    #
193
    #   Ensure that we have all required options
194
    #
195
    Error ("Platform not set")                  unless ( $opt_platform );
196
    Error ("Type not set")                      unless ( $opt_type );
197
    Error ("BuildName not set")                 unless ( $opt_buildname );
4105 dpurdie 198
    Error ("Debian Package Name not set")       unless ( $opt_name );
407 dpurdie 199
    Error ("BuildVersion not set")              unless ( $opt_buildversion );
200
    Error ("InterfaceDir not set")              unless ( $opt_interfacedir );
201
    Error ("Target not set")                    unless ( $opt_target );
202
    Error ("Product not set")                   unless ( $opt_product );
203
    Error ("DebianPackage not set")             unless ( $opt_package_script );
204
    Error ("Ouput File not set")                unless ( $opt_output );
205
 
206
    #
207
    #   Read in relevent config information
208
    #
209
    ReadBuildConfig ($opt_interfacedir, $opt_platform, '--NoTest' );
210
 
211
    #
212
    #   Build the package image in a directory based on the target being created
213
    #
425 dpurdie 214
    $DebianWorkDirBase = "$opt_platform$opt_type.image";
215
    $DebianWorkDir = "$DebianWorkDirBase/$opt_name";
407 dpurdie 216
 
217
    #
218
    #   Configure the System command to fail on any error
219
    #
220
    SystemConfig ( ExitOnError => 1 );
221
 
222
    #
223
    #   Extract the 'name' of the package from the output path
224
    #   Display purposes only
225
    #
226
    my $DebianPkgName = StripDirExt($opt_output);
227
 
228
    #
229
    #   Display variables used
230
    #
231
    Message    "=Building Debian Package =============================================";
417 dpurdie 232
    Message    "Build $opt_name";
407 dpurdie 233
    Message    "       Package: $opt_buildname";
427 dpurdie 234
    Message    "       Variant: $opt_variant" if ($opt_variant);
407 dpurdie 235
    Message    "       Version: $opt_buildversion";
236
    Message    "  Building for: $opt_platform, $opt_target";
237
    Message    "       Product: $opt_product";
238
    Message    "          Type: $opt_type";
3921 dpurdie 239
    Message    "      Pkg Arch: $opt_pkgarch" if ($opt_pkgarch);
407 dpurdie 240
    Verbose    "       Verbose: $opt_verbose";
241
    Verbose    "  InterfaceDir: $opt_interfacedir";
242
    Message    "       Package: $DebianPkgName";
243
    Message    "======================================================================";
244
 
245
    #
3921 dpurdie 246
    #   Defaults
247
    #
248
    $opt_pkgarch = $opt_platform unless ( $opt_pkgarch );
249
 
250
    #
407 dpurdie 251
    #   Perform Clean up
252
    #   Invoked during "make clean" or "make clobber"
253
    #
254
    if ( $opt_clean )
255
    {
256
        Message ("Remove packaging directory: $DebianWorkDir");
425 dpurdie 257
 
258
        #
259
        #   Remove the directory for this package
260
        #   Remove the general work dir - if all packages have been cleaned
261
        #
407 dpurdie 262
        rmtree( $DebianWorkDir );
425 dpurdie 263
        rmdir( $DebianWorkDirBase );
407 dpurdie 264
        rmtree ($opt_output) if ( -f $opt_output );
265
        exit;
266
    }
267
 
268
    #
269
    #   Clean  out the WORK directory
270
    #   Always start with a clean slate
271
    #
272
    #   Ensure that the base of the directory tree does not have 'setgid'
273
    #       This will upset the debian packager
274
    #       This may be an artifact from the users directory and not expected
275
    #
276
    rmtree( $DebianWorkDir );
277
    mkpath( $DebianWorkDir );
278
 
279
    my $perm = (stat $DebianWorkDir)[2] & 0777;
280
    chmod ( $perm & 0777, $DebianWorkDir );
281
 
282
    #
283
    #   Invoke the user script to do the hard work
284
    #
285
    do $opt_package_script;
286
 
287
    #
288
    #   Complete the building of the package
289
    #
290
    BuildDebianPackage ();
291
    Message ("Created Debian Package");
292
}
293
 
294
#-------------------------------------------------------------------------------
295
# Function        : BuildDebianPackage
296
#
297
# Description     : This function will create the Debian Package
298
#                   and transfer it to the target directory
299
#
300
# Inputs          : None
301
#
302
# Returns         : Nothing
303
#
304
sub BuildDebianPackage
305
{
306
    Error ("BuildDebianPackage: No Control File or Package Description")
307
        unless ( $opt_control || $opt_description );
308
 
309
    #
310
    #   Convert the FileSystem Image into a Debian Package
311
    #       Insert Debian control files
312
    #
313
    Verbose ("Copy in the Debian Control Files");
314
    mkdir ( "$DebianWorkDir/DEBIAN" );
315
 
316
    CopyFile ( $opt_prerm,    "/DEBIAN", "prerm" )    if $opt_prerm;
317
    CopyFile ( $opt_postrm,   "/DEBIAN", "postrm" )   if $opt_postrm;
318
    CopyFile ( $opt_preinst,  "/DEBIAN", "preinst" )  if $opt_preinst;
319
    CopyFile ( $opt_postinst, "/DEBIAN", "postinst" ) if $opt_postinst;
320
 
321
    UpdateControlFile ($opt_control );
322
    System ( 'chmod', '-R', 'a+rx', "$DebianWorkDir/DEBIAN" );
323
    System ( 'build_dpkg.sh', '-b', $DebianWorkDir);
324
    System ( 'mv', '-f', "$DebianWorkDir.deb", $opt_output );
325
 
326
    System ("build_dpkg.sh", '-I', $opt_output) if (IsVerbose(1));
327
 
328
}
329
 
330
#-------------------------------------------------------------------------------
331
# Function        : UpdateControlFile
332
#
333
# Description     : Update the Debian 'control' file to fix up varoius fields
334
#                   within the file.
335
#
336
#                   If the files has not been specified, then a basic control
337
#                   file will be provided.
338
#
339
#                   This routine knows where the control file will be placed
340
#                   within the output work space.
341
#
342
# Inputs          : $src            - Path to source file
343
#                   Uses global variables
344
#
345
# Returns         : Nothing
346
#
347
sub UpdateControlFile
348
{
349
    my($src) = @_;
350
    my $dst = "$DebianWorkDir/DEBIAN/control";
351
 
352
    unless ( $src )
353
    {
354
        CreateControlFile();
355
        return;
356
    }
357
 
358
    Verbose ("UpdateControlFile: $dst" );
359
    $src = ResolveFile( 0, $src );
360
 
361
    open (SF, '<', $src) || Error ("UpdateControlFile: Cannot open $src");
362
    open (DF, '>', $dst) || Error ("UpdateControlFile: Cannot create:$dst");
363
    while ( <SF> )
364
    {
365
        s~\s*$~~;
366
        if ( m~^Package:~ ) {
4105 dpurdie 367
            $_ = "Package: $opt_name";
407 dpurdie 368
 
369
        } elsif ( m~^Version:~ ) {
370
            $_ = "Version: $opt_buildversion";
371
 
372
        } elsif ( m~^Architecture:~ ) {
3921 dpurdie 373
            $_ = "Architecture: $opt_pkgarch";
407 dpurdie 374
 
375
        } elsif ( $opt_description && m~^Description:~ ) {
376
            $_ = "Description: $opt_description";
377
        }
378
        print DF $_ , "\n";
379
    }
380
    close (SF);
381
    close (DF);
382
}
383
 
384
#-------------------------------------------------------------------------------
385
# Function        : CreateControlFile
386
#
387
# Description     : Craete a basic debian control file
388
#
389
# Inputs          : Uses global variables
390
#
391
# Returns         : 
392
#
393
sub CreateControlFile
394
{
395
    my $dst = "$DebianWorkDir/DEBIAN/control";
396
 
397
    Verbose ("CreateControlFile: $dst" );
398
 
399
    open (DF, '>', $dst) || Error ("CreateControlFile: Cannot create:$dst");
4105 dpurdie 400
    print DF "Package: $opt_name\n";
407 dpurdie 401
    print DF "Version: $opt_buildversion\n";
402
    print DF "Section: main\n";
403
    print DF "Priority: standard\n";
3921 dpurdie 404
    print DF "Architecture: $opt_pkgarch\n";
405
    print DF "Essential: No\n";
406
    print DF "Maintainer: Vix Technology\n";
407 dpurdie 407
    print DF "Description: $opt_description\n";
408
    close (DF);
409
}
410
 
411
#-------------------------------------------------------------------------------
412
# Function        : SetVerbose
413
#
414
# Description     : Set the level of verbosity
415
#                   Display activity
416
#
417
# Inputs          : Verbosity level
418
#                       0 - Use makefile verbosity (Default)
419
#                       1..2
420
#
421
# Returns         : 
422
#
423
sub SetVerbose
424
{
425
    my ($level) = @_;
426
 
427
    $level = $opt_verbose unless ( $level );
428
    $opt_verbose = $level;
429
    ErrorConfig( 'verbose' => $level);
430
}
431
 
432
 
433
#-------------------------------------------------------------------------------
434
# Function        : DebianFiles
435
#
436
# Description     : Name Debian builder control files
437
#                   May be called multiple times
438
#
439
# Inputs          : Options
440
#                       --Control=file
441
#                       --PreRm=file
442
#                       --PostRm=file
443
#                       --PreInst=file
444
#                       --PostInst=file
445
#
446
# Returns         : Nothing
447
#
448
sub DebianFiles
449
{
450
    #
451
    #   Exctact names
452
    #
453
    Verbose ("Specify Debian Control Files and Scripts");
454
    foreach  ( @_ )
455
    {
456
        if ( m/^--Control=(.+)/ ) {
457
            $opt_control = $1;
458
 
459
        } elsif ( m/^--PreRm=(.+)/ ) {
460
            $opt_prerm = $1;
461
 
462
        } elsif ( m/^--PostRm=(.+)/ ) {
463
            $opt_postrm = $1;
464
 
465
        } elsif ( m/^--PreInst=(.+)/ ) {
466
            $opt_preinst  = $1;
467
 
468
        } elsif ( m/^--PostInst=(.+)/ ) {
469
            $opt_postinst = $1;
470
 
471
        } else {
472
            Error ("DebianFiles: Unknown option: $_");
473
        }
474
    }
475
}
476
 
477
#-------------------------------------------------------------------------------
478
# Function        : PackageDescription
479
#
480
# Description     : Specify the Package Description
481
#                   Keep it short
482
#
483
# Inputs          : $description
484
#
485
# Returns         : 
486
#
487
sub PackageDescription
488
{
489
    ($opt_description) = @_;
490
}
491
 
492
#-------------------------------------------------------------------------------
493
# Function        : MakeSymLink
494
#
495
# Description     : Create a symlink - with error detection
496
#
497
# Inputs          : old_file    - Link Target
498
#                                 Path to the link target
499
#                                 If an ABS path is provided, the routine will
500
#                                 attempt to create a relative link.
501
#                   new_file    - Relative to the output work space
502
#                                 Path to where the 'link' file will be created
503
#                   Options     - Must be last
504
#                                 --NoClean         - Don't play with links
505
#                                 --NoDotDot        - Don't create symlinks with ..
506
#
507
# Returns         : Nothing
508
#
509
sub MakeSymLink
510
{
511
    my $no_clean;
512
    my $no_dot;
513
    my @args;
514
 
515
    #
516
    #   Extract options
517
    #
518
    foreach ( @_ )
519
    {
520
        if ( m/^--NoClean/i ) {
521
            $no_clean = 1;
522
 
523
        } elsif ( m/^--NoDotDot/i ) {
524
            $no_dot = 1;
525
 
526
        } elsif ( m/^--/ ) {
527
            Error ("MakeSymLink: Unknown option: $_");
528
 
529
        } else {
530
            push @args, $_;
531
        }
532
    }
533
 
534
    my ($old_file, $new_file) = @args;
535
 
536
    my $tfile = $DebianWorkDir . '/' . $new_file;
537
    $tfile =~ s~//~/~;
538
    Verbose ("Symlink $old_file -> $new_file" );
539
 
540
    #
541
    #   Create the directory in which the link will be placed
542
    #   Remove any existing file of the same name
543
    #
544
    my $dir = StripFileExt( $tfile );
545
    mkpath( $dir) unless -d $dir;
546
    unlink $tfile;
547
 
548
    #
549
    #   Determine a good name of the link
550
    #   Convert to a relative link in an attempt to prune them
551
    #
552
    my $sfile = $old_file;
553
    unless ( $no_clean )
554
    {
555
        $sfile = CalcRelPath( StripFileExt( $new_file ), $old_file );
556
        $sfile = $old_file if ( $no_dot && $sfile =~ m~^../~ );
557
    }
558
 
559
    my $result = symlink $sfile, $tfile;
560
    Error ("Cannot create symlink. $old_file -> $new_file") unless ( $result );
561
}
562
 
563
#-------------------------------------------------------------------------------
564
# Function        : CopyFile
565
#
566
# Description     : Copy a file to a target dir
567
#                   Used for text files, or files with fixed names
568
#
569
# Inputs          : $src
570
#                   $dst_dir    - Within the output workspace
571
#                   $dst_name   - Output Name [Optional]
572
#                   Options     - Common Copy Options
573
#
574
# Returns         : Full path to destination file
575
#
576
sub CopyFile
577
{
578
    CopyFileCommon( \&ResolveFile, @_ );
579
}
580
 
581
#-------------------------------------------------------------------------------
582
# Function        : CopyBinFile
583
#
584
# Description     : Copy a file to a target dir
585
#                   Used for executable programs. Will look in places where
586
#                   programs are stored.
587
#
588
# Inputs          : $src
589
#                   $dst_dir    - Within the output workspace
590
#                   $dst_name   - Output Name [Optional]
591
#
592
#                   Options:
593
#                       --FromPackage
594
#                       --SoftLink=xxxx
595
#                       --LinkFile=xxxx
596
#
597
#
598
# Returns         : Full path to destination file
599
#
600
sub CopyBinFile
601
{
602
    CopyFileCommon( \&ResolveBinFile, @_ );
603
}
604
 
605
#-------------------------------------------------------------------------------
606
# Function        : CopyLibFile
607
#
608
# Description     : Copy a file to a target dir
609
#                   Used for shared programs. Will look in places where
610
#                   shared libraries are stored.
611
#
612
# Inputs          : $src        - Base for 'realname' (no lib, no extension)
613
#                   $dst_dir    - Within the output workspace
614
#                   $dst_name   - Output Name [Optional, but not suggested]
615
#
616
# Returns         : Full path to destination file
617
#
618
# Notes           : Copying 'lib' files
619
#                   These are 'shared libaries. There is no provision for copying
620
#                   static libraries.
621
#
622
#                   The tool will attempt to copy a well-formed 'realname' library
623
#                   The soname of the library should be constructed on the target
624
#                   platform using ldconfig.
625
#                   There is no provision to copy the 'linker' name
626
#
627
#                   Given a request to copy a library called 'fred', then the
628
#                   well formed 'realname' will be:
629
#                           libfred[P|D|]].so.nnnnn
630
#                   where:
631
#                           nnnn is the library version
632
#                           [P|D|] indicates Production, Debug or None
633
#
634
#                   The 'soname' is held within the realname form of the library
635
#                   and will be created by lsconfig.
636
#
637
#                   The 'linkername' would be libfred[P|D|].so. This is only
638
#                   needed when linking against the library.
639
#
640
#
641
#                   The routine will also recognize Windows DLLs
642
#                   These are of the form fred[P|D|].nnnnn.dll
643
#
644
sub CopyLibFile
645
{
646
    CopyFileCommon( \&ResolveLibFile, @_ );
647
}
648
 
649
#-------------------------------------------------------------------------------
650
# Function        : CopyFileCommon
651
#
652
# Description     : Common ( internal File Copy )
653
#
654
# Inputs          : $resolver           - Ref to function to resolve source file
655
#                   $src                - Source File Name
656
#                   $dst_dir            - Target Dir
657
#                   $dst_name           - Target Name (optional)
658
#                   Options
659
#                   Options:
660
#                       --FromPackage
661
#                       --SoftLink=xxxx
662
#                       --LinkFile=xxxx
663
#
664
# Returns         : 
665
#
666
sub CopyFileCommon
667
{
668
    my $from_package = 0;
669
    my $isa_linkfile = 0;
670
    my @llist;
671
    my @args;
672
 
673
    #
674
    #   Parse options
675
    #
676
    foreach ( @_ )
677
    {
678
        if ( m/^--FromPackage/ ) {
679
            $from_package = 1;
680
 
681
        } elsif ( m/^--LinkFile/ ) {
682
            $isa_linkfile = 1;
683
 
684
        } elsif ( m/^--SoftLink=(.+)/ ) {
685
            push @llist, $1;
686
 
687
        } elsif ( m/^--/ ) {
688
            Error ("FileCopy: Unknown option: $_");
689
 
690
        } else {
691
            push @args, $_;
692
        }
693
    }
694
 
695
    #
696
    #   Extract non-options.
697
    #   These are the bits that are left over
698
    #
699
    my ($resolver, $src, $dst_dir, $dst_name ) = @args;
700
 
701
    #
702
    #   Clean up dest_dir. Must start with a / and not end with one
703
    #
704
    $dst_dir = "/$dst_dir/";
705
    $dst_dir =~ s~/+~/~g;
706
    $dst_dir =~ s~/$~~;
707
 
708
    Verbose ("CopyFile: $src, $dst_dir, " . ($dst_name || ''));
709
    foreach $src ( &$resolver( $from_package, $src ) )
710
    {
711
        my $dst_fname = $dst_name ? $dst_name : StripDir($src);
712
        my $dst_file = "$dst_dir/$dst_fname";
713
        Verbose ("CopyFile: Copy $src, $dst_file" );
714
 
715
 
716
        #
717
        #   LinkFiles are special
718
        #   They get concatenated to any existing LINKS File
719
        #
720
        if ( $isa_linkfile )
721
        {
722
            CatFile ( $src, "$dst_dir/.LINKS" );
723
        }
724
        else
725
        {
726
            mkpath( "$DebianWorkDir$dst_dir", 0, 0775);
727
            unlink ("$DebianWorkDir$dst_file");
728
            System ('cp','-f', $src, "$DebianWorkDir$dst_file" );
729
 
730
            foreach my $lname ( @llist )
731
            {
732
                $lname = $dst_dir . '/' . $lname unless ( $lname =~ m ~^/~ );
733
                MakeSymLink( $dst_file ,$lname);
734
            }
735
        }
736
    }
737
}
738
 
739
#-------------------------------------------------------------------------------
740
# Function        : CopyDir
741
#
742
# Description     : Copy a directory to a target dir
743
#
744
# Inputs          : $src_dir    - Local to the user
745
#                                 Symbolic Name
746
#                   $dst_dir    - Within the output workspace
747
#                   Options
423 dpurdie 748
#                       --Merge             - Don't delete first
749
#                       --Source=Name       - Source via Symbolic Name
425 dpurdie 750
#                       --FromPackage       - Souve via package roots
407 dpurdie 751
#
752
# Returns         :
753
#
754
sub CopyDir
755
{
756
    my ($src_dir, $dst_dir, @opts) = @_;
757
    my $opt_merge;
758
    my $opt_base;
411 dpurdie 759
    my $from_interface = 0;
407 dpurdie 760
 
761
    $dst_dir = $DebianWorkDir . '/' . $dst_dir;
762
    $dst_dir =~ s~//~/~;
763
 
764
    #
765
    #   Detect and expand Symbolic names in the Source Directory
766
    #
767
    foreach  ( @opts )
768
    {
769
        if ( m/^--Merge/ ) {
770
            $opt_merge = 1;
771
        } elsif ( m/^--Source=(.+)/ ) {
425 dpurdie 772
            my $name = $1;
773
            Verbose2 ("CopyDir: Source: $name");
774
            Error ("Source directory can only be specified once")
775
                if ( defined $opt_base );
776
 
777
            $name = lc($name);
407 dpurdie 778
            my %CopyDirSymbolic = (
779
                'interfaceincdir'   => $opt_interfaceincdir,
780
                'interfacelibdir'   => $opt_interfacelibdir,
781
                'interfacebindir'   => $opt_interfacebindir,
782
                'libdir'            => $opt_libdir,
783
                'bindir'            => $opt_bindir,
784
                'localincdir'       => $opt_localincdir,
785
                'locallibdir'       => $opt_locallibdir,
786
                'localbindir'       => $opt_localbindir,
787
                'packagebindir'     => $opt_pkgbindir,
788
                'packagelibdir'     => $opt_pkglibdir,
789
                'packagepkgdir'     => $opt_pkgpkgdir,
790
                'packagedir'        => $opt_pkgdir,
791
            );
792
 
793
            if ( exists $CopyDirSymbolic{$name} )
794
            {
795
                $opt_base = $CopyDirSymbolic{$name};
411 dpurdie 796
 
797
                #
798
                #   If sourceing from interface, then follow
799
                #   symlinks in the copy. All files will be links anyway
800
                #
801
                $from_interface = 1
802
                    if ( $name =~ m~^interface~ );
407 dpurdie 803
            }
804
            else
805
            {
806
                DebugDumpData ("CopyDirSymbolic", \%CopyDirSymbolic);
807
                Error ("CopyDir: Unknown Source Name: $name" );
808
            }
425 dpurdie 809
 
810
        } elsif ( m/^--FromPackage/ ) {
811
            Verbose2 ("CopyDir: FromPackage: $src_dir");
812
            Error ("Source directory can only be specified once")
813
                if ( defined $opt_base );
814
 
815
            my @path;
816
            foreach my $entry ( getPackageList() )
817
            {
818
                my $base = $entry->getBase(3);
819
                next unless ( defined $base );
820
                if ( -d $base . '/' . $src_dir )
821
                {
822
                    push @path, $base;
2021 dpurdie 823
                    $from_interface = 1
824
                        if ( $entry->{'TYPE'} eq 'interface' );
425 dpurdie 825
                }
826
            }
827
 
828
            Error ("CopyDir: Cannot find source dir in any package: $src_dir")
829
                if ( $#path < 0 );
830
            Error ("CopyDir: Requested path found in mutiple packages: $src_dir",
831
                    @path ) if ( $#path > 0 );
832
            $opt_base = pop @path;
833
 
834
            #
835
            #   If sourceing from interface, then follow symlinks in the copy.
836
            #   All files will be links anyway
837
            #
838
            #   This is a very ugly test for 'interface'
839
            #
840
            $from_interface = 1
841
                if ( $opt_base =~ m~/interface/~ );
842
 
407 dpurdie 843
        } else {
844
            Error ("CopyDir: Unknown option: $_" );
845
        }
846
    }
847
 
848
    $src_dir = $opt_base . '/' . $src_dir if ( $opt_base );
849
    $src_dir =~ s~//~/~g;
850
    $src_dir =~ s~/$~~;
851
 
852
    Verbose ("CopyDir: $src_dir, $dst_dir");
853
    Error ("CopyDir: Directory not found: $src_dir") unless ( -d $src_dir );
854
 
855
    #
423 dpurdie 856
    #   Setup the copy options
407 dpurdie 857
    #
423 dpurdie 858
    my %copyOpts;
4101 dpurdie 859
    $copyOpts{'IgnoreDirs'} = ['.svn', '.git', '.cvs', '.hg'];
860
    $copyOpts{'Ignore'} = ['.gbedir', '_gbedir'];
423 dpurdie 861
    $copyOpts{'EmptyDirs'} = 1;
862
    $copyOpts{'DeleteFirst'} = 1 unless $opt_merge;
863
    $copyOpts{'Log'} = 1 if ( $opt_verbose > 1 );
864
    $copyOpts{'DuplicateLinks'} = 1 unless ( $from_interface );
407 dpurdie 865
 
866
    #
423 dpurdie 867
    #   Transfer the directory
407 dpurdie 868
    #
423 dpurdie 869
    JatsCopy::CopyDir ( $src_dir, $dst_dir, \%copyOpts );
407 dpurdie 870
 
871
    #
872
    #   Expand link files that may have been copied in
873
    #
874
    Verbose ("Locate LINKFILES in $DebianWorkDir");
875
    ExpandLinkFiles();
876
}
877
 
878
#-------------------------------------------------------------------------------
879
# Function        : AddInitScript
880
#
881
# Description     : Add an Init Script to the target
882
#                   Optionally create start and stop links
883
#
884
# Inputs          : $script     - Name of the init script
885
#                   $start      - Start Number
886
#                   $stop       - Stop Number
887
#                   Options:
888
#                       --NoCopy        - Don't copy the script, just add links
889
#                       --Afc           - Place in AFC init area
890
#                       --FromPackage   - Source is in a package
891
#
892
# Returns         : 
893
#
894
sub AddInitScript
895
{
896
    my $no_copy;
897
    my $basedir = "";
898
    my @args;
899
    my $from_package = 0;
900
 
901
    #
902
    #   Process and Remove options
903
    #
904
    foreach  ( @_ )
905
    {
906
        if ( m/^--NoCopy/ ) {
907
            $no_copy = 1;
908
 
909
        } elsif ( m/^--Afc/ ) {
910
            $basedir = "/afc";
911
 
912
        } elsif ( m/^--FromPackage/ ) {
913
            $from_package = 1;
914
 
915
        } elsif ( m/^--/ ) {
916
            Error ("AddInitScript: Unknown option: $_");
917
 
918
        } else {
919
            push @args, $_;
920
 
921
        }
922
    }
923
 
924
    my( $script, $start, $stop ) = @args;
925
    Error ("No script file specified") unless ( $script );
926
    Warning("AddInitScript: No start or stop index specified") unless ( $start || $stop );
927
    Verbose ("AddInitScript: $script, " . ($start || 'No Start') . ", " . ($stop || 'No Stop'));
928
    $script = ResolveFile($from_package, $script );
929
 
930
    my $tdir = $basedir . "/etc/init.d/init.d";
931
    my $base = StripDir($script);
932
 
933
    CopyFile( $script, $tdir ) unless $no_copy;
934
 
935
    my $link;
936
    if ( $start )
937
    {
938
        $link = sprintf ("${basedir}/etc/init.d/S%2.2d%s", $start, $base );
939
        MakeSymLink( "$tdir/$base", $link);
940
    }
941
 
942
    if ( $stop )
943
    {
944
        $link = sprintf ("${basedir}/etc/init.d/K%2.2d%s", $stop, $base );
945
        MakeSymLink( "$tdir/$base", $link);
946
    }
947
}
948
 
949
#-------------------------------------------------------------------------------
950
# Function        : CatFile
951
#
952
# Description     : Copy a file to the end of a file
953
#
954
# Inputs          : $src
955
#                   $dst    - Within the output workspace
956
#
957
# Returns         :
958
#
959
sub CatFile
960
{
961
    my ($src, $dst) = @_;
962
 
963
    $dst = $DebianWorkDir . '/' . $dst;
964
    $dst =~ s~//~/~;
965
    Verbose ("CatFile: $src, $dst");
966
    $src = ResolveFile(0, $src );
967
 
968
    open (SF, '<', $src)  || Error ("CatFile: Cannot open $src");
969
    open (DF, '>>', $dst) || Error ("CatFile: Cannot create:$dst");
970
    while ( <SF> )
971
    {
972
        print DF $_;
973
    }
974
    close (SF);
975
    close (DF);
976
}
977
 
978
#-------------------------------------------------------------------------------
979
# Function        : EchoFile
980
#
981
# Description     : Echo simple text to a file
982
#
983
# Inputs          : $file   - Within the output workspace
984
#                   $text
985
#
986
# Returns         : 
987
#
988
sub EchoFile
989
{
990
    my ($file, $text) = @_;
991
    Verbose ("EchoFile: $file");
992
 
993
    $file = $DebianWorkDir . '/' . $file;
994
    $file =~ s~//~/~;
995
 
996
    unlink $file;
997
    open (DT, ">", $file ) || Error ("Cannot create $file");
998
    print DT  $text || Error ("Cannot print to $file");
999
    close DT;
1000
}
1001
 
1002
#-------------------------------------------------------------------------------
1003
# Function        : SetFilePerms
1004
#
1005
# Description     : Set file permissions on one or more files or directories
1006
#
1007
# Inputs          : $perm           - Perm Mask
1008
#                   @paths          - List of paths/files to process
1009
#                   Options
1010
#                       --Recurse   - Recurse subdirs
1011
#
1012
# Returns         : 
1013
#
1014
sub SetFilePerms
1015
{
1016
 
1017
    my @args;
1018
    my $perms;
1019
    my $recurse = 0;
1020
 
1021
    #
1022
    #   Process and Remove options
1023
    #
1024
    foreach  ( @_ )
1025
    {
1026
        if ( m/^--Recurse/ ) {
1027
            $recurse = 1;
1028
 
1029
        } elsif ( m/^--/ ) {
1030
            Error ("SetFilePerms: Unknown option: $_");
1031
 
1032
        } else {
1033
            push @args, $_;
1034
 
1035
        }
1036
    }
1037
 
1038
    $perms = shift @args;
1039
    Error ("SetFilePerms: No Permissions" ) unless ( $perms );
1040
 
1041
    foreach my $path ( @args )
1042
    {
1043
        Verbose ("Set permissions; $perms, $path");
1044
        my $full_path = $DebianWorkDir . '/' . $path;
1045
        if ( -f $full_path )
1046
        {
1047
            System ('chmod', $perms, $full_path );
1048
        }
1049
        elsif ( -d $full_path )
1050
        {
1051
            System ('chmod', '-R', $perms, $full_path ) if ($recurse);
1052
            System ('chmod', $perms, $full_path ) unless ($recurse);
1053
        }
1054
        else
1055
        {
1056
            Warning("SetFilePerms: Path not found: $path");
1057
        }
1058
    }
1059
}
1060
 
1061
#-------------------------------------------------------------------------------
1062
# Function        : CreateDir
1063
#
1064
# Description     : Create a directory within the target workspace
1065
#
1066
# Inputs          : $path           - Name of the target directory
1067
#
1068
# Returns         : Nothing
1069
#
1070
sub CreateDir
1071
{
1072
    my ($path) = @_;
1073
 
1074
    Verbose ("Create Dir: $path");
1075
    mkpath( $DebianWorkDir . '/' . $path );
1076
}
1077
 
1078
#-------------------------------------------------------------------------------
1079
# Function        : IsProduct
1080
#                   IsPlatform
1081
#                   IsTarget
427 dpurdie 1082
#                   IsVariant
407 dpurdie 1083
#
1084
# Description     : This function allows some level of control in the
1085
#                   packaging scripts. It will return true if the current
1086
#                   product is listed.
1087
#
1088
#                   Ugly after thought
1089
#
1090
#                   Intended use:
1091
#                       Xxxxxx(...) if (IsProduct( 'aaa',bbb' );
1092
#
1093
# Inputs          : products    - a list of products to compare against
1094
#
1095
# Returns         : True if the current build is for one of the listed products
1096
#
1097
sub IsProduct
1098
{
1099
    foreach ( @_ )
1100
    {
1101
        return 1 if ( $opt_product eq $_ );
1102
    }
1103
    return 0;
1104
}
1105
 
1106
sub IsPlatform
1107
{
1108
    foreach ( @_ )
1109
    {
1110
        return 1 if ( $opt_platform eq $_ );
1111
    }
1112
    return 0;
1113
}
1114
 
1115
sub IsTarget
1116
{
1117
    foreach ( @_ )
1118
    {
1119
        return 1 if ( $opt_target eq $_ );
1120
    }
1121
    return 0;
1122
}
1123
 
427 dpurdie 1124
sub IsVariant
1125
{
1126
    foreach ( @_ )
1127
    {
1128
        return 1 if ( $opt_variant eq $_ );
1129
    }
1130
    return 0;
1131
}
407 dpurdie 1132
 
1133
#-------------------------------------------------------------------------------
1134
# Function        : FindFiles
1135
#
1136
# Description     : Locate files within a given dir tree
1137
#
1138
# Inputs          : $root           - Base of the search
1139
#                   $match          - Re to match
1140
#
1141
# Returns         : A list of files that match
1142
#
1143
my @FIND_LIST;
1144
my $FIND_NAME;
1145
 
1146
sub FindFiles
1147
{
1148
    my ($root, $match ) = @_;
1149
    Verbose2("FindFiles: Root: $root, Match: $match");
1150
 
1151
    #
1152
    #   Becareful of closure, Must use globals
1153
    #
1154
    @FIND_LIST = ();
1155
    $FIND_NAME = $match;
1156
    File::Find::find( \&find_files, $root);
1157
 
1158
    #
1159
    #   Find callback program
1160
    #
1161
    sub find_files
1162
    {
1163
        my $item =  $File::Find::name;
1164
 
1165
        return if ( -d $File::Find::name );
1166
        return unless ( $_ =~ m~$FIND_NAME~ );
1167
        push @FIND_LIST, $item;
1168
    }
1169
    return @FIND_LIST;
1170
}
1171
 
1172
#-------------------------------------------------------------------------------
1173
# Function        : CalcRelPath
1174
#
1175
# Description     : Return the relative path to the current working directory
1176
#                   as provided in $Cwd
1177
#
1178
# Inputs          : $Cwd - Base dir
1179
#                   $base - Path to convert
1180
#
1181
# Returns         : Relative path from the $Cwd
1182
#
1183
sub CalcRelPath
1184
{
1185
    my ($Cwd, $base) = @_;
1186
 
1187
    my @base = split ('/', $base );
1188
    my @here = split ('/', $Cwd );
1189
    my $result;
1190
 
1191
    Debug("RelPath: Source: $base");
1192
 
1193
    return $base unless ( $base =~ m~^/~ );
1194
 
1195
    #
1196
    #   Remove common bits from the head of both lists
1197
    #
1198
    while ( $#base >= 0 && $#here >= 0 && $base[0] eq $here[0] )
1199
    {
1200
        shift @base;
1201
        shift @here;
1202
    }
1203
 
1204
    #
1205
    #   Need to go up some directories from here and then down into base
1206
    #
1207
    $result = '../' x ($#here + 1);
1208
    $result .= join ( '/', @base);
1209
    $result = '.' unless ( $result );
1210
    $result =~ s~//~/~g;
1211
    $result =~ s~/$~~;
1212
 
1213
    Debug("RelPath: Result: $result");
1214
    return $result;
1215
}
1216
 
1217
#-------------------------------------------------------------------------------
1218
# Function        : ExpandLinkFiles
1219
#
1220
# Description     : Look for .LINK files in the output image and expand
1221
#                   the links into softlinks
1222
#
1223
# Inputs          : None
1224
#                   The rouine works on the $DebianWorkDir directory tree
1225
#
1226
# Returns         : Nothing
1227
#                   Will remove .LINKS files that are processed
1228
#
1229
sub ExpandLinkFiles
1230
{
1231
    foreach my $linkfile ( FindFiles( $DebianWorkDir, ".LINKS" ))
1232
    {
1233
        next if ( $linkfile =~ m~/\.svn/~ );
1234
        my $BASEDIR = StripFileExt( $linkfile );
1235
        $BASEDIR =~ s~^$DebianWorkDir/~~;
1236
        Verbose "Expand links: $BASEDIR";
1237
 
1238
        open (LF, "<", $linkfile ) || Error ("Cannot open link file: $linkfile" );
1239
        while ( <LF> )
1240
        {
1241
            chomp;
1242
            next if ( m~^#~ );
1243
            next unless ( $_ );
1244
            my ($link, $file) = split;
1245
 
1246
            MakeSymLink($file ,"$BASEDIR/$link", '--NoDotDot' );
1247
        }
1248
        close (LF);
1249
        unlink $linkfile;
1250
    }
1251
}
1252
 
1253
#-------------------------------------------------------------------------------
1254
# Function        : ResolveFile
1255
#
1256
# Description     : Determine where the source for a file is
415 dpurdie 1257
#                   Will look in (default):
407 dpurdie 1258
#                       Local directory
1259
#                       Local Include
415 dpurdie 1260
#                   Or  (FromPackage)
1261
#                       Our Package directory
1262
#                       Interface directory (BuildPkgArchives)
1263
#                       Packages (LinkPkgArchive)
1264
#
407 dpurdie 1265
#                   Will scan 'parts' subdirs
1266
#
1267
# Inputs          : $from_package       - 0 - Local File
1268
#                   $file
1269
#
1270
# Returns         : Path
1271
#
1272
sub ResolveFile
1273
{
1274
    my ($from_package, $file) = @_;
1275
    my $wildcard = ($file =~ /[*?]/);
415 dpurdie 1276
    my @path;
407 dpurdie 1277
 
1278
    #
415 dpurdie 1279
    #   Determine the paths to search
1280
    #
1281
    if ( $from_package )
1282
    {
1283
        unless ( @ResolveFileList )
1284
        {
1285
            push @ResolveFileList, $opt_pkgdir;
1286
            foreach my $entry ( getPackageList() )
1287
            {
1288
                push @ResolveFileList, $entry->getBase(3);
1289
            }
1290
        }
1291
        @path = @ResolveFileList;
1292
    }
1293
    else
1294
    {
1295
        @path = ('.', $opt_localincdir);
1296
    }
1297
 
1298
    #
407 dpurdie 1299
    #   Determine a full list of 'parts' to search
1300
    #   This is provided within the build information
1301
    #
1302
    my @parts = getPlatformParts ();
1303
    push @parts, '';
1304
 
1305
    my @done;
1306
    foreach my $root (  @path )
1307
    {
1308
        foreach my $subdir ( @parts )
1309
        {
1310
            my $sfile;
415 dpurdie 1311
            $sfile = "$root/$subdir/$file";
1312
            $sfile =~ s~//~/~g;
1313
            $sfile =~ s~^./~~g;
1314
            Verbose2("LocateFile: $sfile, $root, $subdir");
1315
            if ( $wildcard )
1316
            {
1317
                push @done, glob ( $sfile );
1318
            }
1319
            else
1320
            {
1321
                push @done, $sfile if ( -f $sfile || -l $sfile )
1322
            }
407 dpurdie 1323
        }
1324
    }
1325
 
415 dpurdie 1326
    Error ("ResolveFile: File not found: $file", "Search Path:", @path)
407 dpurdie 1327
        unless ( @done );
1328
 
1329
    Warning ("ResolveFile: Multiple instances of file found. Only first is used", @done)
1330
        if ( $#done > 0 && ! $wildcard && !wantarray );
1331
 
1332
    return wantarray ? @done : $done[0];
1333
}
1334
 
1335
#-------------------------------------------------------------------------------
1336
# Function        : ResolveBinFile
1337
#
415 dpurdie 1338
# Description     : Determine where the source for a BIN file is
1339
#                   Will look in (default):
1340
#                       Local directory
1341
#                       Local Include
1342
#                   Or  (FromPackage)
1343
#                       Our Package directory
1344
#                       Interface directory (BuildPkgArchives)
1345
#                       Packages (LinkPkgArchive)
407 dpurdie 1346
#                   Will scan 'parts' subdirs
1347
#
1348
# Inputs          : $from_package       - 0 - Local File
415 dpurdie 1349
#                   $file
407 dpurdie 1350
#
1351
# Returns         : Path
1352
#
1353
sub ResolveBinFile
1354
{
1355
    my ($from_package, $file) = @_;
1356
    my @path;
1357
    my @types;
1358
    my $wildcard = ($file =~ /[*?]/);
1359
 
415 dpurdie 1360
    #
1361
    #   Determine the paths to search
1362
    #
407 dpurdie 1363
    if ( $from_package )
1364
    {
415 dpurdie 1365
        unless ( @ResolveBinFileList )
1366
        {
1367
            push @ResolveBinFileList, $opt_pkgdir . '/bin';
1368
            foreach my $entry ( getPackageList() )
1369
            {
1370
                if ( my $path = $entry->getBase(3) )
1371
                {
1372
                    $path .= '/bin';
1373
                    push @ResolveBinFileList, $path if ( -d $path );
1374
                }
1375
            }
1376
        }
1377
        @path = @ResolveBinFileList;
407 dpurdie 1378
        @types = ($opt_type, '');
1379
    }
1380
    else
1381
    {
1382
        @path = ($opt_bindir, $opt_localbindir);
1383
        @types = '';
1384
    }
1385
 
1386
    #
1387
    #   Determine a full list of 'parts' to search
1388
    #   This is provided within the build information
1389
    #
1390
    my @parts = getPlatformParts ();
1391
    push @parts, '';
1392
 
1393
    my @done;
1394
    foreach my $root (  @path )
1395
    {
1396
        foreach my $subdir ( @parts )
1397
        {
1398
            foreach my $type ( @types )
1399
            {
1400
                my $sfile;
1401
                $sfile = "$root/$subdir$type/$file";
1402
                $sfile =~ s~//~/~g;
1403
                Verbose2("LocateBinFile: $sfile");
1404
                if ( $wildcard )
1405
                {
429 dpurdie 1406
                    foreach  ( glob ( $sfile ) )
1407
                    {
1408
                        next if ( m~\.dbg$~ );
1409
                        push @done, $_;
1410
                    }
407 dpurdie 1411
                }
1412
                else
1413
                {
415 dpurdie 1414
                    push @done, $sfile if ( -f $sfile || -l $sfile )
407 dpurdie 1415
                }
1416
            }
1417
        }
1418
    }
1419
 
415 dpurdie 1420
    Error ("ResolveBinFile: File not found: $file", "Search Path:", @path)
407 dpurdie 1421
        unless ( @done );
1422
 
1423
    Warning ("ResolveBinFile: Multiple instances of file found. Only first is used", @done)
1424
        if ( $#done > 0 && ! $wildcard && !wantarray );
1425
    return wantarray ? @done : $done[0];
1426
}
1427
 
1428
#-------------------------------------------------------------------------------
1429
# Function        : ResolveLibFile
1430
#
415 dpurdie 1431
# Description     : Determine where the source for a LIB file is
1432
#                   Will look in (default):
1433
#                       Local directory
1434
#                       Local Include
1435
#                   Or  (FromPackage)
1436
#                       Our Package directory
1437
#                       Interface directory (BuildPkgArchives)
1438
#                       Packages (LinkPkgArchive)
407 dpurdie 1439
#                   Will scan 'parts' subdirs
1440
#
1441
# Inputs          : $from_package       - 0 - Local File
415 dpurdie 1442
#                   $file       - Basename for a 'realname'
407 dpurdie 1443
#                                 Do not provide 'lib' or '.so' or version info
1444
#                                 May contain embedded options
1445
#                                   --Dll - use Windows style versioned DLL
1446
#                                   --VersionDll - USe the versioned DLL
1447
#
1448
# Returns         : Path
1449
#
1450
sub ResolveLibFile
1451
{
1452
    my ($from_package, $file) = @_;
1453
    my $wildcard = ($file =~ /[*?]/);
1454
    my @options;
1455
    my $num_dll;
415 dpurdie 1456
    my @path;
407 dpurdie 1457
    #
1458
    #   Extract options from file
1459
    #
409 alewis 1460
    $num_dll = 0;
407 dpurdie 1461
    ($file, @options) = split ( ',', $file);
1462
    foreach ( @options )
1463
    {
1464
        if ( m/^--Dll/ ) {
1465
            $num_dll = 1;
1466
        } elsif ( m/^--VersionDll/ ) {
1467
            $num_dll = 2;
1468
        } else {
1469
            Error ("Unknown suboption to ResolveLibFile: $_" );
1470
        }
1471
    }
1472
 
1473
    #
415 dpurdie 1474
    #   Determine the paths to search
1475
    #
1476
    if ( $from_package )
1477
    {
1478
        unless ( @ResolveLibFileList )
1479
        {
1480
            push @ResolveLibFileList, $opt_pkgdir . '/lib';
1481
            foreach my $entry ( getPackageList() )
1482
            {
1483
                push @ResolveLibFileList, $entry->getLibDirs(3);
1484
            }
1485
        }
1486
        @path = @ResolveLibFileList;
1487
    }
1488
    else
1489
    {
1490
        @path = ($opt_libdir, $opt_locallibdir);
1491
    }
1492
 
1493
    #
407 dpurdie 1494
    #   Determine a full list of 'parts' to search
1495
    #   This is provided within the build information
1496
    #
1497
    my @parts = getPlatformParts ();
1498
    push @parts, '';
1499
 
1500
    my @done;
1501
    foreach my $root (  @path )
1502
    {
1503
        foreach my $type ( $opt_type, '' )
1504
        {
1505
            foreach my $subdir ( @parts )
1506
            {
1507
                my $sfile;
1508
                my $exact;
1509
                if ( $num_dll == 2 ) {
1510
                    $sfile = $file . $type . '.*.dll' ;
1511
                } elsif ( $num_dll == 1 ) {
1512
                    $sfile = $file . $type . '.dll' ;
1513
                    $exact = 1;
1514
                } else {
1515
                    $sfile = "lib" . $file . $type . '.so.*';
1516
                }
1517
 
1518
                $sfile = "$root/$subdir/$sfile";
1519
                $sfile =~ s~//~/~g;
1520
                Verbose2("LocateLibFile: $sfile");
1521
                if ( $exact )
1522
                {
415 dpurdie 1523
                    push @done, $sfile if ( -f $sfile || -l $sfile );
407 dpurdie 1524
                }
419 dpurdie 1525
                elsif ($num_dll)
407 dpurdie 1526
                {
1527
                    push @done, glob ( $sfile );
1528
                }
419 dpurdie 1529
                else
1530
                {
1531
                    #
1532
                    #   Looking for .so files
1533
                    #   Filter out the soname so files
1534
                    #   Assume that the soname is shorter than the realname
429 dpurdie 1535
                    #       Ignore .dbg files.
419 dpurdie 1536
                    #
1537
                    my %sieve;
1538
                    foreach ( glob ( $sfile )  )
1539
                    {
429 dpurdie 1540
                        next if ( m~\.dbg$~ );
421 alewis 1541
                        m~(.*\.so\.)([\d\.]*\d)$~;
1542
                        if ( $1 )
1543
                        {
1544
                            my $file = $1;
1545
                            my $len = exists $sieve{$file} ? length($sieve{$file}) : 0;
1546
                            $sieve{$file} = $_
1547
                                if ( $len == 0 || length($_) > $len );
1548
                        }                                
419 dpurdie 1549
                    }
1550
 
1551
                    push @done, values %sieve;
1552
                }
407 dpurdie 1553
            }
1554
        }
1555
    }
1556
 
415 dpurdie 1557
    Error ("ResolveLibFile: File not found: $file", "Search Path:", @path)
407 dpurdie 1558
        unless ( @done );
1559
 
1560
    Warning ("ResolveLibFile: Multiple instances of file found. Only first is used", @done)
1561
        if ( $#done > 0 && ! $wildcard && !wantarray );
1562
 
1563
    return wantarray ? @done : $done[0];
1564
}
1565
 
1566
 
1567
#-------------------------------------------------------------------------------
1568
# Function        : AUTOLOAD
1569
#
1570
# Description     : Intercept bad user directives and issue a nice error message
1571
#                   This is a simple routine to report unknown user directives
1572
#                   It does not attempt to distinguish between user errors and
1573
#                   programming errors. It assumes that the program has been
1574
#                   tested. The function simply report filename and line number
1575
#                   of the bad directive.
1576
#
1577
# Inputs          : Original function arguments ( not used )
1578
#
1579
# Returns         : This function does not return
1580
#
1581
our $AUTOLOAD;
1582
sub AUTOLOAD
1583
{
1584
    my $fname = $AUTOLOAD;
1585
    $fname =~ s~^main::~~;
1586
    my ($package, $filename, $line) = caller;
1587
 
1588
    Error ("Directive not known or not allowed in this context: $fname",
1589
           "Directive: $fname( @_ );",
1590
           "File: $filename, Line: $line" );
1591
}
1592
 
1593
 
1594
1;
1595