RZ

0001: #!/usr/bin/perl
0002:
0003: # rgz # command line tool
0004:
0005: # for calling the actual working code
0006: {
0007:     my @programme;        # exec interpreter and code
0008:     my @linkage;          # arguments
0009:     sub set_linkage {
0010:         my $here = here( $0 );
0011:         my $inc = $here =~ m{^/} ? $here : './'.$here;
0012:         $inc =~ s{/*$}{};
0013:         {
0014:             my %dispatch_table = (
0015:                 analyze    => "FileAnalyze.pl",
0016:                 synthesize => "DemandRetriever.pl",
0017:                 realize    => "FileRealize.pl",
0018:             );
0019:             @programme = (
0020:                 $debug ? qw{ perl -w } : qw{ perl },
0021:                 qw{ -I }, $inc,
0022:                 $here.$dispatch_table{ get_algorithm() },
0023:             );
0024:         }
0025:         for my $key ( get_option_keys() ) {
0026:             push @linkage, get_option( $key );
0027:         }
0028:     }
0029:     sub exec_linkage {
0030:         return unless @programme;
0031:         my ( undef, undef, $verbosity, $debug ) = get_hvvd();
0032:         if ( $debug + $verbosity >= 2 ) {
0033:             print STDERR "Forwarding to: @programme\n";
0034:         }
0035:         unless ( exec { "perl" } @programme, @linkage ) {
0036:             print STDERR "Failure in called programme\n";
0037:         }
0038:     }
0039: }
0040:
0041: use Getopt::Long; #qw{ :config no_permute bundling no_ignore_case }
0042:
0043: # Options
0044:
0045: commandline: {
0046:     my @fullbase = ( "", "", "" );
0047:     my $rm = qr{(?:(?:ht|f|nn)tp|file)://[^/]*(?:/|$)};
0048:     my $rd = qr{.*?};
0049:     my $rf = qr{[^/]*?};
0050:     my $rx = qr{(?:(?<!^)(?<!^\.)(?<!^\.\.)(?<!/)(?<!/\.)(?<!/\.\.)\.rz)?};
0051:     sub cleanurl {
0052:         $_ = $_[0];
0053:
0054:         my ( $machine, $rest ) = m{^($rm?)(.*)$};
0055:
0056:         return $machine . clean( $rest );
0057:     }
0058:     sub clean {
0059:         $_ = $_[0];
0060:
0061:         # append / after . or ..
0062:
0063:         # interior /./ & // compaction
0064:         # leading      ./   stripped
0065:
0066:         # interior /foo/../ compaction
0067:         # leading   foo/../ stripped
0068:
0069:         s{(?:^|(?<=^\.)|(?<=/)|(?<=/\.))\.$}{\./};
0070:
0071:         s{(/\.?)+/}{/}g;
0072:         s{^\./}{};
0073:
0074:         while ( s{/(?!\.\./)[^/]+/\.\./}{/}g ) {};
0075:         s{^(?!\.\./)[^/]+/\.\./}{};
0076:
0077:         return $_;
0078:     }
0079:
0080:     # follow symlinks sufficiently to get the directory holding a regular entry
0081:     sub here {
0082:         my $here;
0083:         for ( my $path = clean( $_[0] );; ) {
0084:             ( $here ) = $path =~ m{^($rd)$rf$};
0085:             -l $path or last;
0086:             my $link = readlink $path;
0087:             $path = clean( $link =~ m{^/} ? $link : $here.$link );
0088:         }
0089:         return $here;
0090:     }
0091:
0092:     my ( $help, $version, $verbosity, $debug ) = ( 0, 0, 0, 0 );
0093:     sub get_hvvd { return ( $help, $version, $verbosity, $debug, ); }
0094:
0095:     {
0096:         my %exclusion = ();
0097:         sub exclusive {
0098:             my $x = shift;
0099:             local( $" ) = " ";
0100:             if ( exists $exclusion{ $x } ) {
0101:                 die "Mutually exclusive: $exclusion{ $x } and --@_\n";
0102:             }
0103:             else {
0104:                 $exclusion{ $x } = "--@_";
0105:             }
0106:         }
0107:         sub exclusive_command {
0108:             my $x = shift;
0109:             local( $" ) = " ";
0110:             if ( exists $exclusion{ $x } ) {
0111:                 die "Mutually exclusive: $exclusion{ $x } and @_\n";
0112:             }
0113:             else {
0114:                 $exclusion{ $x } = "@_";
0115:             }
0116:         }
0117:
0118:         my %exclusionf = ();
0119:         sub filename {
0120:             my $x = shift;
0121:             local( $" ) = " ";
0122:             if ( exists $exclusionf{ $x } ) {
0123:                 die "Duplicate filename: $exclusionf{ $x } and --@_\n";
0124:             }
0125:             else {
0126:                 $exclusionf{ $x } = "--@_";
0127:             }
0128:         }
0129:         sub filename_command {
0130:             my $x = shift;
0131:             local( $" ) = " ";
0132:             if ( exists $exclusionf{ $x } ) {
0133:                 die "Duplicate filename: $exclusionf{ $x } and @_\n";
0134:             }
0135:             else {
0136:                 $exclusionf{ $x } = "@_";
0137:             }
0138:         }
0139:     }
0140:
0141:     {
0142:         my $algorithm = 7;
0143:         sub algorithm {
0144:             selectalgorithm: {
0145:                 my $s = $_[ 0 ];
0146:                 $s eq 'analyze'        and ( $algorithm &= 1, last );
0147:                 $s eq 'synthesize'     and ( $algorithm &= 2, last );
0148:                 $s eq 'realize'        and ( $algorithm &= 4, last );
0149:                 $s eq 'not-analyze'    and ( $algorithm &= 6, last );
0150:                 $s eq 'not-synthesize' and ( $algorithm &= 5, last );
0151:                 $s eq 'not-realize'    and ( $algorithm &= 3, last );
0152:             }
0153:             unless ( $algorithm ) {
0154:                 die "Algorithmically inconsistent\n";
0155:             }
0156:         }
0157:         sub get_algorithm {
0158:             $algorithm == 1 and return "analyze";
0159:             $algorithm == 2 and return "synthesize";
0160:             $algorithm == 4 and return "realize";
0161:             return '';
0162:         }
0163:     }
0164:
0165:     my $backup_suffix = "~";
0166:     my $write_strategy = undef;
0167:     {
0168:         my %write_strategy;
0169:         @write_strategy{ 'departure', 'file', 'destination' } = ( 1, 0, 1 );
0170:         sub write_strategy {
0171:             if ( defined $write_strategy ) {
0172:                 $write_strategy{ $_[0] } = $write_strategy;
0173:                 unless ( $_[0] eq 'file' xor $write_strategy & -3 ) {
0174:                     die "Inconsistent write/backup mode\n";
0175:                 }
0176:                 undef $write_strategy;
0177:             }
0178:         }
0179:         sub consistent_strategy {
0180:             my $t = shift;
0181:             return $t unless defined $write_strategy;
0182:             {
0183:                 return $t if $t eq 'file' xor $write_strategy & -3;
0184:                 redo if $t = shift;
0185:             }
0186:             die "Inconsistent write/backup mode\n";
0187:         }
0188:         sub get_write_strategy {
0189:             my $x = shift;
0190:             $x == 0 and return "--overwrite";
0191:             $x == 1 and return "--remove-existing";
0192:             $x == 2 and return "--copy-aside-and-overwrite";
0193:             $x == 3 and return "--move-aside-existing";
0194:             die; # Shouldn't get here
0195:         }
0196:         sub get_strategy {
0197:             if ( $write_strategy{ $_[0] } & -2 and $backup_suffix ne "~" ) {
0198:                 return (
0199:                     "--backup-suffix", $backup_suffix,
0200:                     get_write_strategy( $write_strategy{ $_[0] } ),
0201:                 );
0202:             }
0203:             else {
0204:                 return (
0205:                     get_write_strategy( $write_strategy{ $_[0] } ),
0206:                 );
0207:             }
0208:         }
0209:     }
0210:
0211:     my %sane_default = ();
0212:     sub sane_default {
0213:         my ( $d, $handler ) = @_;
0214:         if ( not exists $sane_default{ $d } or not defined $handler ) {
0215:             $sane_default{ $d } = $handler;
0216:         }
0217:     }
0218:
0219:     {
0220:         my %option = ();
0221:         sub set_option {
0222:             my $isnode = shift;
0223:             push( @{$option{ $isnode }}, @_ );
0224:         }
0225:         sub get_option_keys {
0226:             return sort keys %option;
0227:         }
0228:         sub get_option {
0229:             return @{$option{ $_[0] }};
0230:         }
0231:     }
0232:
0233:     #my %node = ();
0234:     #sub set_node {
0235:     #        $node{ $_[0] } = $_[1];
0236:     #}
0237:
0238:     my %need = (
0239:         departure =>    "Incomplete arguments specified\n",
0240:         destination =>  "Incomplete destination arguments specified\n",
0241:     );
0242:     sub meets_need {
0243:         $need{ shift @_ } = undef while @_;
0244:     }
0245:
0246: ######## -- long options on the command line ########
0247:
0248:     my @options = (
0249:         'help|h+'    => \$help,
0250:         'version|V'  => \$version,
0251:         'verbose|v+' =>
0252:         sub {
0253:             ++$verbosity;
0254:             set_option( AAAverbosity => "--verbose" );
0255:         },
0256:         'debug|D+' =>
0257:         sub {
0258:             ++$debug;
0259:             set_option( AAAdebug => "--debug" );
0260:         },
0261:
0262:         'overwrite|O'                => sub { $write_strategy = 0 },
0263:         'remove-existing|R'          => sub { $write_strategy = 1 },
0264:         'copy-aside-and-overwrite|C' => sub { $write_strategy = 2 },
0265:         'move-aside-existing|M'      => sub { $write_strategy = 3 },
0266:
0267:         'backup-suffix|B=s'          => \$backup_suffix,
0268:
0269:         'no-stdin-analyze|no-stdin-given|nostdin-analyze|nostdin-given' =>
0270:         sub {
0271:             exclusive( stdin => 'no-stdin' );
0272:         },
0273:
0274:         'stdin-analyze' =>
0275:         sub {
0276:             exclusive( stdin => 'stdin-analyze' );
0277:             exclusive( analyze => 'stdin-analyze' );
0278:             algorithm( analyze => @_ );
0279:             set_option( AAanalyze => "--stdin-analyze" );
0280:             meets_need( departure => );
0281:         },
0282:
0283:         'analyze=s' =>
0284:         sub {
0285:             exclusive( analyze => @_ );
0286:             algorithm( analyze => @_ );
0287:             my $cleanname = clean( $_[1] );
0288:             @fullbase = ( $cleanname =~ m{(^)$rd($rf)($)}, );
0289:             $fullbase[1] or die "Empty filename\n";
0290:             filename( $cleanname, @_ );
0291:             set_option( AAanalyze => "--analyze", $cleanname );
0292:             meets_need( departure => );
0293:         },
0294:
0295:         'convert-file=s' =>
0296:         sub {
0297:             exclusive( analyze => @_ );
0298:             exclusive( 'concentrated-file' => @_ );
0299:             algorithm( analyze => @_ );
0300:             write_strategy( file => @_ );
0301:             my $cleanname = clean( $_[1] );
0302:             @fullbase = ( $cleanname =~ m{^($rd)($rf)($)}, );
0303:             $fullbase[1] or die "Empty filename\n";
0304:             filename( $cleanname, @_ );
0305:             set_option( AAconvert =>
0306:                 get_strategy( 'file' ), "--convert-file", $cleanname,
0307:             );
0308:             meets_need( departure => destination => );
0309:         },
0310:
0311:         'convert-departure=s' =>
0312:         sub {
0313:             exclusive( analyze => @_ );
0314:             algorithm( analyze => @_ );
0315:             write_strategy( departure => @_ );
0316:             my $cleanname = clean( $_[1] );
0317:             @fullbase = ( $cleanname =~ m{^($rd)($rf)($)}, );
0318:             $fullbase[1] or die "Empty filename\n";
0319:             filename( $cleanname, @_ );
0320:             set_option( AAconvert =>
0321:                 get_strategy( 'departure' ), "--convert-departure", $cleanname,
0322:             );
0323:             meets_need( departure => destination => );
0324:         },
0325:
0326:         'retrieve=s' =>
0327:         sub {
0328:             exclusive( synthesize => @_ );
0329:             algorithm( synthesize => @_ );
0330:             my $cleanname = cleanurl( $_[1] );
0331:             @fullbase = ( $cleanname =~ m{(^)$rd($rf)($rx)$}, );
0332:             $fullbase[1] or die "Empty filename\n";
0333:             filename( $cleanname, @_ );
0334:             set_option( AAretrieve => "--retrieve", $cleanname );
0335:             meets_need( departure => );
0336:         },
0337:
0338:         'stdin-given' =>
0339:         sub {
0340:             exclusive( stdin => 'stdin-given' );
0341:             algorithm( 'synthesize' );
0342:             set_option( BBgiven => "--stdin-given" );
0343:         },
0344:
0345:         'given=s' =>
0346:         sub {
0347:             algorithm( 'synthesize' );
0348:             my $cleanname = clean( $_[1] );
0349:             set_option( BBgiven => "--given", $cleanname );
0350:         },
0351:
0352:         'no-stdout-reconstituted|nostdout-reconstituted' =>
0353:         sub {
0354:             exclusive( stdout => 'nostdout' );
0355:             sane_default( stdout => );
0356:         },
0357:
0358:         'stdout-reconstituted' =>
0359:         sub {
0360:             exclusive( stdout => 'stdout-reconstituted' );
0361:             algorithm( 'not-analyze' );
0362:             set_option( CCstdout => "--stdout-reconstituted" );
0363:             sane_default( stdout => );
0364:             meets_need( destination => );
0365:         },
0366:
0367:         'realize=s' =>
0368:         sub {
0369:             exclusive( realize => @_ );
0370:             algorithm( realize => @_ );
0371:             my $cleanname = clean( $_[1] );
0372:             @fullbase = ( $cleanname =~ m{(^)$rd($rf)($rx)$}, );
0373:             $fullbase[1] or die "Empty filename\n";
0374:             filename( $cleanname, @_ );
0375:             set_option( AArealize => "--realize", $cleanname );
0376:             meets_need( departure => );
0377:         },
0378:
0379:         'revert-file=s' =>
0380:         sub {
0381:             exclusive( realize => @_ );
0382:             exclusive( 'reconstituted-file' => @_ );
0383:             algorithm( realize => @_ );
0384:             write_strategy( file => @_ );
0385:             my $cleanname = clean( $_[1] );
0386:             @fullbase = ( $cleanname =~ m{^($rd)($rf)($rx)$}, );
0387:             $fullbase[1] or die "Empty filename\n";
0388:             filename( $cleanname, @_ );
0389:             set_option( AArevert =>
0390:                 get_strategy( 'file' ), "--revert-file", $cleanname,
0391:             );
0392:             meets_need( departure => destination => );
0393:         },
0394:
0395:         'revert-departure=s' =>
0396:         sub {
0397:             exclusive( realize => @_ );
0398:             algorithm( realize => @_ );
0399:             write_strategy( departure => @_ );
0400:             my $cleanname = clean( $_[1] );
0401:             @fullbase = ( $cleanname =~ m{^($rd)($rf)($rx)$}, );
0402:             $fullbase[1] or die "Empty filename\n";
0403:             filename( $cleanname, @_ );
0404:             set_option( AArevert =>
0405:                 get_strategy( 'departure' ), "--revert-departure", $cleanname,
0406:             );
0407:             meets_need( departure => destination => );
0408:         },
0409:
0410:         'no-reconstituted-file|no-file|nofile|'.
0411:         'no-reconstituted-destination|no-destination|nodestination' =>
0412:         sub {
0413:             exclusive( reconstituted => 'no-reconstituted' );
0414:             sane_default( reconstituted => );
0415:         },
0416:
0417:         'reconstituted-file|file|f=s' =>
0418:         sub {
0419:             exclusive( reconstituted => @_ );
0420:             exclusive( 'reconstituted-file' => @_ );
0421:             algorithm( 'not-analyze' => @_ );
0422:             write_strategy( file => @_ );
0423:             my $cleanname = clean( $_[1] );
0424:             my @fullname = ( $cleanname =~ m{^($rd)($rf)($)}, );
0425:             if ( $fullname[1] ) {
0426:                 filename( $cleanname, @_ );
0427:                 set_option( CCreconstituted =>
0428:                     get_strategy( 'file' ), "--reconstituted-file", $cleanname,
0429:                 );
0430:                 meets_need( destination => );
0431:             }
0432:             else {
0433:                 my $dir = $fullname[0];
0434:                 my $uglyname = $_[1];
0435:                 my $strategy = get_strategy( 'file' );
0436:                 sane_default( 'reconstituted-directory' =>
0437:                     sub {
0438:                         my $fullname = "$dir$fullbase[1]";
0439:                         filename( $fullname, "--reconstituted-file", $uglyname,
0440:                         );
0441:                         set_option( CCreconstituted =>
0442:                             $strategy, "--reconstituted-file", $fullname,
0443:                         );
0444:                         meets_need( destination => );
0445:                     },
0446:                 );              # Wow!  Nexted Closures!
0447:             }
0448:             sane_default( reconstituted => );
0449:         },
0450:
0451:         'reconstituted-destination|destination|d=s' =>
0452:         sub {
0453:             exclusive( reconstituted => @_ );
0454:             algorithm( 'not-analyze' => @_ );
0455:             write_strategy( destination => @_ );
0456:             my $cleanname = clean( $_[1] );
0457:             my @fullname = ( $cleanname =~ m{^($rd)($rf)($)}, );
0458:             if ( $fullname[1] ) {
0459:                 filename( $cleanname, @_ );
0460:                 set_option( CCreconstituted =>
0461:                     get_strategy( 'destination' ),
0462:                     "--reconstituted-destination", $cleanname,
0463:                 );
0464:                 meets_need( destination => );
0465:             }
0466:             else {
0467:                 my $dir = $fullname[0];
0468:                 my $uglyname = $_[1];
0469:                 my $strategy = get_strategy( 'destination' );
0470:                 sane_default( 'reconstituted-directory' =>
0471:                     sub {
0472:                         my $fullname = "$dir$fullbase[1]";
0473:                         filename(
0474:                             $fullname,
0475:                             "--reconstituted-destination", $uglyname,
0476:                         );
0477:                         set_option( CCreconstituted =>
0478:                             $strategy,
0479:                             "--reconstituted-destination", $fullname,
0480:                         );
0481:                         meets_need( destination => );
0482:                     },
0483:                 );              # Wow!  Nexted Closures!
0484:             }
0485:             sane_default( reconstituted => );
0486:         },
0487:
0488:         'no-concentrated-file|no-rz-file|norz-file|'.
0489:         'no-concentrated-destination|no-rz-destination|norz-destination' =>
0490:         sub {
0491:             exclusive( concentrated => 'no-concentrated' );
0492:             sane_default( concentrated => );
0493:         },
0494:
0495:         'concentrated-file|rz-file=s' =>
0496:         sub {
0497:             exclusive( concentrated => @_ );
0498:             exclusive( 'concentrated-file' => @_ );
0499:             algorithm( 'not-realize' => @_ );
0500:             write_strategy( file => @_ );
0501:             my $cleanname = clean( $_[1] );
0502:             my @fullname = ( $cleanname =~ m{^($rd)($rf)($)}, );
0503:             if ( $fullname[1] ) {
0504:                 filename( $cleanname, @_ );
0505:                 set_option( DDconcentrated =>
0506:                     get_strategy( 'file' ), "--concentrated-file", $cleanname,
0507:                 );
0508:                 meets_need( destination => );
0509:             }
0510:             else {
0511:                 my $dir = $fullname[0];
0512:                 my $uglyname = $_[1];
0513:                 my $strategy = get_strategy( 'file' );
0514:                 sane_default( 'concentrated-directory' =>
0515:                     sub {
0516:                         $fullbase[1] or die "Empty filename\n";
0517:                         my $fullname = "$dir$fullbase[1].rz";
0518:                         filename( $fullname, "--concentrated-file", $uglyname);
0519:                         set_option( DDconcentrated =>
0520:                             $strategy, "--concentrated-file", $fullname,
0521:                         );
0522:                         meets_need( destination => );
0523:                     },
0524:                 );              # Wow!  Nexted Closures!
0525:             }
0526:             sane_default( concentrated => );
0527:         },
0528:
0529:         'concentrated-destination|rz-destination=s' =>
0530:         sub {
0531:             exclusive( concentrated => @_ );
0532:             algorithm( 'not-realize' => @_ );
0533:             write_strategy( destination => @_ );
0534:             my $cleanname = clean( $_[1] );
0535:             my @fullname = ( $cleanname =~ m{^($rd)($rf)($)}, );
0536:             if ( $fullname[1] ) {
0537:                 filename( $cleanname, @_ );
0538:                 set_option( DDconcentrated =>
0539:                     get_strategy( 'destination' ),
0540:                     "--concentrated-destination", $cleanname,
0541:                 );
0542:                 meets_need( destination => );
0543:             }
0544:             else {
0545:                 my $dir = $fullname[0];
0546:                 my $uglyname = $_[1];
0547:                 my $strategy = get_strategy( 'destination' );
0548:                 sane_default( 'concentrated-directory' =>
0549:                     sub {
0550:                         $fullbase[1] or die "Empty filename\n";
0551:                         my $fullname = "$dir$fullbase[1].rz";
0552:                         filename(
0553:                             $fullname, "--concentrated-destination", $uglyname,
0554:                         );
0555:                         set_option( DDconcentrated =>
0556:                             $strategy, "--concentrated-destination", $fullname,
0557:                         );
0558:                         meets_need( destination => );
0559:                     },
0560:                 );              # Wow!  Nexted Closures!
0561:             }
0562:             sane_default( concentrated => );
0563:         },
0564:     );
0565:
0566: ######## bare commands on the command line ########
0567:
0568:     my %commands = (
0569:         'analyze' =>
0570:         sub {
0571:             exclusive_command( analyze => @_ );
0572:             algorithm( analyze => @_ );
0573:         },
0574:
0575:         'synthesize' =>
0576:         sub {
0577:             exclusive_command( synthesize => @_ );
0578:             algorithm( synthesize => @_ );
0579:         },
0580:
0581:         'realize' =>
0582:         sub {
0583:             exclusive_command( realize => @_ );
0584:             algorithm( realize => @_ );
0585:         },
0586:
0587:         'cat' =>
0588:         sub {
0589:             exclusive_command( realize => @_ );
0590:             algorithm( realize => @_ );
0591:         },
0592:
0593:         'convert' =>
0594:         sub {
0595:             exclusive_command( analyze => @_ );
0596:             algorithm( analyze => @_ );
0597:         },
0598:
0599:         'revert' =>
0600:         sub {
0601:             exclusive_command( realize => @_ );
0602:             algorithm( realize => @_ );
0603:         },
0604:     );
0605:
0606: ######## bare arguments on the command line ########
0607:
0608:     my %arguments = (
0609:         'analyze' =>
0610:         sub {
0611:             exclusive_command( argument => @_ );
0612:             my $cleanname = clean( $_[1] );
0613:             @fullbase = ( $cleanname =~ m{(^)$rd($rf)($)}, );
0614:             $fullbase[1] or die "Empty filename\n";
0615:             filename_command( $cleanname, @_ );
0616:             set_option( AAanalyze => "--analyze", $cleanname );
0617:             meets_need( departure => );
0618:             sane_default( concentrated =>
0619:                 sub {
0620:                     my $fullname = "$fullbase[1].rz";
0621:                     filename_command( $fullname, @_ );
0622:                     my $fd = consistent_strategy( 'file', 'destination' );
0623:                     write_strategy( $fd );
0624:                     set_option( DDconcentrated =>
0625:                         get_strategy( $fd ), "--concentrated-$fd", $fullname,
0626:                     );
0627:                     meets_need( destination => );
0628:                 },
0629:             );
0630:         },
0631:
0632:         'synthesize' =>
0633:         sub {
0634:             exclusive_command( argument => @_ );
0635:             my $cleanname = cleanurl( $_[1] );
0636:             @fullbase = ( $cleanname =~ m{(^)$rd($rf)($rx)$}, );
0637:             $fullbase[1] or die "Empty filename\n";
0638:             set_option( AAretrieve => "--retrieve", $cleanname );
0639:             meets_need( departure => );
0640:             sane_default( reconstituted =>
0641:                 sub {
0642:                     my $fullname = $fullbase[1];
0643:                     filename_command( $fullname, @_ );
0644:                     my $fd = consistent_strategy( 'file', 'destination' );
0645:                     write_strategy( $fd );
0646:                     set_option( CCreconstituted =>
0647:                         get_strategy( $fd ), "--reconstituted-$fd", $fullname,
0648:                     );
0649:                     meets_need( destination => );
0650:                 },
0651:             );
0652:             #set_url( $_[1] );
0653:         },
0654:
0655:         'realize' =>
0656:         sub {
0657:             exclusive_command( argument => @_ );
0658:             my $cleanname = clean( $_[1] );
0659:             @fullbase = ( $cleanname =~ m{(^)$rd($rf)($rx)$}, );
0660:             $fullbase[1] or die "Empty filename\n";
0661:             filename_command( $cleanname, @_ );
0662:             set_option( AArealize => "--realize", $cleanname );
0663:             meets_need( departure => );
0664:             sane_default( reconstituted =>
0665:                 sub {
0666:                     my $fullname = $fullbase[1];
0667:                     filename_command( $fullname, @_ );
0668:                     my $fd = consistent_strategy( 'file', 'destination' );
0669:                     write_strategy( $fd );
0670:                     set_option( CCreconstituted =>
0671:                         get_strategy( $fd ), "--reconstituted-$fd", $fullname,
0672:                     );
0673:                     meets_need( destination => );
0674:                 },
0675:             );
0676:         },
0677:
0678:         'cat' =>
0679:         sub {
0680:             exclusive_command( argument => @_ );
0681:             my $cleanname = clean( $_[1] );
0682:             @fullbase = ( $cleanname =~ m{(^)$rd($rf)($rx)$}, );
0683:             $fullbase[1] or die "Empty filename\n";
0684:             filename_command( $cleanname, @_ );
0685:             set_option( AArealize => "--realize", $cleanname );
0686:             meets_need( departure => );
0687:             sane_default( stdout =>
0688:                 sub {
0689:                     set_option( CCstdout => "--stdout-reconstituted" );
0690:                     meets_need( destination => );
0691:                 },
0692:             );
0693:         },
0694:
0695:         'convert' =>
0696:         sub {
0697:             exclusive_command( argument => @_ );
0698:             my $cleanname = clean( $_[1] );
0699:             @fullbase = ( $cleanname =~ m{^($rd)($rf)($)}, );
0700:             $fullbase[1] or die "Empty filename\n";
0701:             filename_command( $cleanname, @_ );
0702:             my $fs = consistent_strategy( 'file', 'departure' );
0703:             write_strategy( $fs );
0704:             set_option( AAconvert =>
0705:                 get_strategy( $fs ), "--convert-$fs", $cleanname,
0706:             );
0707:             meets_need( departure => destination => );
0708:             my @df = ( 'destination', 'file' );
0709:             if ( $fs eq 'file' ) {
0710:                 exclusive_command( 'concentrated-file' => @_ );
0711:                 pop @df;
0712:             }
0713:             sane_default( concentrated =>
0714:                 sub {
0715:                     local( $" ) = "";
0716:                     my $fullname = "@fullbase[0,1].rz";
0717:                     filename_command( $fullname, @_ );
0718:                     my $fd = consistent_strategy( @df );
0719:                     write_strategy( $fd );
0720:                     set_option( DDconcentrated =>
0721:                         get_strategy( $fd ), "--concentrated-$fd", $fullname,
0722:                     );
0723:                     meets_need( destination => );
0724:                 },
0725:             );
0726:         },
0727:
0728:         'revert' =>
0729:         sub {
0730:             exclusive_command( argument => @_ );
0731:             my $cleanname = clean( $_[1] );
0732:             @fullbase = ( $cleanname =~ m{^($rd)($rf)($rx)$}, );
0733:             $fullbase[1] or die "Empty filename\n";
0734:             filename_command( $cleanname, @_ );
0735:             my $fs = consistent_strategy( 'file', 'departure' );
0736:             write_strategy( $fs );
0737:             local( $" ) = "";
0738:             set_option( AArevert =>
0739:                 get_strategy( $fs ), "--revert-$fs", "@fullbase[0,1,2]",
0740:             );
0741:             meets_need( departure => destination => );
0742:             $fullbase[2] or return;
0743:             my @df = ( 'destination', 'file' );
0744:             if ( $fs eq 'file' ) {
0745:                 exclusive_command( 'reconstituted-file' => @_ );
0746:                 pop @df;
0747:             }
0748:             sane_default( reconstituted =>
0749:                 sub {
0750:                     local( $" ) = "";
0751:                     my $fullname = "@fullbase[0,1]";
0752:                     filename_command( $fullname, @_ );
0753:                     my $fd = consistent_strategy( @df );
0754:                     write_strategy( $fd );
0755:                     local( $" ) = "";
0756:                     set_option( CCreconstituted =>
0757:                         get_strategy( $fd ), "--reconstituted-$fd", $fullname,
0758:                     );
0759:                     meets_need( destination => );
0760:                 },
0761:             );
0762:         },
0763:     );
0764:
0765: ######## now do the command line parsing ########
0766:
0767:     my $parser = new Getopt::Long::Parser;
0768:
0769:     #### grab everything before an explicit command
0770:
0771:     $parser->configure( 'no_permute' );
0772:     $parser->configure( 'bundling' );
0773:     $parser->configure( 'no_ignore_case' );
0774:     $parser->getoptions(
0775:         @options,
0776:     ) or last commandline;
0777:
0778:     if ( my $command = shift @ARGV ) {
0779:
0780:         #### grab one explicit command
0781:
0782:         if ( exists $commands{ $command } ) {
0783:             eval {
0784:                 &{$commands{ $command }}( $command );
0785:             };
0786:             if ( $@ ) {
0787:                 print STDERR $@;
0788:                 last commandline;
0789:             }
0790:         }
0791:         else {
0792:             print STDERR "Error in commands or arguments\n";
0793:             last commandline;
0794:         }
0795:
0796:         #### grab everything left including bare arguments
0797:
0798:         $parser->configure( 'permute' );
0799:         $parser->getoptions(
0800:             @options,
0801:             '<>' =>
0802:             sub {
0803:                 if ( exists $arguments{ $command } ) {
0804:                     &{$arguments{ $command }}( $command, @_ );
0805:                 }
0806:                 else {
0807:                     die "Error in commands or arguments\n";
0808:                 }
0809:             }
0810:         ) or last commandline;
0811:     }
0812:
0813:     #### reconcile defaults issued by an explicit command
0814:     #### and clean up default filenames for explicit/ directory only options
0815:
0816:     for my $default_handler ( values %sane_default ) {
0817:         if ( defined $default_handler ) {
0818:             eval {
0819:                 &{$default_handler}( 'default' );
0820:             };
0821:             if ( $@ ) {
0822:                 print STDERR $@;
0823:                 last commandline;
0824:             }
0825:         }
0826:     }
0827:
0828:     #### check for leftover explicit write/backup mode switches
0829:
0830:     if ( defined $write_strategy ) {
0831:         print STDERR "Warning: meaningless context ";
0832:         print STDERR "for write/backup mode switch: ";
0833:         print STDERR get_write_strategy( $write_strategy );
0834:         print STDERR "\n";
0835:     }
0836:
0837:     #### check for remaining ARGV
0838:
0839:     if ( @ARGV ) {
0840:         print STDERR "Remaining unparsable arguments\n";
0841:         last commandline;
0842:     }
0843:
0844:     #### completeness checks
0845:
0846:     if ( get_algorithm() ) {
0847:         for ( values %need ) {
0848:             defined or next;
0849:             print STDERR;
0850:             last commandline;
0851:         }
0852:     }
0853:     else {
0854:         print STDERR "No action requested\n";
0855:         last commandline;
0856:     }
0857:
0858:     #### set up the call to do the actual work
0859:
0860:     set_linkage();
0861: }
0862:
0863: # Main action
0864:
0865: my ( $help, $version, $verbosity, $debug ) = get_hvvd();
0866:
0867: if ( $version ) {
0868:     print STDERR "Version: 0.0.48\n";
0869:     my $magic =
0870:         pack( "C", 159 )."rgz".13.10.26.10."zlib".0.0.4.0.
0871:         pack( "N4",
0872:             555777555, # checksum bits  0-31
0873:             777222777, # checksum bits 32-63
0874:             999555999, # checksum bits 64-95
0875:             1<<16,    # blocksize 8192 bytes
0876:         );
0877:     print STDERR "File format version (rz):\n  ";
0878:     {
0879:         local( $, ) = ".";
0880:         print STDERR unpack( "C16", $magic ), "\n  ";
0881:         print STDERR unpack( "x16C16", $magic );
0882:     }
0883:     print STDERR "\n";
0884: }
0885:
0886: if ( $debug ) {
0887:     print STDERR "Algorithm and arguments:\n";
0888:     if ( my $algorithm = get_algorithm() ) {
0889:         print STDERR "  $algorithm\n";
0890:     }
0891:     else {
0892:         print STDERR "  rgz\n";
0893:     }
0894:     local( $" ) = " ";
0895:     for my $key ( get_option_keys() ) {
0896:         my @option = get_option( $key );
0897:         print STDERR "  @option\n";
0898:     }
0899: }
0900:
0901: my $max_helplevel = 0;
0902: my @help_message;
0903:
0904: $help_message[ $max_helplevel++ ] = <<'__END_OF_MESSAGE__';
0905: Exempli gratia:
0906:   rgz analyze     Packages         # at server site create new `Packages.rz'
0907:   rgz synthesize  http://elsewhere.net/Packages.rz     # download `Packages'
0908:
0909: __END_OF_MESSAGE__
0910:
0911: $help_message[ $max_helplevel++ ] = <<'__END_OF_MESSAGE__';
0912: Overview:
0913:   `rgz' speeds the downloads of long files using the synchronization methods
0914:   introduced by the programme `rsync'; however, it does so in a two step
0915:   process.  The analysis phase divides a file into 8K chunks, creates a table
0916:   of 96 bit signatures, compresses the data blocks, and reassembles the whole
0917:   into a single concentrated `rz' file.  This need be performed only once
0918:   and the file should then be made available by an ordinary http or ftp
0919:   server.  The server requires only the ability to serve files by byte ranges
0920:   in order for the synthesis phase to take advantage of the analyzed file.
0921:   The synthesis phase reconstitutes a file from remote and local sources,
0922:   only downloading data blocks that differ from ones available locally.
0923:
0924: __END_OF_MESSAGE__
0925:
0926: $help_message[ $max_helplevel++ ] = <<'__END_OF_MESSAGE__';
0927: Secondary command examples:
0928:   rgz convert  Packages      # concentrates file `Packages' in place
0929:   rgz revert   Packages.rz   # reconstitutes file `Packages.rz' in place
0930:   rgz realize  Packages.rz   # complements analyze
0931:   rgz cat      Packages.rz   # reconstitutes to stdout
0932:
0933: __END_OF_MESSAGE__
0934:
0935: $help_message[ $max_helplevel++ ] = <<'__END_OF_MESSAGE__';
0936: Command usage:
0937:   rgz analyze SOURCEDATA [--rz-file CONCENTRATEDFILE]
0938:   rgz synthesize URL [--file RECONSTITUTEDFILE]
0939:
0940:   rgz convert SOURCEFILE [--rz-destination NEWCONCENTRATEDNAME]
0941:   rgz revert RZFILE [--destination NEWRECONSTITUTEDNAME]
0942:   rgz realize RZDATA [--file RECONSTITUTEDFILE]
0943:   rgz cat RZDATA
0944:
0945: __END_OF_MESSAGE__
0946:
0947: $help_message[ $max_helplevel++ ] = <<'__END_OF_MESSAGE__';
0948: Options:
0949:   [--analyze DATA] [--stdin-analyze] [--no{|-}stdin{|-analyze|-given}]
0950:   [--convert-file FILE] [--convert-departure FILE]
0951:   [--retrieve URL] [--given DATA] [--stdin-given]
0952:   [--realize DATA] [--revert-file FILE] [--revert-departure NAME]
0953:   [--stdout{|-reconstituted}] [--no{|-}stdout{|-reconstituted}]
0954:   [-{|-reconstituted}-file FILE] [-{|-reconstituted}-destination NAME]
0955:   [--no{{|-}file|{|-}destination|-reconstituted{|-file|-destination}]
0956:   [--{rz|concentrated}-file FILE] [--{rz|concentrated}-destination NAME]
0957:   [--no{{|-}rz|-concentrated}{|-file|-destination}]
0958:   [--{O|overwrite}] [--{C|copy-aside-and-overwrite}]
0959:   [--{R|remove-existing}] [--{M|move-aside-existing}]
0960:   [--{B|backup-suffix} SUFFIX]
0961:
0962: __END_OF_MESSAGE__
0963:
0964: $help_message[ $max_helplevel++ ] = <<'__END_OF_MESSAGE__';
0965: Pure options syntax:
0966:   rgz              --stdin-analyze      [-O*|-C] --rz-file FILE
0967:   rgz              --stdin-analyze      [-R*|-M] --rz-destination NAME
0968:   rgz              --analyze DATA       [-O*|-C] --rz-file FILE
0969:   rgz              --analyze DATA       [-R*|-M] --rz-destination NAME
0970:   rgz [-O*|-C]   --convert-file FILE    [-R*|-M] --rz-destination NAME
0971:   rgz [-R*|-M] --convert-departure NAME [-R*|-M] --rz-destination NAME
0972:   rgz [-R*|-M] --convert-departure NAME [-O*|-C] --rz-file FILE
0973:
0974:   rgz              --retrieve URL      [-O*|-C] --file FILE        [--stdout]
0975:   rgz              --retrieve URL      [-R*|-M] --destination NAME [--stdout]
0976:
0977:   rgz              --realize DATA      [-O*|-C] --file FILE        [--stdout]
0978:   rgz              --realize DATA      [-R*|-M] --destination NAME [--stdout]
0979:   rgz [-O*|-C]   --revert-file FILE    [-R*|-M] --destination NAME [--stdout]
0980:   rgz [-R*|-M] --revert-departure NAME [-R*|-M] --destination NAME [--stdout]
0981:   rgz [-R*|-M] --revert-departure NAME [-O*|-C] --file FILE        [--stdout]
0982:
0983:   * default write strategies are --overwrite and --remove-existing
0984:     for *-file and *-{departure|destination} type arguments respectively
0985:
0986: __END_OF_MESSAGE__
0987:
0988: $help_message[ $max_helplevel++ ] = <<'__END_OF_MESSAGE__';
0989: Implementation:
0990:   The `rgz' command line utility is a long-winded but mostly trivial
0991:   programme that simply preprocesses the command line for a collection of
0992:   more fundamental programmes.  It provides a forgiving layer over the
0993:   brittle interfaces provided by these lowel-level programmes.
0994:
0995: Fundamental programmes:
0996:   rz-analyze          #         data -> rz-file
0997:   rz-synthesize   #  rz-proxy + data -> synced rz-file & data
0998:   rz-realize          #         rz-file -> data
0999:
1000: This is the last help level.  See the man page for more details
1001: __END_OF_MESSAGE__
1002:
1003: if ( $help ) {
1004:     my $helplevel = $help + $verbosity;
1005:     $helplevel > $max_helplevel and $helplevel = $max_helplevel;
1006:     print @help_message[ 0 .. $helplevel - 1 ];
1007:     unless( $helplevel == $max_helplevel ) {
1008:         print "For more help run: rgz", " -h"x( $helplevel + 1 ), "\n";
1009:     }
1010: }
1011:
1012: exec_linkage();
1013:
1014: # rgz # command line tool