Subversion Repositories DevTools

Rev

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

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