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