001:
002:
003: use strict;
004: use Getopt::Long;
005:
006: require "GetoptGlue.pl";
007:
008: package GetoptAnalyze;
009:
010:
011:
012: my $verbosity = 0;
013: sub verbosity { $verbosity }
014: my $debug = 0;
015: sub debug { $debug }
016:
017: my %exclusion = ();
018: sub exclusive {
019: my $x = shift;
020: local( $" ) = " ";
021: if ( exists $exclusion{ $x } ) {
022: die "Mutually exclusive: $exclusion{ $x } and --@_\n";
023: } else { $exclusion{ $x } = "--@_"; }
024: }
025:
026: my $backup_suffix = "~";
027: my $write_strategy = undef;
028: my %write_strategy;
029: @write_strategy{ 'departure', 'file', 'destination' } = ( 1, 0, 1 );
030: sub write_strategy {
031: if ( defined $write_strategy ) {
032: $write_strategy{ $_[0] } = $write_strategy;
033: if ( $_[0] eq 'file') {
034: $write_strategy & -3 and die "Inconsistent write/backup mode\n";
035: } else {
036: $write_strategy & -3 or die "Inconsistent write/backup mode\n";
037: }
038: undef $write_strategy;
039: }
040: }
041:
042: my $conversion;
043:
044:
045:
046: my $differh; sub differh { my $h = shift; $differh->( @_ ); }
047: my %backh; sub backh { my $h = shift; $backh{ $h }->( @_ ); }
048: my %openh; sub openh { my $h = shift; $openh{ $h }->( @_ ); }
049: my $closeh; sub closeh { $closeh->( @_ ); }
050: my $converth; sub converth { $converth->( @_ ); }
051:
052: $differh = sub {};
053: $backh{ departure } = sub {};
054: $backh{ destination } = sub {};
055: $closeh = GetoptGlue::closer();
056: $converth = sub { 0 };
057:
058:
059:
060: my @options = (
061: 'verbose+' => \$verbosity,
062: 'debug+' => \$debug,
063:
064: 'overwrite' => sub { $write_strategy = 0 },
065: 'remove-existing' => sub { $write_strategy = 1 },
066: 'copy-aside-and-overwrite' => sub { $write_strategy = 2 },
067: 'move-aside-existing' => sub { $write_strategy = 3 },
068:
069: 'backup-suffix=s' => \$backup_suffix,
070:
071: 'stdin-analyze' =>
072: sub {
073: exclusive( analyze => 'stdin-analyze' );
074: $openh{ departure } = GetoptGlue::opener( "<-", "" );
075: },
076:
077: 'analyze=s' =>
078: sub {
079: exclusive( analyze => @_ );
080: $openh{ departure } = GetoptGlue::opener( "<", $_[1] );
081: },
082:
083: 'convert-file=s' =>
084: sub {
085: exclusive( analyze => @_ );
086: exclusive( 'concentrated-file' => @_ );
087: write_strategy( file => @_ );
088: $backh{ departure } = GetoptGlue::backer(
089: $write_strategy{ file }, $_[1], $backup_suffix
090: );
091: $openh{ departure } = GetoptGlue::opener( "+<", $_[1] );
092: if ( defined $conversion ) {
093: $converth = GetoptGlue::converter( $_[1], $conversion );
094: }
095: else {
096: $converth = GetoptGlue::converter( $_[1] );
097: $conversion = $_[1];
098: }
099: },
100:
101: 'convert-departure=s' =>
102: sub {
103: exclusive( analyze => @_ );
104: write_strategy( departure => @_ );
105: $backh{ departure } = GetoptGlue::backer(
106: $write_strategy{ departure }, $_[1], $backup_suffix
107: );
108: $openh{ departure } = GetoptGlue::opener( "<", $_[1] );
109: if ( not defined $openh{ destination } ) {
110: $openh{ destination } = GetoptGlue::opener( ">", $_[1] );
111: }
112: },
113:
114: 'concentrated-file=s' =>
115: sub {
116: exclusive( concentrated => @_ );
117: exclusive( 'concentrated-file' => @_ );
118: write_strategy( file => @_ );
119: $differh = GetoptGlue::differ( $_[1] );
120: $backh{ destination } = GetoptGlue::backer(
121: $write_strategy{ file }, $_[1], $backup_suffix
122: );
123: $openh{ destination } = GetoptGlue::opener( ">", $_[1] );
124: },
125:
126: 'concentrated-destination=s' =>
127: sub {
128: exclusive( concentrated => @_ );
129: write_strategy( destination => @_ );
130: $differh = GetoptGlue::differ( $_[1] );
131: $backh{ destination } = GetoptGlue::backer(
132: $write_strategy{ destination }, $_[1], $backup_suffix
133: );
134: $openh{ destination } = GetoptGlue::opener( ">", $_[1] );
135: if ( defined $conversion ) {
136: $converth = GetoptGlue::converter( $conversion, $_[1] );
137: }
138: else {
139: $conversion = $_[1];
140: }
141: },
142: );
143:
144:
145:
146: my $parser = new Getopt::Long::Parser;
147: $parser->configure( 'no_permute' );
148: $parser->getoptions( @options ) or die "Error in arguments\n";
149: if ( @ARGV ) {
150: die "Unparsable arguments specified\n";
151: }
152: unless ( $openh{ departure } and ( $openh{ destination } or $converth ) ) {
153: die "Incomplete arguments specified\n";
154: }
155:
156:
157:
158: 1;