Subversion Repositories DevTools

Rev

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