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