Subversion Repositories DevTools

Rev

Rev 5783 | Rev 5862 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
227 dpurdie 1
########################################################################
5709 dpurdie 2
# Copyright (c) VIX TECHNOLOGY (AUST) LTD
227 dpurdie 3
#
4
# Module name   : cache_dpkg
5744 dpurdie 5
# Module type   : JATS Utility
6
# Compiler(s)   : Perl
227 dpurdie 7
# Environment(s): jats
8
#
9
# Description:
5743 dpurdie 10
#       Maintain a local cache of dpkg_archive
227 dpurdie 11
#
12
# Notes:
335 dpurdie 13
#       Stopped using the JATS "cp.exe" utility as there was a weird problem under
227 dpurdie 14
#       windows. The package orahops-ssw-install/1.0.1000.ssw could not be installed
335 dpurdie 15
#       correctly. It appears that the 'cp' could not process the subdir pair
227 dpurdie 16
#       "DBMGR/DBMGR". Change the name it was OK.
17
#
18
#       Solution: Avoid system functions
19
#
20
#......................................................................#
21
 
22
use strict;
23
use warnings;
24
use JatsError;
25
use FileUtils;
26
use File::Find;
27
use File::Path;
28
use File::Copy;
29
 
30
use Getopt::Long;
31
use Pod::Usage;                             # required for help support
32
 
5743 dpurdie 33
my $VERSION = "1.5.0";
227 dpurdie 34
 
35
 
36
#
37
#   Options
38
#
39
my $opt_debug   = $ENV{'GBE_DEBUG'};        # Allow global debug
40
my $opt_verbose = $ENV{'GBE_VERBOSE'};      # Allow global verbose
41
my $opt_help = 0;
42
my $opt_clear;
43
my $opt_flush;
44
my $opt_refresh;
45
my $opt_refresh_all;
46
my $opt_list;
47
my $opt_list_short;
48
my $opt_export;
49
my $opt_quiet;
50
my $opt_update_all;
51
my $opt_age;
361 dpurdie 52
my $opt_test;
5744 dpurdie 53
my $opt_wait = 0;
5783 dpurdie 54
my $opt_cache = 1;
227 dpurdie 55
 
56
#
57
#   Global Variables
58
#
4688 dpurdie 59
my $GBE_DPKG            = $ENV{'GBE_DPKG'};                     # The Master repository
60
my $GBE_DPKG_CACHE      = $ENV{'GBE_DPKG_CACHE'} || "";         # Caches
61
my $GBE_DPKG_LOCAL      = $ENV{'GBE_DPKG_LOCAL'} || "";         # Local scratch
62
my $GBE_DPKG_STORE      = $ENV{'GBE_DPKG_STORE'} || "";         # Global Store
63
my $GBE_DPKG_REPLICA    = $ENV{'GBE_DPKG_REPLICA'} || "";       # Site Local Replica
64
my $GBE_BIN             = $ENV{'GBE_BIN'};
227 dpurdie 65
 
4688 dpurdie 66
my $istore;
227 dpurdie 67
my $gstore;
68
my $archive;
69
my $cache;
70
my $parchive;
71
my $local = '';
72
my $local_pkg;
73
my @package_list;
74
my @refresh_list;
5818 dpurdie 75
 
227 dpurdie 76
#
77
#   Globals for recursive copy
78
#
79
my $copyFind_dst;
80
my $copyFind_src;
81
my $copyFind_src_len;
5818 dpurdie 82
my $copyFind_touch;
83
my $copyFind_time;;
227 dpurdie 84
 
85
#
86
#   Globals for error recovery
87
#
88
my  $remove_on_error;
5818 dpurdie 89
my  $cacheMarker;
227 dpurdie 90
 
91
#-------------------------------------------------------------------------------
92
# Function        : Mainline Entry Point
93
#
94
# Description     :
95
#
96
# Inputs          :
97
#
98
my $result = GetOptions (
337 dpurdie 99
                "help|h:+"                  => \$opt_help,
100
                "manual:3"                  => \$opt_help,
101
                "verbose:+"                 => \$opt_verbose,           # flag, multiple use allowed
102
                "debug:+"                   => \$opt_debug,             # flag, multiple use allowed
227 dpurdie 103
                "flush"                     => \$opt_flush,             # flag
104
                "clear"                     => \$opt_clear,             # flag
5744 dpurdie 105
                "wait!"                     => \$opt_wait,              # [no]flag
5783 dpurdie 106
                "cache!"                    => \$opt_cache,             # [no]flag
5744 dpurdie 107
                "refresh!"                  => \$opt_refresh,           # [no]flag
227 dpurdie 108
                "refresh_all|refresh-all"   => \$opt_refresh_all,       # flag
109
                "update_all|update-all"     => \$opt_update_all,        # flag
110
                "list"                      => \$opt_list,              # flag
111
                "dir"                       => \$opt_list_short,        # flag
112
                "export"                    => \$opt_export,            # flag
113
                "quiet"                     => \$opt_quiet,             # flag
114
                "age=i"                     => \$opt_age,               # integer
361 dpurdie 115
                "test"                      => \$opt_test,              # flag
227 dpurdie 116
                );
117
 
118
                #
119
                #   UPDATE THE DOCUMENTATION AT THE END OF THIS FILE !!!
120
                #
121
 
122
#
123
#   Process help and manual options
124
#
125
pod2usage(-verbose => 0, -message => "Version: $VERSION")  if ($opt_help == 1  || ! $result);
126
pod2usage(-verbose => 1)  if ($opt_help == 2 );
337 dpurdie 127
pod2usage(-verbose => 2)  if ($opt_help > 2);
227 dpurdie 128
 
129
#
130
#   Configure the error reporting process now that we have the user options
131
#
132
ErrorConfig( 'name'    =>'CACHE',
133
             'verbose' => $opt_verbose,
134
             'debug'   => $opt_debug );
135
 
136
#
137
#   Validate user options
138
#
139
Error( "GBE_BIN not defined in the environment" ) unless ( defined($GBE_BIN) );
140
Error( "GBE_DPKG not defined in the environment" ) unless ( defined($GBE_DPKG) );
141
 
5744 dpurdie 142
$opt_refresh = 1
143
    if ( $opt_refresh_all );
144
 
227 dpurdie 145
#
5744 dpurdie 146
#   Locate the various package stores
147
#   Search order for package should be:
148
#       DPKG_SANDBOX (Not cached)
149
#       DPKG_LOCAL   (To be deprecated)
150
#       DPKG_CACHE
151
#       DPKG_REPLICA
152
#       DPKG         (Writable to build system)
153
#       DPKG_STORE
227 dpurdie 154
#
5744 dpurdie 155
$local = $GBE_DPKG_LOCAL;
156
$cache = $GBE_DPKG_CACHE;
157
$istore = $GBE_DPKG_REPLICA;
158
$archive = $GBE_DPKG;
159
$gstore = $GBE_DPKG_STORE;
160
 
161
Error ("dpkg_archive cache is the main archive")    if ( $cache eq $archive );
162
Error ("dpkg_archive replica is the main archive")  if ( $istore && $istore eq $archive );
163
Error ("main archive is local archive" )            if ( $local && $local eq $archive );
164
Warning  ("dpkg_archive_cache is local_archive" )   if ( $cache && $local && $local eq $cache );
165
 
166
#
167
#   Perform package/version replication wait
168
#   
169
#   Do not need a cache for this to be performed as the operation is used on build servers
170
#   that do not have a cache (most Unix build machines)
171
#   
172
#   Cannot wait if we don't have a REPLICA
173
#   
174
if ($opt_wait && $istore)
227 dpurdie 175
{
5744 dpurdie 176
    Verbose("Wait for package replication");
177
    #
178
    #   Scan the argument list
179
    #   Only wait for package/version. Cannot wait on an entire package
180
    #
181
    foreach (@ARGV)
182
    {
183
        unless (m~.+/.+~)
184
        {
185
            Verbose("Wait Skip $_");
186
            next;
187
        }
227 dpurdie 188
 
5744 dpurdie 189
        if (-d "$istore/$_")
190
        {
191
            Verbose("Wait not required. Version in replica: $_");
192
            next;
193
        }
227 dpurdie 194
 
5744 dpurdie 195
        unless (-d "$archive/$_")
196
        {
197
            Verbose("Wait not required. Version not in store: $_");
198
            next;
199
        }
227 dpurdie 200
 
5744 dpurdie 201
        #
202
        #   Wait for the package to be replicated
203
        #       Wait up to 10 minutes
204
        #       Or the package to appear in the replica
205
        #       Or the package to disappear from the main store
206
        #
207
        Verbose("Waiting for replication of: $_");
208
        my $waitStart = time();
209
        while (1)
210
        {
211
            sleep(30);
212
            my $delta = time() - $waitStart;
213
            if (-d "$istore/$_")
214
            {
215
                Message("PkgReplication. Package replicated ($delta): $_");
216
                last;
217
            }
218
            unless (-d "$archive/$_")
219
            {
220
                Message("PkgReplication. Package deleted from main archive: $_");
221
                last;
222
            }
223
            #
224
            #   Done wait forever
225
            #   If the package has not been replicate we will just have to copy it the slow way
226
            #   
227
            if ( $delta >= 600)
228
            {
229
                Message("PkgReplication. Package not replicated: $_");
230
                last;
231
            }
232
        }
233
    }
234
}
235
 
227 dpurdie 236
#
5783 dpurdie 237
#   Allow replication update without also caching the package
238
#       This is used to prevent ALL replicated packages beinng cached.
239
#       Packages do not need to be cached if they are not used by a build on the current machine
240
#       This will prevent the cache from filling up with unused packages.
241
#
242
unless ($opt_cache)
243
{
244
    Message("Packages not cached");
245
    exit 0;
246
}
247
 
248
#
5744 dpurdie 249
#   No cache - nothing to do
250
#   Generate a status message and exit
227 dpurdie 251
#
5744 dpurdie 252
unless ( $cache )
227 dpurdie 253
{
5744 dpurdie 254
    Warning ( "GBE_DPKG_CACHE not defined in the environment" );
255
    exit 0;
227 dpurdie 256
}
257
 
258
#
259
#   Export the list of cache entries
260
#
261
if ( $opt_export or $opt_refresh_all or $opt_list_short or $opt_update_all )
262
{
263
    opendir (DIR, $cache) || die "Cannot open $cache\n";
264
    my @dir_list = readdir(DIR);
265
    closedir DIR;
266
 
267
    for my $fn ( @dir_list)
268
    {
269
        my $count = 0;
270
        next if ( $fn =~ m/^\./ );
271
        next unless ( -d "$cache/$fn" );
272
 
273
        opendir( DIR, "$cache/$fn" ) || die "Cannot open $cache/$fn\n";
274
        while ( my $fn1 = readdir(DIR) )
275
        {
276
            next if ( $fn1 =~ m/^\./ );
277
            push @package_list, "$fn/$fn1";
278
        }
279
        closedir DIR;
280
    }
281
 
282
    if ( $opt_refresh_all or $opt_update_all )
283
    {
284
        @refresh_list = @package_list
285
    }
286
 
287
    #
288
    #   Simply export a list of packages in the cache
289
    #   Used by other programs
290
    #
291
    if ( $opt_export )
292
    {
293
        print join ' ', @package_list;
294
        exit 0;
295
    }
296
}
297
 
298
#
299
#   Display cache information
300
#   This is done AFTER the export - since the export command does not
301
#   need this header.
302
if ( $opt_verbose || $#ARGV < 0 )
303
{
304
    print  "dpkg_store        : $gstore\n" if ($gstore);
305
    print  "dpkg_archive      : $archive\n";
4688 dpurdie 306
    print  "dpkg_archive image: $istore\n";
227 dpurdie 307
    print  "dpkg_archive cache: $cache\n";
308
    print  "dpkg_archive local: $local\n";
309
    Verbose ("args:               @ARGV");
310
}
311
 
312
#
313
#   List the contents of the cache
314
#
315
if ( $opt_list_short )
316
{
317
    print join "\n", @package_list;
318
}
319
 
320
if ( $opt_list )
321
{
322
    #
323
    #   Process user commands
324
    #   List: A nice pretty display of the cache
325
    #
326
    opendir (DIR, $cache) || die "Cannot open $cache\n";
327
    my @dir_list = readdir(DIR);
328
    closedir DIR;
329
 
330
    #
331
    #   Determine max length of a name so that the display is nicely aligned
332
    #
333
    my $nl = 10;
334
    for my $fn ( @dir_list)
335
    {
336
        my $ns = length($fn);
337
        $nl = $ns if ( $ns > $nl )
338
    }
339
 
340
    #
341
    #   Display information by package
342
    #   A nicely formatted list with line wrapping
343
    #
344
    for my $fn ( @dir_list)
345
    {
346
        my $count = 0;
347
        next if ( $fn =~ m/^\./ );
348
        next unless ( -d "$cache/$fn" );
349
 
350
        opendir( DIR, "$cache/$fn" ) || die "Cannot open $cache/$fn\n";
351
        printf "%-*s :", $nl, $fn;
352
        while ( my $fn1 = readdir(DIR) )
353
        {
354
            next if ( $fn1 =~ m/^\./ );
355
            if ( $count++ >= 4 )
356
            {
357
                $count = 1;
358
                printf "\n%*s  ", $nl, "";
359
            }
360
            printf " %14.14s", $fn1;
361
        }
362
        closedir DIR;
363
        print "\n";
364
    }
365
}
366
 
367
#
368
#   Clear the cache
369
#
370
if ( $opt_clear )
371
{
372
    Warning   ( "Deleting the ENTIRE cache");
373
    rmtree( $cache, $opt_debug );
374
    mkpath( $cache, $opt_debug, 0777);
375
}
376
 
377
#
378
#   Perform cache aging
379
#
380
if ( $opt_age )
381
{
382
    Error ("Age parameter cannot be negative") if ( $opt_age < 0 );
383
    age_the_cache();
384
}
385
 
386
#
387
#   Process the command line arguments
388
#   These MUST be of the form
389
#       packagename
390
#       packagename/version
391
#
392
for (@ARGV, @refresh_list)
393
{
394
    $remove_on_error = undef;
5818 dpurdie 395
    $cacheMarker = undef;
396
 
227 dpurdie 397
    if ( $opt_flush )
398
    {
399
        unless ( -d "$cache/$_" )
400
        {
401
            Warning ("Package not in cache: $_")
402
                unless ( $opt_quiet );
403
        }
404
        else
405
        {
406
            rmtree( "$cache/$_", $opt_debug );
407
            print "Package removed: $_\n"
408
                unless ( $opt_quiet );
409
        }
410
    }
411
    else
412
    {
413
        #
414
        #   Speed up - for remote access
415
        #   If the package is found in the local archive and we aren't doing
416
        #   anything fancy then don't access the remote archive
417
        #
418
        my $local_pkg = ( -d "$local/$_" || -f "$local/$_.lnk" );
419
        if ( $local_pkg )
420
        {
421
            if ( !$opt_refresh )
422
            {
423
                print "Cache SkipLocal: $_ Local copy found\n";
424
 
425
                #
426
                # Delete the cache copy
427
                # The user is playing with local copy
428
                #
429
                if ( -d "$cache/$_" )
430
                {
431
                    print  "Cache SkipLocalDelete: $_ -> $cache\n";
432
                    Verbose ( "Remove: $_" );
433
                    rmtree( "$cache/$_", $opt_debug );
434
                    Verbose ( "Remove Complete: $_" );
435
                }
436
                next;
437
            }
438
        }
439
 
440
        #
441
        #   Locate package.
4688 dpurdie 442
        #   It may be in GBE_DPKG_REPLICA, GBE_DPKG or GBE_DPKG_STORE
227 dpurdie 443
        #
4688 dpurdie 444
        my $pkg_found;
445
        foreach my $store ( $istore, $archive, $gstore)
227 dpurdie 446
        {
4688 dpurdie 447
            $parchive = "$store/$_";
448
            if ( -d $parchive )
227 dpurdie 449
            {
4688 dpurdie 450
                $pkg_found = 1;
451
                last;
227 dpurdie 452
            }
453
        }
4688 dpurdie 454
 
455
        unless ($pkg_found )
456
        {
457
            Warning ("Package not in archive: $_")
458
                unless ( $opt_quiet );
459
            next;
460
        }
227 dpurdie 461
 
462
        ########################################################################
463
        #   We have a package to process
464
        #
5818 dpurdie 465
        my $dir_found = 0;
227 dpurdie 466
        my $force_update = 0;
467
        my $opr = "Update";
468
 
5818 dpurdie 469
        #
470
        #   Generate the 'name' of a marker file used to indicate that the version is being updated
471
        #   This is outside the target directory
472
        #   
473
        $cacheMarker = "$_/built.cache";
474
        $cacheMarker =~ tr~/~_~s;
475
        $cacheMarker =~ tr~_~_~s;
476
        $cacheMarker =  $cache . '/' . $cacheMarker;
477
        Verbose2("cacheMarker: $cacheMarker");
227 dpurdie 478
 
479
        #
480
        #   Setup error recovery
335 dpurdie 481
        #       1) Tag the directory to be deleted on error
227 dpurdie 482
        #
483
        $remove_on_error = "$cache/$_";
484
        ErrorConfig( 'on_exit' => \&error_recovery );
485
 
486
        #
335 dpurdie 487
        #   Not a forced refresh. Ensure that the cached copy is
227 dpurdie 488
        #   up to date. Examine descpkg
489
        #
5818 dpurdie 490
        $dir_found = waitForComplete($_,$cache);
491
        if ( $dir_found && !$opt_refresh )
227 dpurdie 492
        {
5818 dpurdie 493
            if ( FileIsNewer( "$parchive/descpkg", "$cache/$_/descpkg" ) )
227 dpurdie 494
            {
495
                $force_update = 1;
496
                $opr = "OutOfDate";
5818 dpurdie 497
                TouchFile ( $cacheMarker, "Marks the cache copy as incomplete");
227 dpurdie 498
                Verbose ("Cache out-of-date: $_");
499
            }
500
        }
501
 
502
        #
503
        #   If we need to refresh the cache copy - delete it first
504
        #
505
        if ( ($opt_refresh || $force_update) && $dir_found )
506
        {
507
            print  "Cache $opr: $_ -> $cache\n";
508
            Verbose ( "Remove: $_" );
509
            rmtree( "$cache/$_", $opt_debug );
510
            Verbose ( "Remove Complete: $_" );
229 dpurdie 511
 
512
            #
513
            #   Force transfer, but without the status message
514
            #
227 dpurdie 515
            $dir_found = 0;
229 dpurdie 516
            $opr = '';
227 dpurdie 517
        }
518
 
519
        #
5818 dpurdie 520
        #   If the directory exists, then we need to avoid a race condition
521
        #   where multiple instances are updating the same directory
522
        #       Need to aviod hanging forever if the primary updator does not
523
        #       complete the task
227 dpurdie 524
        #   If its not in the cache then copy it in
525
        #
5818 dpurdie 526
        $dir_found = waitForComplete($_,$cache);
227 dpurdie 527
        unless ( $dir_found )
528
        {
229 dpurdie 529
            print "Cache $opr: $_ -> $cache\n" if $opr;
227 dpurdie 530
            mkpath( "$cache/$_", $opt_debug, 0777);
5818 dpurdie 531
            TouchFile ( $cacheMarker, "Marks the cache copy as incomplete");
227 dpurdie 532
            Verbose ( "Copy in: $_" );
533
            $copyFind_dst = "$cache/$_";
534
            $copyFind_src = $parchive;
535
            $copyFind_src_len = length( $copyFind_src );
5818 dpurdie 536
            $copyFind_touch = $cacheMarker;
537
            $copyFind_time = 0;
227 dpurdie 538
            File::Find::find( \&copyFind, $parchive );
5818 dpurdie 539
            rmtree( $cacheMarker, $opt_debug );  # Works on files too !!
227 dpurdie 540
        }
541
        else
542
        {
543
            $opr = "Skip";
544
            print "Cache $opr: $_ -> $cache\n";
545
        }
546
    }
547
}
548
 
549
#-------------------------------------------------------------------------------
5818 dpurdie 550
# Function        : waitForComplete 
551
#
552
# Description     : Wait for a package-version to complete
553
#                   At the end of this operation the directory will be 
554
#                   completly transferred, or it will be deleted
555
#                   
556
#                   If the directory exists, then we need to avoid a race condition
557
#                   where multiple instances are updating the same directory
558
#                   Need to avoid hanging forever if the primary updator does not
559
#                   complete the task
560
#
561
# Inputs          : $dir    - Subdir directory to monitor
562
#                   $cache  - Target cache
563
#
564
# Returns         : 0   - $dir does not exist
565
#                   1   - $dir does exist 
566
#
567
sub waitForComplete
568
{
569
    my ($dir, $cache) = @_;
570
    my $opr;
571
    my $tgtDir = "$cache/$dir";
572
    #
573
    #   Directory not preset
574
    #       All done - dir does not exist 
575
    #
576
    if (! -d $tgtDir)
577
    {
578
        return 0;
579
    }
580
 
581
    # If the package is not being updated, then we are done if the 
582
    # package being updated marker is NOT present
583
    #     
584
    if (  -d $tgtDir && ! -f $cacheMarker)
585
    {
586
        return 98;
587
    }
588
 
589
    #
590
    #   The package-version is being updated by another instance
591
    #   Hang around waiting for the update to complete or terminate
592
    #       Wait 10 minutes max
593
    #
594
    my  $waitStart = time();
595
    $opr = "Wait";
596
    print "Cache $opr: $dir -> $cache\n";
597
    while (1)
598
    {
599
        if ( ! -d $tgtDir )
600
        {
601
            # Directory has gone away
602
            #   Must have been a bad transfer by another instance
603
            #   Start the processing again
604
            $opr = "Retry";
605
            print "Cache $opr: $dir -> $cache\n";
606
            return 0;
607
        }
608
 
609
        if ( ! -f $cacheMarker )
610
        {
611
            #
612
            #   Update must have completed - marker file has been removed
613
            #
614
            $opr = "Found";
615
            print "Cache $opr: $_ -> $cache\n";
616
            return 97;
617
        }
618
 
619
        #
620
        #   Determine the 'age' of the marker file
621
        #       It will be updated after each file in the package has been copied
622
        #       If it is too old, then we must assume that the other instance died
623
        #   Complication. Windows does not correctly report the 'modified' time of a file
624
        #                 It gets messed up by the file system. Can't use the modified info
625
        #                 from Perls stat function to determine the absolute modified time of the
626
        #                 file.
627
        #                 
628
        #       Solution: Create a temp file and determine the age relative to that file
629
        #       
630
 
631
        my $cacheMarkerTmp = $cacheMarker . ".tmp";
632
        TouchFile($cacheMarkerTmp, "Relative time stamp");
633
        my $now   = (stat ($cacheMarkerTmp))[9];
634
        my $mtime = (stat ($cacheMarker))[9];
635
        rmtree( $cacheMarkerTmp, $opt_debug );
636
 
637
        #
638
        #   If the marker file is older than 5 minutes then we can consider the package as
639
        #   a dud. The marker file will be updated be every file write into the cache. Its
640
        #   an indication of activity.
641
        #   
642
        #   Assume that no file is going to take more then 5 minutes to copy
643
        #   Lets see how this goes.
644
        #   
645
        my $age = $now - $mtime;
646
        if ( $age > 5 * 60)
647
        {
648
            #
649
            #   Update taking too long
650
            #       Delete the package-version
651
            #       Try again
652
            #
653
            $opr = "Remove Bad";
654
            print "Cache $opr: $_ -> $cache\n";
655
            rmtree( "$cache/$_", $opt_debug );
656
 
657
            return 0;
658
        }
659
 
660
        #
661
        #   Wait a short while
662
        #
663
        Verbose("Waiting: " . (time() - $waitStart));
664
        sleep(5);
665
    }
666
}
667
 
668
 
669
#-------------------------------------------------------------------------------
227 dpurdie 670
# Function        : copyFind
671
#
672
# Description     : File:Find:find callback function to transfer files
673
#
674
# Inputs          : None
675
#                   Global: $copyFind_dst       : Target directory
676
#                   Global: $copyFind_src       : Source directory
677
#                   Global: $copyFind_src_len   : Length of Source dir
5818 dpurdie 678
#                   Global: $copyFind_touch     : File to touch after each operation
679
#                   Global: $copyFind_time      ; Time of last touch
227 dpurdie 680
#
681
# Returns         : 
682
#
683
 
684
sub copyFind
685
{
686
    my $item = $File::Find::name;
5818 dpurdie 687
#Debug0("Remove sleep in copy");
688
#sleep(1);
227 dpurdie 689
 
690
    #
691
    #   Calculate the target directory name
692
    #
5743 dpurdie 693
    my $tgt_path = substr($item, $copyFind_src_len );
694
    my $target = $copyFind_dst . $tgt_path;
695
 
696
    # Do not cache some parts of a package when being used by the build system
697
    #   /lcov ...
698
    #
699
    if ( $ENV{GBE_ABT})
700
    {
701
        if ($tgt_path =~ m~^/lcov(/|$)~)
702
        {
703
            Verbose("Prune directory: $tgt_path");
704
            $File::Find::prune = 1;
705
            return;
706
        }
707
    }
708
 
227 dpurdie 709
    if ( -d $item )
710
    {
711
        #
712
        #   Directories are handled differently
713
        #       - Directories are created with nice permissions
714
        #
715
        if ( ! -d $target )
716
        {
717
            mkpath( $target, $opt_debug, 0755);
718
        }
719
    }
720
    else
721
    {
722
        #
723
        #   File copy
724
        #
725
        #
726
        #   Copy file to destination
727
        #   If the file is a link, then duplicate the link contents
728
        #   Use: Unix libraries are created as two files:
729
        #        lib.xxxx.so -> libxxxx.so.vv.vv.vv
730
        #
731
        if ( -l $item )
732
        {
733
            Debug("Clone Link: $target");
734
            my $link = readlink $item;
735
            Debug( "Link: $item, $link");
736
            symlink ($link, $target );
737
            unless ( $link && -l $target )
738
            {
739
                Error("Failed to copy link [$item] to [$target]: $!");
740
            }
741
        }
742
        elsif (File::Copy::copy($item, $target))
743
        {
744
            Debug("Copying File: $target");
745
 
746
            #   Make the file ReadOnly
747
            my $perm = (stat $item)[2] & 07777;
748
            CORE::chmod $perm & 0555, $target;
749
        }
750
        else
751
        {
752
            Error("Failed to copy file [$item] to [$target]: $!");
753
        }
754
    }
5818 dpurdie 755
 
756
    #
757
    #   Touch this file to indicate that the copy operation is still in progress
758
    #   Assists in early detection of partial copies
759
    #   
760
    #   Only touch once a minute to prevent hammering the file system
761
    #
762
    my $age = time() - $copyFind_time;
763
    if ($age > 60)
764
    {
765
        $copyFind_time = time();
766
        TouchFile ( $copyFind_touch, "Marks the cache copy as incomplete");
767
    }
227 dpurdie 768
}
769
 
770
#-------------------------------------------------------------------------------
771
# Function        : error_recovery
772
#
773
# Description     : Error recovery routine
774
#                   Delete the cached entry
775
#
776
# Inputs          :  Globals
777
#
778
# Returns         : None
779
#
780
sub error_recovery
781
{
782
    if ( $remove_on_error )
783
    {
345 dpurdie 784
        ReportError ("Error cleanup. Delete cache entry: $remove_on_error");
227 dpurdie 785
        rmtree( $remove_on_error, $opt_debug );
786
        $remove_on_error = undef;
787
    }
5818 dpurdie 788
 
789
    if ($cacheMarker)
790
    {
791
        ReportError ("Error cleanup. Delete cache marker: $cacheMarker");
792
        rmtree( $cacheMarker, $opt_debug );
793
        $cacheMarker = undef;
794
    }
227 dpurdie 795
}
796
 
797
 
798
#-------------------------------------------------------------------------------
799
# Function        : age_the_cache
800
#
801
# Description     : Age cache entries
802
#                   Determine the age by:
803
#                       Use used.cache file if present
804
#                       Use descpkg file
805
#                       Not a proper entry - delete
806
#
807
# Inputs          : opt_age         - Delete packages older than XX days
808
#
809
# Returns         : Nothing
810
#
811
sub age_the_cache
812
{
813
    my $now = time;
814
 
815
    opendir (DIR, $cache) || die "Cannot open $cache\n";
816
    my @dir_list = readdir(DIR);
817
    closedir DIR;
818
 
819
    for my $fn ( @dir_list)
820
    {
821
        my $keep_dir = 0;
822
        next if ( $fn =~ m/^\./ );
823
        next unless ( -d "$cache/$fn" );
361 dpurdie 824
        next if ( $fn eq "core_devl" );
227 dpurdie 825
 
826
        opendir( DIR, "$cache/$fn" ) || die "Cannot open $cache/$fn\n";
827
        while ( my $fn1 = readdir(DIR) )
828
        {
829
            next if ( $fn1 =~ m/^\./ );
830
            my $dir = "$cache/$fn/$fn1";
831
            my $file = "$dir/used.cache" ;
832
            $file = "$dir/descpkg" unless ( -f $file );
833
 
834
            if ( ! -f $file )
835
            {
836
                #
837
                #   No descpkg file
838
                #   This is a badly formed entry - so delete it
839
                #
361 dpurdie 840
                if ( $opt_test )
841
                {
842
                    Message("Would Purge: $fn/$fn1" );
843
                    $keep_dir = 1;
844
                }
845
                else
846
                {
847
                    Message("Purging: $fn/$fn1" );
848
                    rmtree( $dir, $opt_debug );
849
                }
227 dpurdie 850
            }
851
            else
852
            {
853
                #
854
                #   used.cache or descpkg file found
855
                #   How old is it
856
                #
857
                my $timestamp = (stat($file))[9] || 0;
858
                my $age = int( ($now - $timestamp) / (60 * 60 * 24));
859
 
860
                if ( $age > $opt_age )
861
                {
361 dpurdie 862
                    if ( $opt_test )
863
                    {
864
                        Message("Could Age: $fn/$fn1, $age" );
865
                        $keep_dir = 1;
866
                    } else {
867
                        Message("Aging: $fn/$fn1, $age" );
868
                        rmtree( $dir, $opt_debug );
869
                    }
227 dpurdie 870
                }
871
                else
872
                {
873
                    Verbose("Age of: $fn/$fn1, $age" );
874
                    $keep_dir = 1;
875
                }
876
            }
877
        }
878
        closedir DIR;
879
 
880
        #
881
        #   Delete the entire directory if is is empty
882
        #
883
        unless ( $keep_dir )
884
        {
885
            Message("Remove Empty Dir: $cache/$fn"  );
886
            rmtree( "$cache/$fn", $opt_debug );
887
        }
888
    }
889
}
890
 
891
#-------------------------------------------------------------------------------
892
#   Documentation
893
#
894
 
895
=pod
896
 
361 dpurdie 897
=for htmltoc    SYSUTIL::
898
 
227 dpurdie 899
=head1 NAME
900
 
901
cache_dpkg - Maintain a local cache of packages
902
 
903
=head1 SYNOPSIS
904
 
905
 jats cache_dpkg.pl [options] package/version ...
906
 
907
 Options:
908
    -help              - brief help message
909
    -help -help        - Detailed help message
910
    -man               - Full documentation
911
    -clear             - Delete the entire cache
912
    -flush             - Flush all named packages
913
    -[no]refresh       - Refresh package in cache
914
    -list              - List cache contents with nice format
915
    -dir               - List cache contents
916
    -export            - Generate a list of cached packages
917
    -refresh_all       - Refresh all packages within the cache
918
    -update_all        - Update all packages within the cache as required
5744 dpurdie 919
    -[no]wait          - Wait for package replication
5783 dpurdie 920
    -[no]cache         - Cache packages [default]
227 dpurdie 921
    -quiet             - Suppress warnings
361 dpurdie 922
    -age=nn            - Remove all packages older than nn days
923
    -test              - Use with -age to report ages
227 dpurdie 924
 
925
=head1 OPTIONS
926
 
927
=over 8
928
 
929
=item B<-help>
930
 
931
Print a brief help message and exits.
932
 
933
=item B<-help -help>
934
 
935
Print a detailed help message with an explanation for each option.
936
 
937
=item B<-man>
938
 
939
Prints the manual page and exits.
940
 
941
=item B<-clear>
942
 
943
Delete the B<entire> contents of the dpkg_archive cache. This will occur before
944
any new packages are copied into the cache.
945
 
946
=item B<-flush>
947
 
948
If set then the utility will delete the named packages from the cache. All named
949
packaged will be deleted. This option affects all named packages. It is not
950
possible to flush and copy packages with the same command.
951
 
952
=item B<-[no]refresh>
953
 
954
If the B<refresh> option has been specified then packages will be deleted, from
955
the cache and then a new copy will be copied in. If not specified then no copy
956
will occur if the package is present in the cache.
957
 
958
=item B<-list>
959
 
960
Display a list of all packages in the cache. A formatted display is generated.
961
 
962
This will be done before any packages are transferred.
963
 
964
=item B<-dir>
965
 
966
Display a list of all packages in the cache. This is a raw directory like
967
listing of the cache.
968
 
969
This will be done before any packages are transferred.
970
 
971
=item B<-export>
972
 
973
Generate a space separated list of cached packages as a single line. This is
974
intended to allow a list be exported for later import.
975
 
976
=item B<-refresh_all>
977
 
978
This option will force the program to refresh all the packages in the cache.
979
This forces a B<-refresh> and may be combined with other packages specified
980
on the command line.
981
 
982
=item B<-update_all>
983
 
984
This option will force the program to examine all packages within the cache and
985
refresh packages that are out of date. This option may be combined with other
986
packages specified on the command line.
987
 
988
A package is deemed to be out-of-date if the modification time of the package's
335 dpurdie 989
descpkg file in the cache is older than the one in the archive.
227 dpurdie 990
 
5744 dpurdie 991
=item B<-[no]wait>
992
 
993
This option will cause the utility to wait for specified package versions to be replicated
994
into a package replica. The dafult mode is to not-wait, unless the operation is invoked 
995
from within the build phase.
996
 
997
The utility will wait upto 10 minutes (600 seconds) for a named version to be replicated
998
from the main archive to a replica.
999
 
1000
A dpkg_cache need not be present for the replication-wait to be performed.
1001
 
1002
The wait-for replication step is designed to address an issue where the build system
1003
is remotely located from the main archive. If required package versions are not in the
1004
replica then this utility would copy them from the main archive. This can be very very 
1005
slow - much slower than waiting for the replication to complete.
1006
 
5783 dpurdie 1007
=item B<-[no]cache>
1008
 
1009
This option can be used to prevent the named packages from being cached. The default mode
1010
is to cache the named packages.
1011
 
1012
It is intended to be used with the '-wait' option so that replication is complete
1013
but the local caching is not perform. To be used for non-ant builds to prevent local caching
1014
of packages that are not used in a build.
1015
 
227 dpurdie 1016
=item B<-quiet>
1017
 
1018
This option will suppress almost all of the progress messages, except for a single
1019
copy message. It is intended to be used when the program is called from another
1020
script.
1021
 
1022
=item B<-age=nn>
1023
 
1024
This option will delete all package versions that are older than the nn days.
1025
The age of a package is calculated from the timestamp of the descpkg file.
1026
 
361 dpurdie 1027
=item B<-test>
1028
 
1029
This option modifies the operation of the B<-age=nn> option such that it will not
1030
delete old package-versions. It will simply report what would be deleted.
1031
 
227 dpurdie 1032
=back
1033
 
1034
=head1 DESCRIPTION
1035
 
1036
This program simplifies the operation of maintaining a local copy of
1037
used packages from the maintaining dpkg_archive store. The cache should be
1038
stored on your local disk for speed.
1039
 
1040
=head2 Location of the cache
1041
 
4688 dpurdie 1042
The local cache is specified with the EnvVar GBE_DPKG_CACHE
227 dpurdie 1043
 
4688 dpurdie 1044
=head2 Location of the maintaining archive
227 dpurdie 1045
 
4688 dpurdie 1046
The required pacjage version can be found in three archives. These are:
227 dpurdie 1047
 
4688 dpurdie 1048
=over 4
227 dpurdie 1049
 
4688 dpurdie 1050
=item *
227 dpurdie 1051
 
4688 dpurdie 1052
GBE_DPKG_REPLICA. A local image of the main dpkg_archive. This is used when dpkg_archive is synced locally and is expected to be faster than GBE_DPKG
1053
 
1054
=item *
1055
 
1056
GBE_DPKG. The main dpkg_archive
1057
 
1058
=item *
1059
 
1060
GBE_DPKG_STORE. A global package archive. The search repository of last choice.
1061
 
1062
=back
1063
 
227 dpurdie 1064
=head2 Interaction with local_dpkg_archive
1065
 
1066
If a package is located in the users local_dpkg_archive and we are doing a
1067
simple cache update then the package will be deleted from the cache. This is
1068
done to speed use on slow remote links and ensure cache consistency.
1069
 
5743 dpurdie 1070
=head2 Interaction with build system
1071
 
1072
If the cache operating is done withinthe context of the Build System (GBE_ABT is not zero), 
1073
then some parts of the package will not be transferred. This is done to speed up the caching.
1074
 
1075
Directories that will not be cached:
1076
 
1077
=over 4
1078
 
1079
=item * 
1080
 
1081
lcov - A directory that contains code coverage information. This directory normally 
1082
contains a large number of files, none of which are used by the build system. Over long 
1083
links the trasnfer time of the 'lcov' directory can take hours.
1084
 
1085
=back
1086
 
227 dpurdie 1087
=head1 EXAMPLE
1088
 
1089
=head2 jats dpkg_cache -list
1090
 
1091
This will list the current contents of the cache.
1092
 
1093
=head2 jats dpkg_cache -refresh crc/1.0.4.cr
1094
 
1095
This will delete any cached copy of the package crc/1.0.4.cr, if one exists,
1096
and then copy in a new version.
1097
 
1098
=head2 jats dpkg_cache crc
1099
 
1100
This will copy in all versions of the crc package. This may not be desirable.
1101
 
1102
=head2 jats dpkg_cache -update_all
1103
 
1104
This will examine all packages in the cache and refresh those packages that are
1105
out of date.
1106
 
1107
=cut
1108