Subversion Repositories DevTools

Rev

Rev 391 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
263 dpurdie 1
########################################################################
2
# Copyright (C) 2008 ERG Limited, All rights reserved
227 dpurdie 3
#
263 dpurdie 4
# Module name   : create_dpkg.pl
5
# Module type   : JATS Utility
6
# Compiler(s)   : Perl
7
# Environment(s): JATS
227 dpurdie 8
#
263 dpurdie 9
# Description   : This script is used to create a dpkg_archive.
227 dpurdie 10
#
263 dpurdie 11
# Usage         : See POD
227 dpurdie 12
#
263 dpurdie 13
#......................................................................#
227 dpurdie 14
 
263 dpurdie 15
require 5.008_002;
227 dpurdie 16
 
17
# Include Standard Perl Functions
18
#
19
use strict;
263 dpurdie 20
use warnings;
227 dpurdie 21
use Cwd;
22
use Getopt::Long;
23
use File::Basename;
24
use File::Find;
25
use File::Path;
26
use File::Copy;
27
use Pod::Usage;
263 dpurdie 28
use Digest::MD5;
227 dpurdie 29
 
30
use JatsError;
263 dpurdie 31
use JatsEnv;
227 dpurdie 32
use DescPkg;
33
use FileUtils;
34
 
363 dpurdie 35
#
36
#   Under Windows we need the Win32::FileSecurity module
37
#   It only exists under windows
38
#
39
my $Win32 = eval "require Win32::FileSecurity";
40
 
227 dpurdie 41
# define Global variables
42
#
263 dpurdie 43
my $VERSION = "2.4.1";
227 dpurdie 44
my $PROGNAME = "create_dpkg.pl";
45
 
279 dpurdie 46
# Globals imported from environment
47
#
48
our $GBE_MACHTYPE;
49
our $GBE_HOSTNAME;
50
our $USER;
51
our $GBE_ABT;
227 dpurdie 52
 
279 dpurdie 53
# Global variables
54
#
227 dpurdie 55
my $DPKG_NAME     = "";
56
my $DESC_NAME     = "";
57
my $DPKG_VERSION  = "";
58
my $DESCPKG_FILE  = "";
59
my $DESCPKG_TYPE  = "";
60
my $CWD_DIR       = cwd;
61
my $SRC_ROOT;
62
my $DPKG_DIR;
63
my $DPKG_ROOT;
4001 dpurdie 64
my $PKG_BASE;
261 dpurdie 65
my $e_repository = "";
263 dpurdie 66
my $bad_merge_count = 0;
227 dpurdie 67
 
68
#
69
#   Option variables
70
#
71
my $opt_help = 0;
72
my $opt_manual = 0;
73
my $opt_verbose = 0;
74
my $opt_quiet = 0;
75
my $opt_override = 0;
76
my $opt_merge = 0;
77
my $opt_archive;
78
my $opt_generic;
79
my $opt_pname;
80
my $opt_pversion;
81
my $opt_test;
263 dpurdie 82
my $opt_md5 = 1;
227 dpurdie 83
 
84
 
85
#
86
#   Structure to translate -archive=xxx option to archive variable
87
#   These are the various dpkg_archives known to JATS
88
#
89
my %Archive2Var =( 'main'       =>  'GBE_DPKG',
90
                   'store'      =>  'GBE_DPKG_STORE',
91
                   'cache'      =>  'GBE_DPKG_CACHE',
92
                   'local'      =>  'GBE_DPKG_LOCAL',
93
                   'sandbox'    =>  'GBE_DPKG_SBOX',
94
                   'deploy'     =>  'GBE_DPLY',
95
                   );
96
 
97
#------------------------------------------------------------------------------
98
#------------------------------------------------------------------------------
99
# Subroutines
100
#------------------------------------------------------------------------------
101
#------------------------------------------------------------------------------
102
 
103
#------------------------------------------------------------------------------
104
sub LogFileOp
105
#
106
# Description:
107
#       This sub-routine is used to generate a consistent informational log
108
#------------------------------------------------------------------------------
109
{
110
    my ($opr, $file) = @_;
111
    $file =~ s/$DPKG_ROOT/DPKG/;
112
 
113
    Information (sprintf( "%-15s [%s]", $opr, $file));
114
}
115
 
116
#------------------------------------------------------------------------------
117
sub Init
118
#
119
# Description:
120
#     This function is used to process any command line arguements
121
#     and print the start banner.
122
#
123
#------------------------------------------------------------------------------
124
{
125
    # Process any command line arguements...
126
    my $result = GetOptions (
263 dpurdie 127
                "help:+"        => \$opt_help,              # flag, multiple use allowed
128
                "manual:3"      => \$opt_help,              # flag
129
                "verbose:+"     => \$opt_verbose,           # flag, multiple use allowed
227 dpurdie 130
                "override!"     => \$opt_override,          # [no]flag
131
                "merge|m!"      => \$opt_merge,             # [no]flag.
132
                "archive=s"     => \$opt_archive,           # string
133
                "quiet+"        => \$opt_quiet,             # Flag
134
                "generic!"      => \$opt_generic,           # [no]Flag
135
                "pname=s"       => \$opt_pname,             # string
136
                "pversion=s"    => \$opt_pversion,          # string
137
                "test!"         => \$opt_test,              # [no]flag
263 dpurdie 138
                "md5!"          => \$opt_md5,               # [no]flag
227 dpurdie 139
                );
140
 
141
 
142
    #
143
    #   Process help and manual options
144
    #
145
    pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);
146
    pod2usage(-verbose => 1)  if ($opt_help == 2 );
263 dpurdie 147
    pod2usage(-verbose => 2)  if ($opt_help > 2);
227 dpurdie 148
 
149
    #
150
    #   Init the error and message subsystem
151
    #
152
    ErrorConfig( 'name'    =>'CREATE_DPKG',
153
                 'verbose' => $opt_verbose,
154
                 'quiet'   => $opt_quiet );
155
 
156
    if ($opt_verbose)
157
    {
158
       Verbose ("Program: $PROGNAME");
159
       Verbose ("Version: $VERSION");
160
    }
161
 
162
    #
263 dpurdie 163
    #   Needed EnvVars
164
    #
165
    EnvImport ('GBE_MACHTYPE');
279 dpurdie 166
    EnvImport ('GBE_HOSTNAME');
167
    EnvImport ('USER' );
168
    EnvImportOptional ('GBE_ABT', "");
263 dpurdie 169
 
4001 dpurdie 170
    #
171
    #   Determine the target archive
172
    #   The default archive is GBE_DPKG, but this may be changed
173
    #
174
    $opt_archive = 'main' unless ( $opt_archive );
175
    my $archive_tag = $Archive2Var{$opt_archive};
176
    Error("Unknown archive specified: $opt_archive")
177
        unless ( $archive_tag );
178
    $DPKG_ROOT = $ENV{$archive_tag} || '';
179
    Verbose ("Archive Variable: $archive_tag" );
180
    Verbose2 ("Archive Path: $DPKG_ROOT" );
279 dpurdie 181
 
263 dpurdie 182
    #
4001 dpurdie 183
    #   Detect NoBuild marker
184
    #   This will bypass most of the operation of this package
185
    #
186
    if ( -f 'noBuild.gbe' )
187
    {
188
        Verbose ("No Build Marker file found");
189
        Error("Use of noBuild marker should only be done by a build daemon")
190
            unless ( $GBE_ABT );
191
 
192
        $SRC_ROOT = '';
193
        $DPKG_NAME = 'pkg';
194
        $DESCPKG_FILE = 'descpkg';
195
        $PKG_BASE =$CWD_DIR;
196
        return;
197
    }
198
 
199
    #
227 dpurdie 200
    #   Check for a "pkg" directory
201
    #   This may be in:
202
    #       1) The deploy directory (DEPLOY) build/deploy/descpkg
203
    #       2) The build directory (ANT)     build/pkg/descpkg
204
    #       3) The current directory (JATS)  pkg/xxxx/descpkg
205
    #
4001 dpurdie 206
    $PKG_BASE = "$CWD_DIR/build/deploy";
227 dpurdie 207
    Verbose2 ("Looking for descpkg: $PKG_BASE");
208
    if ( -f "$PKG_BASE/descpkg" )
209
    {
210
        #
211
        #   This is a deployment package.
212
        #   Force the use of the GBE_DPLY
213
        #
214
        $opt_archive = 'deploy' unless ( $opt_archive );
215
    }
216
    else
217
    {
218
        $PKG_BASE = "$CWD_DIR/build/pkg";
219
        Verbose ("Looking for descpkg: $PKG_BASE");
220
        if ( ! -f  "$PKG_BASE/descpkg" )
221
        {
222
            $PKG_BASE = "$CWD_DIR/pkg";
223
            Verbose ("Looking for descpkg: $PKG_BASE");
224
            Error("Failed to find a package to transfer. Looked in:",
225
                  "./build/deploy",
226
                  "./build/pkg",
227
                  "./pkg"
228
                  )
229
                unless( -d $PKG_BASE );
230
        }
231
    }
232
    Verbose("Package directory: $PKG_BASE");
233
 
234
    Error("Repository location not specified: $archive_tag")
235
        unless $DPKG_ROOT;
236
 
237
    Error("Failed to find Repository: $DPKG_ROOT")
238
        unless ( -d $DPKG_ROOT );
239
 
240
    $e_repository = ("      *Non Standard archive")
241
        unless ( $opt_archive eq 'main' );
242
 
243
 
244
    #   Locate the package
245
    #   Packages are located by looking for a file called descpkg within the
246
    #   main package directory.
247
    #
248
    #   This installation process only handles one such file
249
    #
250
    File::Find::find( \&pkgFind, $PKG_BASE);
4001 dpurdie 251
}
227 dpurdie 252
 
4001 dpurdie 253
#-------------------------------------------------------------------------------
254
# Function        : CheckDescPkg
255
#
256
# Description     : Check the descpkg file
257
#
258
# Inputs          : Globals
259
#
260
# Returns         : Will not return on error
261
#
262
sub CheckDescPkg
263
{
227 dpurdie 264
    # Get the dpkg_archive version number we are  going to create.
265
    #
266
    Error("Descpkg file not found in package directory: $PKG_BASE")
267
        unless ( -f "$DESCPKG_FILE" );
268
 
269
    #
270
    #   Read in the package description and validate essential fields
271
    #
272
    GetDpkgArchiveVersion($DESCPKG_FILE);
273
    unless ( "$DPKG_VERSION" )
274
    {
275
        Error ("Incorrect descpkg content detected.",
276
               "Check JATS build.pl config.");
277
    }
278
 
279
    #
280
    #   Need to support two forms of pkg subdirectory
281
    #       1) packages are in a named subdir within 'pkg'
282
    #       2) package is within 'pkg' or 'deploy'
283
    #
284
    if ( $DPKG_NAME eq 'pkg' || $DPKG_NAME eq 'deploy' )
285
    {
286
        $DPKG_NAME = $DESC_NAME;
287
        unless ( $DESC_NAME )
288
        {
289
            Error ("Cannot determine package name",
290
                   "The packages 'descpkg' file is bad or missing");
291
        }
292
    }
293
    elsif ( $DESC_NAME ne $DPKG_NAME )
294
    {
295
        Error ("Package name MUST match package description",
296
               "Check build.pl and package.pl",
297
               "Package name: $DPKG_NAME",
298
               "Description : $DESC_NAME" );
299
    }
300
 
301
    #
302
    # lets just check to see if we have a version number before
303
    # we proceed.
304
    #
305
    unless ( $DPKG_VERSION )
306
    {
307
        Error("Cannot determine dpkg_archive version number.",
308
              "Check JATS build config.");
309
    }
310
 
311
    #
312
    #   Sanity test package name and version, if provided
313
    #
314
    if ( $opt_pname )
315
    {
316
        ReportError ("Package Name does not match expected name",
317
                     "Expected: '$opt_pname'",
318
                     "Descpkg : '$DPKG_NAME'") unless ( $DPKG_NAME eq $opt_pname );
319
    }
320
    if ( $opt_pversion )
321
    {
322
        ReportError ("Package Version does not match expected version",
323
                     "Expected: '$opt_pversion'",
324
                     "Descpkg : '$DPKG_VERSION'") unless ( $DPKG_VERSION eq $opt_pversion );
325
    }
326
    ErrorDoExit();
4001 dpurdie 327
}
227 dpurdie 328
 
4001 dpurdie 329
#-------------------------------------------------------------------------------
330
# Function        : ShowInfo
331
#
332
# Description     : Show info to the user
333
#
334
# Inputs          : 
335
#
336
# Returns         : 
337
#
338
sub ShowInfo
339
{
227 dpurdie 340
    #
341
    #   Set up the target directory path and name
342
    #   It will be created later
343
    #
344
    $DPKG_DIR = "$DPKG_ROOT/$DPKG_NAME/$DPKG_VERSION";
4001 dpurdie 345
 
227 dpurdie 346
    #
347
    #   Information for the user
348
    #
349
    Information ("---------------------------------------------------------------");
350
    Information ("Dpkg archive creation tool...");
351
    Information ("Version: $VERSION");
352
    Information ("");
353
    Information ("Information:");
354
    Information ("Working dir   = [$CWD_DIR]");
355
    Information ("Package Root  = [$SRC_ROOT]");
356
    Information ("Repository    = [$DPKG_ROOT]$e_repository");
357
    Information ("Target dir    = [$DPKG_DIR]");
358
    Information1("DPKG_NAME     = [$DPKG_NAME]");
359
    Information1("DPKG_VERSION  = [$DPKG_VERSION]");
360
    Information1("GBE_MACHTYPE  = [$GBE_MACHTYPE]");
279 dpurdie 361
    Information1("GBE_HOSTNAME  = [$GBE_HOSTNAME]");
362
    Information1("GBE_ABT       = [$GBE_ABT]");
363
    Information1("USER          = [$USER]");
227 dpurdie 364
    Information ("")                                if ( $opt_merge || $opt_override );
365
    Information ("Opt:Override  = Enabled")         if ( $opt_override );
366
    Information ("Opt:Merge     = Enabled")         if ( $opt_merge );
367
    Information ("Opt:TestMode  = Enabled. No Package Transferred") if ( $opt_test );
369 dpurdie 368
    Warning     ("Sandbox Build = Yes") if ($ENV{GBE_DPKG_SBOX}) ;
227 dpurdie 369
    Information ("---------------------------------------------------------------");
370
 
369 dpurdie 371
    #
372
    #   If the environment variable GBE_DPKG_SBOX is defined then the package
373
    #   is being built within a development sandbox. In such a sandbox the
374
    #   version numbers of the packages are ignored. Publishing a package
375
    #   fromm such an environment is certainly not reproducible - so don't allow
376
    #   it to happen
377
    #
378
    #   Allow versions of 99.99.99 as these are known to be test versions
379
    #
380
    unless ( $opt_archive eq 'local' || $opt_archive eq 'sandbox' )
381
    {
382
        if ( $ENV{GBE_DPKG_SBOX} )
383
        {
384
            unless ( $DPKG_VERSION =~ /^99.99.99/ )
385
            {
386
                Error("Cannot not publish a package that has been generated",
387
                   "within a Sandbox as the version of dependent packages",
388
                   "is not guaranteed.",
389
                   "Only version 99.99.99 is allowed");
390
            }
391
        }
392
    }
4001 dpurdie 393
}
369 dpurdie 394
 
395
 
227 dpurdie 396
#------------------------------------------------------------------------------
397
sub pkgFind
398
#
399
# Description:
235 dpurdie 400
#     This subroutine is used to locate the FIRST descpkg file in
227 dpurdie 401
#     the local pkg dir.
402
#
403
#------------------------------------------------------------------------------
404
{
405
    my($item)= "$File::Find::name";
406
    my($file)= File::Basename::basename($item);
407
 
408
    # we get the absolute path from the find, but we only require
409
    # a relative path from the starting dir.
410
    # so our start dir.
411
 
412
    # we need to determine which file we are dealing with
235 dpurdie 413
    if ( ! -d $item && $file =~ /^descpkg$/ )
227 dpurdie 414
    {
235 dpurdie 415
        #
416
        #   Only grab the first one
417
        #
418
        if ( $DESCPKG_FILE )
419
        {
420
            Warning ("Package contains multiple descpkg files");
421
            return;
422
        }
423
 
227 dpurdie 424
        $DESCPKG_FILE = $item;
425
        my($dir)= File::Basename::dirname($item);
426
        $DPKG_NAME = File::Basename::basename($dir);
427
        $SRC_ROOT = $dir;
428
    }
429
}
430
 
431
 
432
#------------------------------------------------------------------------------
433
sub GetDpkgArchiveVersion
434
#
435
# Description:
436
#     This subroutine is used to determine the version of the dpkg_archive.
437
#     We assume that the version number is in the descpkg file.
438
#
439
#     Need to allow for two forms of descpkg. Some one decided that a Java
440
#     Manifest would be a good descpkg file - a long time after the rest of the
441
#     world had been using an existing file format.
442
#
443
#     Lines are tagged
444
#
445
#     Once the version number is determined we set the
446
#     global DPKG_VERSION variable.
447
#
448
#------------------------------------------------------------------------------
449
{
450
    my ($path) = @_;
451
    my $line;
452
    my $type;
453
 
454
    #
455
    #   Use a common routine to parse the package descriptor
456
    #   There are several forms that may need to be processed
457
    #
458
    my $pkg_data = ReadDescpkg( $path );
459
    Error("Failed to open file [$path].") unless $pkg_data;
460
 
461
    $DESC_NAME    = $pkg_data->{'NAME'};
462
    $DPKG_VERSION = $pkg_data->{'VERSION_FULL'};
463
}
464
 
465
#-------------------------------------------------------------------------------
466
# Function        : TransferDescpkg
467
#
468
# Description     : Copy and process the descpkg file to the target
469
#
470
# Inputs          :
471
#
472
# Returns         :
473
#
474
sub TransferDescpkg
475
{
476
    my $result = CopyDescpkg( @_ );
477
    Error("Transfer descpkg: $result") if ( $result );
478
}
479
 
480
#------------------------------------------------------------------------------
481
sub CreateDpkgArchive
482
#
483
# Description:
484
#     This subroutine is used to create the dpkg_archive in the $DPKG_ROOT
485
#     location 
486
#
487
#     We use the global DPKG_DIR, DPKG_NAME, and DPKG_VERSION
488
#     to create the required directory structure.
489
#
490
#     If the dpkg_archive is new (ie not a new version) it is assumed the user
491
#     has access to create the top level dir for the new dpkg_archive.
492
#
493
#     The new dpkg_archive is created with the permission of the user 
494
#     executing this script.
495
#
496
#     If an error ocurs during the dpkg_archive creation the script
497
#     will terminate.
498
#
499
#------------------------------------------------------------------------------
500
{
263 dpurdie 501
    #
227 dpurdie 502
    # first we need to ensure we have the top level directory
503
    #
504
    if ( -d $DPKG_DIR )
505
    {
506
        Warning("Detected previous dpkg_archive [$DPKG_DIR]");
507
        unless ( $opt_override )
508
        {
509
            Error ("Package already exists") if ( $opt_quiet );
510
            if ( !GetYesNo("Do you wish to continue?") )
511
            {
512
                Error("Script terminated by user.");
513
            }
514
        }
263 dpurdie 515
 
516
        #
517
        #   Target exists
518
        #   Unless we are merging, we need to blow the entire tree away
519
        #
520
        unless ( $opt_merge )
521
        {
522
            LogFileOp("Remove Prev Pkg",$DPKG_DIR);
523
            rmtree($DPKG_DIR);
524
 
525
            #
526
            #   At this point the target directory 'should not' exist
527
            #   but it may. Some packges (like JATS) have Unix links within
528
            #   dpkg_archive filesystem. These cannot be deleted under windows
529
            #
530
            #   Not nice, but we live with it.
531
            #
532
            Warning ("Unable to delete previous instance of the package")
533
                if ( -d $DPKG_DIR );
534
        }
227 dpurdie 535
    }
536
    Information("");
537
 
538
    #
539
    #   Create the top level directory
540
    #
541
    mkpath($DPKG_DIR, 0, 0775);
542
 
543
    #
4001 dpurdie 544
    #   Transfer source directory, unless this is a noBuild
545
    #
546
    if ( $SRC_ROOT ne '' )
227 dpurdie 547
    {
4001 dpurdie 548
        # Process the files
549
        #
550
        if ( -d $SRC_ROOT )
551
        {
552
            File::Find::find( \&pkgFind2, $SRC_ROOT );
263 dpurdie 553
 
4001 dpurdie 554
            if ( $bad_merge_count )
555
            {
556
                my $msg = "Merged files that differ: $bad_merge_count";
557
                $opt_md5 ? Error($msg) : Warning($msg);
558
            }
559
        }
560
        else
263 dpurdie 561
        {
4001 dpurdie 562
            Error("Failed to find dir [$SRC_ROOT]",
563
                  "Check JATS config.");
263 dpurdie 564
        }
227 dpurdie 565
    }
566
 
567
    #
568
    #   Transfer of data is complete
345 dpurdie 569
    #       Deprecated format: ($touchfile0)
570
    #           Mark the archive with the build type to indicate which parts of
571
    #           a multi-machine build have been performed
572
    #       New format
573
    #           Mark the archive with the build machine to indicate which parts of
574
    #           a multi-machine build have been performed
227 dpurdie 575
    #
345 dpurdie 576
    my $touchfile = $opt_generic ? "$DPKG_DIR/built.generic" : "$DPKG_DIR/built.$GBE_HOSTNAME";
577
    my $touchfile0 = "$DPKG_DIR/built.$GBE_MACHTYPE";
279 dpurdie 578
 
227 dpurdie 579
    #
4001 dpurdie 580
    #   Create a string to be appended to the 'built' file
581
    #   Comma seperated list of (possibly) useful info
279 dpurdie 582
    #       Date-Time ( Local and GMT)
583
    #       machine type, machine name and the user
584
    #       GBE_ABT value
585
    #
586
    my $built_info = localtime() ."," . gmtime() . " GMT,$GBE_MACHTYPE,$GBE_HOSTNAME,$USER,$GBE_ABT";
227 dpurdie 587
    LogFileOp("Mark File",$touchfile);
279 dpurdie 588
    FileAppend ( $touchfile, $built_info );
227 dpurdie 589
 
345 dpurdie 590
    # Maintain the old format until the build daemon has been updated
227 dpurdie 591
    #
345 dpurdie 592
    LogFileOp("Mark File",$touchfile0);
593
    FileAppend ( $touchfile0, $built_info );
594
 
595
    #
227 dpurdie 596
    #   If there is a .lnk file in the archive then remove it now that the
597
    #   archive has been transferred. The .lnk files are created in 'local'
598
    #   archives in order to simplify multi-package builds
599
    #
600
    my $link_file = "$DPKG_ROOT/$DPKG_NAME/$DPKG_VERSION.lnk";
601
    if ( -f $link_file )
602
    {
603
        LogFileOp("Removing Link",$link_file);
604
        unlink $link_file;
605
    }
606
 
607
    return 1;
608
}
609
 
610
 
611
#------------------------------------------------------------------------------
612
sub pkgFind2
613
#
614
# Description:
615
#   This subroutine is used to locate all associated pkg files in
616
#   the local pkg dir.
617
#
618
#   This routine is called for each file and directory within the package
619
#   Some files and directories are treated in a special manner
620
#       - Top level directory is ignored
621
#
622
#
623
#
624
#------------------------------------------------------------------------------
625
{
626
    my $item = $File::Find::name;
627
    my $base = File::Basename::basename($item);
628
 
629
    #
630
    #   Calculate the target directory name
631
    #
632
    my $target = $item;
241 dpurdie 633
    $target = $DPKG_DIR . substr ( $item, length ($SRC_ROOT) );
227 dpurdie 634
 
635
    if ( -d $item )
636
    {
637
        #
638
        #   Ignore the top level directory
639
        #   It has already been created
640
        #
641
        return
642
            if ( $item eq $SRC_ROOT );
643
 
644
        #
645
        #   Directories are handled differently
646
        #       - Directories are created with nice permissions
263 dpurdie 647
        #       - If the directory already exists then it is being merged.
227 dpurdie 648
        #
649
        if ( ! -d "$target" )
650
        {
651
            LogFileOp("Creating Dir", $target);
652
            mkpath("$target", 0, 0775);
653
        }
654
    }
655
    else
656
    {
657
        #
658
        #   File copy
659
        #   If merging then do not overwrite an existing file
660
        #
661
        unless ( $opt_merge && -f $target )
662
        {
663
            if ( $item =~ m~/descpkg$~ )
664
            {
665
                LogFileOp("Rewrite File",$target);
666
                TransferDescpkg( "$item", $target );
363 dpurdie 667
                CORE::chmod oct("0664"), $target;
227 dpurdie 668
            }
669
            else
670
            {
671
                #
672
                #   Copy file to destination
673
                #   If the file is a link, then duplicate the link contents
674
                #   Use: Unix libraries are created as two files:
675
                #        lib.xxxx.so -> libxxxx.so.vv.vv.vv
676
                #
677
                if ( -l $item )
678
                {
679
                    LogFileOp("Copying Link", $target);
680
                    my $link = readlink $item;
681
                    Verbose( "Link: $item, $link");
682
                    symlink ($link, $target );
683
                    unless ( $link && -l $target )
684
                    {
685
                        Error("Failed to copy link [$item] to [$target]: $!");
686
                    }
687
                }
688
                elsif (File::Copy::copy($item, $target))
689
                {
690
                    LogFileOp("Copying File",$target);
363 dpurdie 691
                    #
692
                    #   Mark the file as executable by all
693
                    #   Under windows, this is tricky
694
                    #
695
                    if ( $Win32 )
696
                    {
697
                        my %hash;
698
                        $hash{Everyone} = Win32::FileSecurity::MakeMask( qw( FULL  ) );
699
                        Win32::FileSecurity::Set( $target, \%hash );
700
                    }
701
                    else
702
                    {
703
                        CORE::chmod oct("0775"), $target;
704
                    }
227 dpurdie 705
                }
706
                else
707
                {
708
                    Error("Failed to copy file [$item] to [$target]: $!");
709
                }
710
            }
711
        }
712
        else
713
        {
714
            #
715
            #   Merging packages
716
            #   Ensure that the descpkg file is "touched" so that caches
717
            #   that use this file as a timestamp can be updated
718
            #
719
            if ( $item =~ m~/descpkg$~ )
720
            {
721
                LogFileOp("Touch File",$target);
722
                TouchFile( $target ) && Error ( "Failed to touch: $target" );
723
            }
724
            else
725
            {
263 dpurdie 726
                #
727
                #   MD5 digest the files that are being merged
728
                #   Ignore version_*.h files as these are generated
729
                #   and may contain different dates and line endings
730
                #
267 dpurdie 731
                #   Don't put the files into 'binmode'
732
                #   Need to handle some level of Unix/DOS file endings
733
                #
734
                #
263 dpurdie 735
                my $msg = "Merge Skip File";
736
                unless ( $target =~ m~/version[^/]*\.h$~ )
737
                {
738
                    $msg = "Merge Test File";
739
                    #
740
                    #   Compare the two files with an MD5
741
                    #
742
                    local *FILE;
743
                    open(FILE, $target) or Error ("Can't open '$target': $!");
267 dpurdie 744
                    binmode FILE, ':crlf';
263 dpurdie 745
                    my $target_md5 = Digest::MD5->new->addfile(*FILE)->hexdigest;
746
                    close FILE;
747
 
748
                    open(FILE, $item) or Error ("Can't open '$item': $!");
267 dpurdie 749
                    binmode FILE, ':crlf';
263 dpurdie 750
                    my $source_md5 = Digest::MD5->new->addfile(*FILE)->hexdigest;
751
                    close FILE;
752
 
753
                    unless ( $source_md5 eq $target_md5 )
754
                    {
755
                        $msg = "DIFF: Merge Test File";
756
                        $bad_merge_count ++;
757
                    }
758
                }
759
                LogFileOp($msg,$target);
227 dpurdie 760
            }
761
        }
762
    }
763
}
764
 
765
 
766
# -------------------------------------------------------------------------
767
sub GetYesNo
768
#
769
# -------------------------------------------------------------------------
770
{
771
    my ($question) = @_;
772
    my ($u_tmp) = "";
773
    Question ("$question, (default: y) [y,n]: ");
774
 
775
    while ( <STDIN> )
776
    {
777
        $u_tmp = $_;
778
        chomp($u_tmp);
779
 
780
        return 1
781
            if ( "$u_tmp" eq "" );
782
 
783
        if( $u_tmp =~ /[yn]{1}/i )
784
        {
785
            return ( "$u_tmp" eq "y" );
786
        }
787
        else
788
        {
789
            Question("Please re-enter response? (default: y) [y,n]: ");
790
        }
791
    }
792
}
793
 
794
#-------------------------------------------------------------------------------
795
# Function        : TestDpkgArchive
796
#
797
# Description     : Test the structure of the source achive
798
#                   Ensure that it has some files
799
#                   Warn if files are present in the root directory
800
#
801
# Inputs          : None
802
#
803
# Returns         : Warnings
804
#
805
my $test_dir_count = 0;
806
my $test_file_count = 0;
807
my @test_root_file = ();
808
sub TestDpkgArchive
809
{
810
    $test_dir_count = 0;
811
    $test_file_count = 0;
812
    @test_root_file = ();
813
 
4001 dpurdie 814
    if ( $SRC_ROOT ne '' )
815
    {
816
        Error("Failed to find dir [$SRC_ROOT]",
817
              "Check JATS config.") unless ( -d $SRC_ROOT );
818
 
819
 
820
        #
821
        #   Scan the package counting files and folders
822
        #
823
        File::Find::find( \&pkgFind3, $SRC_ROOT );
824
    }
825
 
227 dpurdie 826
    Information ("Package contains:",
827
                 "Files: $test_file_count",
828
                 "Dirs: $test_dir_count",
829
                 );
830
    #
831
    #   There shouldn't be any files in the root directory
832
    #   other than the descpkg and incpkg.
833
    #
834
    Warning ("Unexpected files in package root:", @test_root_file)
835
        if ( @test_root_file  );
836
}
837
 
838
sub pkgFind3
839
{
840
 
841
    #
842
    #   Calculate the target directory name
843
    #
844
    my $target = $File::Find::dir;
263 dpurdie 845
    $target = substr ( $target, length ($SRC_ROOT) );
846
    $target =~ s~^.~~;
227 dpurdie 847
 
848
    if ( -d $_ ) {
849
        $test_dir_count++;
850
    } else {
851
        $test_file_count++;
852
        unless ( $target )
853
        {
241 dpurdie 854
            #
855
            #   Locate files in the package root directory that
856
            #   are not expected to be there.
857
            #
263 dpurdie 858
            unless ((  $_ eq 'descpkg' ) || ( $_ eq 'incpkg' ))
859
            {
860
                push @test_root_file, $_;
861
            }
227 dpurdie 862
        }
863
    }
864
}
865
 
866
# ---------------------------------------------------------
867
# ---------------------------------------------------------
868
# Main
869
# ---------------------------------------------------------
870
# ---------------------------------------------------------
871
 
872
 
873
# Initialise our world
874
#
875
Init();
4001 dpurdie 876
CheckDescPkg();
877
ShowInfo();
227 dpurdie 878
 
879
 
880
# Check with the user they want to proceed
881
#
882
unless ( $opt_test )
883
{
884
    Information("Creating dpkg_archive package:", $DPKG_DIR);
885
    unless( $opt_override || $opt_quiet )
886
    {
887
        if ( !GetYesNo( "Do you wish to continue?" ) )
888
        {
889
            Error ("Script terminated by user.");
890
        }
891
    }
892
 
893
    # Create the archive and copy the files
894
    #
895
    CreateDpkgArchive();
896
}
897
else
898
{
899
    TestDpkgArchive();
900
}
901
 
902
# Done
903
#
904
Information ("Done.");
905
exit 0;
906
 
907
 
908
#-------------------------------------------------------------------------------
909
#   Documentation
910
#
911
 
912
=pod
913
 
361 dpurdie 914
=for htmltoc    SYSUTIL::
915
 
227 dpurdie 916
=head1 NAME
917
 
918
create_dpkg - Create a dpkg_archive entry
919
 
920
=head1 SYNOPSIS
921
 
922
 jats create_dpkg [options]
923
 
924
 Options:
925
    -help              - Brief help message
926
    -help -help        - Detailed help message
927
    -man               - Full documentation
928
    -quiet             - Suppress progress messages, then warning messages
929
    -verbose           - Display additional progress messages
930
    -override          - Override any previous version of the package
263 dpurdie 931
    -[no]merge         - merge with existing version of the package
227 dpurdie 932
    -archive=name      - Specify archive (cache, local, main, store, sandbox, deploy)
933
    -pname=name        - Ensure package is named correctly
934
    -pversion=version  - Ensure package version is correct
935
    -generic           - Create a built.generic file
263 dpurdie 936
    -[no]test          - Test package. Do not transfer.
937
    -[no]md5           - Use MD5 comparison of merged files(enabled)
227 dpurdie 938
 
939
 
940
=head1 OPTIONS
941
 
942
=over 8
943
 
944
=item B<-help>
945
 
946
Print a brief help message and exits.
947
 
948
=item B<-help -help>
949
 
950
Print a detailed help message with an explanation for each option.
951
 
952
=item B<-man>
953
 
954
Prints the manual page and exits.
955
 
956
=item B<-quiet>
957
 
958
This option will suppress almost all of the progress messages, except for a single
959
copy message. It is intended to be used when the program is called from another
960
script.
961
 
962
=item B<-override>
963
 
964
If this option is enabled then any previous version of the target package will
965
be deleted, without any user intervention.
966
 
967
=item B<-merge>
968
 
969
If this option is enabled then the package will be merged with any existing
970
package, without any user intervention. This option is used by the auto build
971
tool to assemble multi-machine packages in dpkg_archive.
972
 
973
=item B<-archive=name>
974
 
975
This option specifies the destination archive to be used. The following names
976
are supported:
977
 
361 dpurdie 978
=over 8
979
 
980
=item cache
981
 
982
The location of the target archive will be taken from C<GBE_DPKG_CACHE>.
983
 
984
=item local
985
 
986
The location of the target archive will be taken from C<GBE_DPKG_LOCAL>.
987
 
988
=item main (default)
989
 
990
The location of the target archive will be taken from C<GBE_DPKG>. This is the
991
default target archive.
992
 
993
=item store
994
 
995
The location of the target archive will be taken from C<GBE_DPKG_STORE>.
996
 
997
=item sandbox
998
 
999
The location of the target archive will be taken from C<GBE_DPKG_SBOX>.
1000
 
1001
=item deploy
1002
 
1003
The location of the target archive will be taken from C<GBE_DPLY>. This is the
1004
default target archive is a deployment package is detected.
1005
 
1006
=back
1007
 
227 dpurdie 1008
=item B<-pname=name>
1009
 
1010
If this option is provided, the utility will ensure that the package is named
1011
correctly.
1012
 
1013
=item B<-pversion=version>
1014
 
1015
If this option is provided, the utility will ensure that the package version is
1016
that expected.
1017
 
1018
=item B<-test>
1019
 
1020
If this option is enabled the utility will perform initial sanity testing, but
1021
it will not perform the copy.
1022
 
263 dpurdie 1023
=item B<-[no]md5>
1024
 
1025
If package builds are being merged then a validity check is performed using
1026
an MD5 digest over the current and the existing file.
1027
 
1028
By default, it is an error for the user file to differ from the merged file.
1029
 
1030
This option disabled the error. The test is still done and the results are
1031
reported.
1032
 
227 dpurdie 1033
=item B<-generic>
1034
 
1035
This option will create a built.generic file, instead of one based on the machine
1036
that actually built the package. This is used by the AutoBuilder toolchain.
1037
 
1038
=back
1039
 
1040
=head1 DESCRIPTION
1041
 
1042
This utility program is used to transfer a package that has been built into
1043
dpkg_archive. The package is then available for general consumption.
1044
 
1045
=head2 PACKAGE LOCATION
1046
 
1047
The utility will locate a package by examining the following directores for
1048
the package description file(descpkg).
1049
 
1050
=over 8
1051
 
1052
=item ./build/deploy
1053
 
1054
This format is generated by the deployment builds. The default target archive
1055
will be taken from the environment variable GBE_DPLY.
1056
 
1057
=item ./pkg
1058
 
1059
This format is generated by JATS builds.
1060
 
1061
=item ./build/pkg
1062
 
1063
This format is generated by ANT builds.
1064
 
1065
=back
1066
 
1067
The program should be run in the same directory as the build control files as
1068
the package subdirectory will be created in that directory.
1069
 
1070
=head1 EXAMPLE
1071
 
1072
=head2 jats create_dpkg
1073
 
1074
This will locate a generated package and install it into the dpkg_archive repository.
1075
 
1076
=cut
1077