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;
865
    $copyOpts{'IgnoreDirs'} = ['.svn'];
866
    $copyOpts{'EmptyDirs'} = 1;
867
    $copyOpts{'DeleteFirst'} = 1 unless $opt_merge;
868
    $copyOpts{'Log'} = 1 if ( $opt_verbose > 1 );
869
    $copyOpts{'DuplicateLinks'} = 1 unless ( $from_interface );
407 dpurdie 870
 
871
    #
423 dpurdie 872
    #   Transfer the directory
407 dpurdie 873
    #
423 dpurdie 874
    JatsCopy::CopyDir ( $src_dir, $dst_dir, \%copyOpts );
407 dpurdie 875
 
876
    #
877
    #   Expand link files that may have been copied in
878
    #
879
    Verbose ("Locate LINKFILES in $DebianWorkDir");
880
    ExpandLinkFiles();
881
}
882
 
883
#-------------------------------------------------------------------------------
884
# Function        : AddInitScript
885
#
886
# Description     : Add an Init Script to the target
887
#                   Optionally create start and stop links
888
#
889
# Inputs          : $script     - Name of the init script
890
#                   $start      - Start Number
891
#                   $stop       - Stop Number
892
#                   Options:
893
#                       --NoCopy        - Don't copy the script, just add links
894
#                       --Afc           - Place in AFC init area
895
#                       --FromPackage   - Source is in a package
896
#
897
# Returns         : 
898
#
899
sub AddInitScript
900
{
901
    my $no_copy;
902
    my $basedir = "";
903
    my @args;
904
    my $from_package = 0;
905
 
906
    #
907
    #   Process and Remove options
908
    #
909
    foreach  ( @_ )
910
    {
911
        if ( m/^--NoCopy/ ) {
912
            $no_copy = 1;
913
 
914
        } elsif ( m/^--Afc/ ) {
915
            $basedir = "/afc";
916
 
917
        } elsif ( m/^--FromPackage/ ) {
918
            $from_package = 1;
919
 
920
        } elsif ( m/^--/ ) {
921
            Error ("AddInitScript: Unknown option: $_");
922
 
923
        } else {
924
            push @args, $_;
925
 
926
        }
927
    }
928
 
929
    my( $script, $start, $stop ) = @args;
930
    Error ("No script file specified") unless ( $script );
931
    Warning("AddInitScript: No start or stop index specified") unless ( $start || $stop );
932
    Verbose ("AddInitScript: $script, " . ($start || 'No Start') . ", " . ($stop || 'No Stop'));
933
    $script = ResolveFile($from_package, $script );
934
 
935
    my $tdir = $basedir . "/etc/init.d/init.d";
936
    my $base = StripDir($script);
937
 
938
    CopyFile( $script, $tdir ) unless $no_copy;
939
 
940
    my $link;
941
    if ( $start )
942
    {
943
        $link = sprintf ("${basedir}/etc/init.d/S%2.2d%s", $start, $base );
944
        MakeSymLink( "$tdir/$base", $link);
945
    }
946
 
947
    if ( $stop )
948
    {
949
        $link = sprintf ("${basedir}/etc/init.d/K%2.2d%s", $stop, $base );
950
        MakeSymLink( "$tdir/$base", $link);
951
    }
952
}
953
 
954
#-------------------------------------------------------------------------------
955
# Function        : CatFile
956
#
957
# Description     : Copy a file to the end of a file
958
#
959
# Inputs          : $src
960
#                   $dst    - Within the output workspace
961
#
962
# Returns         :
963
#
964
sub CatFile
965
{
966
    my ($src, $dst) = @_;
967
 
968
    $dst = $DebianWorkDir . '/' . $dst;
969
    $dst =~ s~//~/~;
970
    Verbose ("CatFile: $src, $dst");
971
    $src = ResolveFile(0, $src );
972
 
973
    open (SF, '<', $src)  || Error ("CatFile: Cannot open $src");
974
    open (DF, '>>', $dst) || Error ("CatFile: Cannot create:$dst");
975
    while ( <SF> )
976
    {
977
        print DF $_;
978
    }
979
    close (SF);
980
    close (DF);
981
}
982
 
983
#-------------------------------------------------------------------------------
984
# Function        : EchoFile
985
#
986
# Description     : Echo simple text to a file
987
#
988
# Inputs          : $file   - Within the output workspace
989
#                   $text
990
#
991
# Returns         : 
992
#
993
sub EchoFile
994
{
995
    my ($file, $text) = @_;
996
    Verbose ("EchoFile: $file");
997
 
998
    $file = $DebianWorkDir . '/' . $file;
999
    $file =~ s~//~/~;
1000
 
1001
    unlink $file;
1002
    open (DT, ">", $file ) || Error ("Cannot create $file");
1003
    print DT  $text || Error ("Cannot print to $file");
1004
    close DT;
1005
}
1006
 
1007
#-------------------------------------------------------------------------------
1008
# Function        : SetFilePerms
1009
#
1010
# Description     : Set file permissions on one or more files or directories
1011
#
1012
# Inputs          : $perm           - Perm Mask
1013
#                   @paths          - List of paths/files to process
1014
#                   Options
1015
#                       --Recurse   - Recurse subdirs
1016
#
1017
# Returns         : 
1018
#
1019
sub SetFilePerms
1020
{
1021
 
1022
    my @args;
1023
    my $perms;
1024
    my $recurse = 0;
1025
 
1026
    #
1027
    #   Process and Remove options
1028
    #
1029
    foreach  ( @_ )
1030
    {
1031
        if ( m/^--Recurse/ ) {
1032
            $recurse = 1;
1033
 
1034
        } elsif ( m/^--/ ) {
1035
            Error ("SetFilePerms: Unknown option: $_");
1036
 
1037
        } else {
1038
            push @args, $_;
1039
 
1040
        }
1041
    }
1042
 
1043
    $perms = shift @args;
1044
    Error ("SetFilePerms: No Permissions" ) unless ( $perms );
1045
 
1046
    foreach my $path ( @args )
1047
    {
1048
        Verbose ("Set permissions; $perms, $path");
1049
        my $full_path = $DebianWorkDir . '/' . $path;
1050
        if ( -f $full_path )
1051
        {
1052
            System ('chmod', $perms, $full_path );
1053
        }
1054
        elsif ( -d $full_path )
1055
        {
1056
            System ('chmod', '-R', $perms, $full_path ) if ($recurse);
1057
            System ('chmod', $perms, $full_path ) unless ($recurse);
1058
        }
1059
        else
1060
        {
1061
            Warning("SetFilePerms: Path not found: $path");
1062
        }
1063
    }
1064
}
1065
 
1066
#-------------------------------------------------------------------------------
1067
# Function        : CreateDir
1068
#
1069
# Description     : Create a directory within the target workspace
1070
#
1071
# Inputs          : $path           - Name of the target directory
1072
#
1073
# Returns         : Nothing
1074
#
1075
sub CreateDir
1076
{
1077
    my ($path) = @_;
1078
 
1079
    Verbose ("Create Dir: $path");
1080
    mkpath( $DebianWorkDir . '/' . $path );
1081
}
1082
 
1083
#-------------------------------------------------------------------------------
1084
# Function        : IsProduct
1085
#                   IsPlatform
1086
#                   IsTarget
427 dpurdie 1087
#                   IsVariant
407 dpurdie 1088
#
1089
# Description     : This function allows some level of control in the
1090
#                   packaging scripts. It will return true if the current
1091
#                   product is listed.
1092
#
1093
#                   Ugly after thought
1094
#
1095
#                   Intended use:
1096
#                       Xxxxxx(...) if (IsProduct( 'aaa',bbb' );
1097
#
1098
# Inputs          : products    - a list of products to compare against
1099
#
1100
# Returns         : True if the current build is for one of the listed products
1101
#
1102
sub IsProduct
1103
{
1104
    foreach ( @_ )
1105
    {
1106
        return 1 if ( $opt_product eq $_ );
1107
    }
1108
    return 0;
1109
}
1110
 
1111
sub IsPlatform
1112
{
1113
    foreach ( @_ )
1114
    {
1115
        return 1 if ( $opt_platform eq $_ );
1116
    }
1117
    return 0;
1118
}
1119
 
1120
sub IsTarget
1121
{
1122
    foreach ( @_ )
1123
    {
1124
        return 1 if ( $opt_target eq $_ );
1125
    }
1126
    return 0;
1127
}
1128
 
427 dpurdie 1129
sub IsVariant
1130
{
1131
    foreach ( @_ )
1132
    {
1133
        return 1 if ( $opt_variant eq $_ );
1134
    }
1135
    return 0;
1136
}
407 dpurdie 1137
 
1138
#-------------------------------------------------------------------------------
1139
# Function        : FindFiles
1140
#
1141
# Description     : Locate files within a given dir tree
1142
#
1143
# Inputs          : $root           - Base of the search
1144
#                   $match          - Re to match
1145
#
1146
# Returns         : A list of files that match
1147
#
1148
my @FIND_LIST;
1149
my $FIND_NAME;
1150
 
1151
sub FindFiles
1152
{
1153
    my ($root, $match ) = @_;
1154
    Verbose2("FindFiles: Root: $root, Match: $match");
1155
 
1156
    #
1157
    #   Becareful of closure, Must use globals
1158
    #
1159
    @FIND_LIST = ();
1160
    $FIND_NAME = $match;
1161
    File::Find::find( \&find_files, $root);
1162
 
1163
    #
1164
    #   Find callback program
1165
    #
1166
    sub find_files
1167
    {
1168
        my $item =  $File::Find::name;
1169
 
1170
        return if ( -d $File::Find::name );
1171
        return unless ( $_ =~ m~$FIND_NAME~ );
1172
        push @FIND_LIST, $item;
1173
    }
1174
    return @FIND_LIST;
1175
}
1176
 
1177
#-------------------------------------------------------------------------------
1178
# Function        : CalcRelPath
1179
#
1180
# Description     : Return the relative path to the current working directory
1181
#                   as provided in $Cwd
1182
#
1183
# Inputs          : $Cwd - Base dir
1184
#                   $base - Path to convert
1185
#
1186
# Returns         : Relative path from the $Cwd
1187
#
1188
sub CalcRelPath
1189
{
1190
    my ($Cwd, $base) = @_;
1191
 
1192
    my @base = split ('/', $base );
1193
    my @here = split ('/', $Cwd );
1194
    my $result;
1195
 
1196
    Debug("RelPath: Source: $base");
1197
 
1198
    return $base unless ( $base =~ m~^/~ );
1199
 
1200
    #
1201
    #   Remove common bits from the head of both lists
1202
    #
1203
    while ( $#base >= 0 && $#here >= 0 && $base[0] eq $here[0] )
1204
    {
1205
        shift @base;
1206
        shift @here;
1207
    }
1208
 
1209
    #
1210
    #   Need to go up some directories from here and then down into base
1211
    #
1212
    $result = '../' x ($#here + 1);
1213
    $result .= join ( '/', @base);
1214
    $result = '.' unless ( $result );
1215
    $result =~ s~//~/~g;
1216
    $result =~ s~/$~~;
1217
 
1218
    Debug("RelPath: Result: $result");
1219
    return $result;
1220
}
1221
 
1222
#-------------------------------------------------------------------------------
1223
# Function        : ExpandLinkFiles
1224
#
1225
# Description     : Look for .LINK files in the output image and expand
1226
#                   the links into softlinks
1227
#
1228
# Inputs          : None
1229
#                   The rouine works on the $DebianWorkDir directory tree
1230
#
1231
# Returns         : Nothing
1232
#                   Will remove .LINKS files that are processed
1233
#
1234
sub ExpandLinkFiles
1235
{
1236
    foreach my $linkfile ( FindFiles( $DebianWorkDir, ".LINKS" ))
1237
    {
1238
        next if ( $linkfile =~ m~/\.svn/~ );
1239
        my $BASEDIR = StripFileExt( $linkfile );
1240
        $BASEDIR =~ s~^$DebianWorkDir/~~;
1241
        Verbose "Expand links: $BASEDIR";
1242
 
1243
        open (LF, "<", $linkfile ) || Error ("Cannot open link file: $linkfile" );
1244
        while ( <LF> )
1245
        {
1246
            chomp;
1247
            next if ( m~^#~ );
1248
            next unless ( $_ );
1249
            my ($link, $file) = split;
1250
 
1251
            MakeSymLink($file ,"$BASEDIR/$link", '--NoDotDot' );
1252
        }
1253
        close (LF);
1254
        unlink $linkfile;
1255
    }
1256
}
1257
 
1258
#-------------------------------------------------------------------------------
1259
# Function        : ResolveFile
1260
#
1261
# Description     : Determine where the source for a file is
415 dpurdie 1262
#                   Will look in (default):
407 dpurdie 1263
#                       Local directory
1264
#                       Local Include
415 dpurdie 1265
#                   Or  (FromPackage)
1266
#                       Our Package directory
1267
#                       Interface directory (BuildPkgArchives)
1268
#                       Packages (LinkPkgArchive)
1269
#
407 dpurdie 1270
#                   Will scan 'parts' subdirs
1271
#
1272
# Inputs          : $from_package       - 0 - Local File
1273
#                   $file
1274
#
1275
# Returns         : Path
1276
#
1277
sub ResolveFile
1278
{
1279
    my ($from_package, $file) = @_;
1280
    my $wildcard = ($file =~ /[*?]/);
415 dpurdie 1281
    my @path;
407 dpurdie 1282
 
1283
    #
415 dpurdie 1284
    #   Determine the paths to search
1285
    #
1286
    if ( $from_package )
1287
    {
1288
        unless ( @ResolveFileList )
1289
        {
1290
            push @ResolveFileList, $opt_pkgdir;
1291
            foreach my $entry ( getPackageList() )
1292
            {
1293
                push @ResolveFileList, $entry->getBase(3);
1294
            }
1295
        }
1296
        @path = @ResolveFileList;
1297
    }
1298
    else
1299
    {
1300
        @path = ('.', $opt_localincdir);
1301
    }
1302
 
1303
    #
407 dpurdie 1304
    #   Determine a full list of 'parts' to search
1305
    #   This is provided within the build information
1306
    #
1307
    my @parts = getPlatformParts ();
1308
    push @parts, '';
1309
 
1310
    my @done;
1311
    foreach my $root (  @path )
1312
    {
1313
        foreach my $subdir ( @parts )
1314
        {
1315
            my $sfile;
415 dpurdie 1316
            $sfile = "$root/$subdir/$file";
1317
            $sfile =~ s~//~/~g;
1318
            $sfile =~ s~^./~~g;
1319
            Verbose2("LocateFile: $sfile, $root, $subdir");
1320
            if ( $wildcard )
1321
            {
1322
                push @done, glob ( $sfile );
1323
            }
1324
            else
1325
            {
1326
                push @done, $sfile if ( -f $sfile || -l $sfile )
1327
            }
407 dpurdie 1328
        }
1329
    }
1330
 
415 dpurdie 1331
    Error ("ResolveFile: File not found: $file", "Search Path:", @path)
407 dpurdie 1332
        unless ( @done );
1333
 
1334
    Warning ("ResolveFile: Multiple instances of file found. Only first is used", @done)
1335
        if ( $#done > 0 && ! $wildcard && !wantarray );
1336
 
1337
    return wantarray ? @done : $done[0];
1338
}
1339
 
1340
#-------------------------------------------------------------------------------
1341
# Function        : ResolveBinFile
1342
#
415 dpurdie 1343
# Description     : Determine where the source for a BIN file is
1344
#                   Will look in (default):
1345
#                       Local directory
1346
#                       Local Include
1347
#                   Or  (FromPackage)
1348
#                       Our Package directory
1349
#                       Interface directory (BuildPkgArchives)
1350
#                       Packages (LinkPkgArchive)
407 dpurdie 1351
#                   Will scan 'parts' subdirs
1352
#
1353
# Inputs          : $from_package       - 0 - Local File
415 dpurdie 1354
#                   $file
407 dpurdie 1355
#
1356
# Returns         : Path
1357
#
1358
sub ResolveBinFile
1359
{
1360
    my ($from_package, $file) = @_;
1361
    my @path;
1362
    my @types;
1363
    my $wildcard = ($file =~ /[*?]/);
1364
 
415 dpurdie 1365
    #
1366
    #   Determine the paths to search
1367
    #
407 dpurdie 1368
    if ( $from_package )
1369
    {
415 dpurdie 1370
        unless ( @ResolveBinFileList )
1371
        {
1372
            push @ResolveBinFileList, $opt_pkgdir . '/bin';
1373
            foreach my $entry ( getPackageList() )
1374
            {
1375
                if ( my $path = $entry->getBase(3) )
1376
                {
1377
                    $path .= '/bin';
1378
                    push @ResolveBinFileList, $path if ( -d $path );
1379
                }
1380
            }
1381
        }
1382
        @path = @ResolveBinFileList;
407 dpurdie 1383
        @types = ($opt_type, '');
1384
    }
1385
    else
1386
    {
1387
        @path = ($opt_bindir, $opt_localbindir);
1388
        @types = '';
1389
    }
1390
 
1391
    #
1392
    #   Determine a full list of 'parts' to search
1393
    #   This is provided within the build information
1394
    #
1395
    my @parts = getPlatformParts ();
1396
    push @parts, '';
1397
 
1398
    my @done;
1399
    foreach my $root (  @path )
1400
    {
1401
        foreach my $subdir ( @parts )
1402
        {
1403
            foreach my $type ( @types )
1404
            {
1405
                my $sfile;
1406
                $sfile = "$root/$subdir$type/$file";
1407
                $sfile =~ s~//~/~g;
1408
                Verbose2("LocateBinFile: $sfile");
1409
                if ( $wildcard )
1410
                {
429 dpurdie 1411
                    foreach  ( glob ( $sfile ) )
1412
                    {
1413
                        next if ( m~\.dbg$~ );
1414
                        push @done, $_;
1415
                    }
407 dpurdie 1416
                }
1417
                else
1418
                {
415 dpurdie 1419
                    push @done, $sfile if ( -f $sfile || -l $sfile )
407 dpurdie 1420
                }
1421
            }
1422
        }
1423
    }
1424
 
415 dpurdie 1425
    Error ("ResolveBinFile: File not found: $file", "Search Path:", @path)
407 dpurdie 1426
        unless ( @done );
1427
 
1428
    Warning ("ResolveBinFile: Multiple instances of file found. Only first is used", @done)
1429
        if ( $#done > 0 && ! $wildcard && !wantarray );
1430
    return wantarray ? @done : $done[0];
1431
}
1432
 
1433
#-------------------------------------------------------------------------------
1434
# Function        : ResolveLibFile
1435
#
415 dpurdie 1436
# Description     : Determine where the source for a LIB file is
1437
#                   Will look in (default):
1438
#                       Local directory
1439
#                       Local Include
1440
#                   Or  (FromPackage)
1441
#                       Our Package directory
1442
#                       Interface directory (BuildPkgArchives)
1443
#                       Packages (LinkPkgArchive)
407 dpurdie 1444
#                   Will scan 'parts' subdirs
1445
#
1446
# Inputs          : $from_package       - 0 - Local File
415 dpurdie 1447
#                   $file       - Basename for a 'realname'
407 dpurdie 1448
#                                 Do not provide 'lib' or '.so' or version info
1449
#                                 May contain embedded options
1450
#                                   --Dll - use Windows style versioned DLL
1451
#                                   --VersionDll - USe the versioned DLL
1452
#
1453
# Returns         : Path
1454
#
1455
sub ResolveLibFile
1456
{
1457
    my ($from_package, $file) = @_;
1458
    my $wildcard = ($file =~ /[*?]/);
1459
    my @options;
1460
    my $num_dll;
415 dpurdie 1461
    my @path;
407 dpurdie 1462
    #
1463
    #   Extract options from file
1464
    #
409 alewis 1465
    $num_dll = 0;
407 dpurdie 1466
    ($file, @options) = split ( ',', $file);
1467
    foreach ( @options )
1468
    {
1469
        if ( m/^--Dll/ ) {
1470
            $num_dll = 1;
1471
        } elsif ( m/^--VersionDll/ ) {
1472
            $num_dll = 2;
1473
        } else {
1474
            Error ("Unknown suboption to ResolveLibFile: $_" );
1475
        }
1476
    }
1477
 
1478
    #
415 dpurdie 1479
    #   Determine the paths to search
1480
    #
1481
    if ( $from_package )
1482
    {
1483
        unless ( @ResolveLibFileList )
1484
        {
1485
            push @ResolveLibFileList, $opt_pkgdir . '/lib';
1486
            foreach my $entry ( getPackageList() )
1487
            {
1488
                push @ResolveLibFileList, $entry->getLibDirs(3);
1489
            }
1490
        }
1491
        @path = @ResolveLibFileList;
1492
    }
1493
    else
1494
    {
1495
        @path = ($opt_libdir, $opt_locallibdir);
1496
    }
1497
 
1498
    #
407 dpurdie 1499
    #   Determine a full list of 'parts' to search
1500
    #   This is provided within the build information
1501
    #
1502
    my @parts = getPlatformParts ();
1503
    push @parts, '';
1504
 
1505
    my @done;
1506
    foreach my $root (  @path )
1507
    {
1508
        foreach my $type ( $opt_type, '' )
1509
        {
1510
            foreach my $subdir ( @parts )
1511
            {
1512
                my $sfile;
1513
                my $exact;
1514
                if ( $num_dll == 2 ) {
1515
                    $sfile = $file . $type . '.*.dll' ;
1516
                } elsif ( $num_dll == 1 ) {
1517
                    $sfile = $file . $type . '.dll' ;
1518
                    $exact = 1;
1519
                } else {
1520
                    $sfile = "lib" . $file . $type . '.so.*';
1521
                }
1522
 
1523
                $sfile = "$root/$subdir/$sfile";
1524
                $sfile =~ s~//~/~g;
1525
                Verbose2("LocateLibFile: $sfile");
1526
                if ( $exact )
1527
                {
415 dpurdie 1528
                    push @done, $sfile if ( -f $sfile || -l $sfile );
407 dpurdie 1529
                }
419 dpurdie 1530
                elsif ($num_dll)
407 dpurdie 1531
                {
1532
                    push @done, glob ( $sfile );
1533
                }
419 dpurdie 1534
                else
1535
                {
1536
                    #
1537
                    #   Looking for .so files
1538
                    #   Filter out the soname so files
1539
                    #   Assume that the soname is shorter than the realname
429 dpurdie 1540
                    #       Ignore .dbg files.
419 dpurdie 1541
                    #
1542
                    my %sieve;
1543
                    foreach ( glob ( $sfile )  )
1544
                    {
429 dpurdie 1545
                        next if ( m~\.dbg$~ );
421 alewis 1546
                        m~(.*\.so\.)([\d\.]*\d)$~;
1547
                        if ( $1 )
1548
                        {
1549
                            my $file = $1;
1550
                            my $len = exists $sieve{$file} ? length($sieve{$file}) : 0;
1551
                            $sieve{$file} = $_
1552
                                if ( $len == 0 || length($_) > $len );
1553
                        }                                
419 dpurdie 1554
                    }
1555
 
1556
                    push @done, values %sieve;
1557
                }
407 dpurdie 1558
            }
1559
        }
1560
    }
1561
 
415 dpurdie 1562
    Error ("ResolveLibFile: File not found: $file", "Search Path:", @path)
407 dpurdie 1563
        unless ( @done );
1564
 
1565
    Warning ("ResolveLibFile: Multiple instances of file found. Only first is used", @done)
1566
        if ( $#done > 0 && ! $wildcard && !wantarray );
1567
 
1568
    return wantarray ? @done : $done[0];
1569
}
1570
 
1571
 
1572
#-------------------------------------------------------------------------------
1573
# Function        : AUTOLOAD
1574
#
1575
# Description     : Intercept bad user directives and issue a nice error message
1576
#                   This is a simple routine to report unknown user directives
1577
#                   It does not attempt to distinguish between user errors and
1578
#                   programming errors. It assumes that the program has been
1579
#                   tested. The function simply report filename and line number
1580
#                   of the bad directive.
1581
#
1582
# Inputs          : Original function arguments ( not used )
1583
#
1584
# Returns         : This function does not return
1585
#
1586
our $AUTOLOAD;
1587
sub AUTOLOAD
1588
{
1589
    my $fname = $AUTOLOAD;
1590
    $fname =~ s~^main::~~;
1591
    my ($package, $filename, $line) = caller;
1592
 
1593
    Error ("Directive not known or not allowed in this context: $fname",
1594
           "Directive: $fname( @_ );",
1595
           "File: $filename, Line: $line" );
1596
}
1597
 
1598
 
1599
1;
1600