0001:
0002:
0003:
0004:
0005:
0006: {
0007: my @programme;
0008: my @linkage;
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;
0042:
0043:
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:
0062:
0063:
0064:
0065:
0066:
0067:
0068:
0069: s{(?:^|(?<=^\.)|(?<=/)|(?<=/\.))\.$}{\./};
0070:
0071: s{(/\.?)+/}{/}g;
0072: s{^\./}{};
0073:
0074: while ( s{/(?!\.\./)[^/]+/\.\./}{/}g ) {};
0075: s{^(?!\.\./)[^/]+/\.\./}{};
0076:
0077: return $_;
0078: }
0079:
0080:
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;
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:
0234:
0235:
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:
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: );
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: );
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: );
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: );
0561: }
0562: sane_default( concentrated => );
0563: },
0564: );
0565:
0566:
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:
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:
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:
0766:
0767: my $parser = new Getopt::Long::Parser;
0768:
0769:
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:
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:
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:
0814:
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:
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:
0838:
0839: if ( @ARGV ) {
0840: print STDERR "Remaining unparsable arguments\n";
0841: last commandline;
0842: }
0843:
0844:
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:
0859:
0860: set_linkage();
0861: }
0862:
0863:
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,
0873: 777222777,
0874: 999555999,
0875: 1<<16,
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
0907: rgz synthesize http://elsewhere.net/Packages.rz
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
0929: rgz revert Packages.rz
0930: rgz realize Packages.rz
0931: rgz cat Packages.rz
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
0997: rz-synthesize
0998: rz-realize
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: