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