« back to all changes in this revision
Viewing changes to bin/pt-align
- browse files at revision 569
- compare with another revision
- download diff
- download tarball
- view history from revision 569
- Committer: Daniel Nichter
- Date: 2013-04-04 21:11:03 UTC
- mfrom: (568.1.3 version-in-all-bash-tools-bug-821502)
- Revision ID: daniel@percona.com-20130404211103-w0zppmgv7i5z5xqy
Merge version-in-all-bash-tools-bug-821502.
- files modified:
- bin/pt-align
added
removed
bin/pt-align
4
4
# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
5
5
# notices and disclaimers.
6
6
7
use strict;
8
use warnings FATAL => 'all';
9
10
# This tool is "fat-packed": most of its dependent modules are embedded
11
# in this file. Setting %INC to this file for each module makes Perl aware
12
# of this so it will not try to load the module from @INC. See the tool's
13
# documentation for a full list of dependencies.
14
BEGIN {
15
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
16
OptionParser
17
));
18
}
19
20
# ###########################################################################
21
# OptionParser package
22
# This package is a copy without comments from the original. The original
23
# with comments and its test file can be found in the Bazaar repository at,
24
# lib/OptionParser.pm
25
# t/lib/OptionParser.t
26
# See https://launchpad.net/percona-toolkit for more information.
27
# ###########################################################################
28
{
29
package OptionParser;
30
31
use strict;
32
use warnings FATAL => 'all';
33
use English qw(-no_match_vars);
34
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
35
36
use List::Util qw(max);
37
use Getopt::Long;
38
use Data::Dumper;
39
40
my $POD_link_re = '[LC]<"?([^">]+)"?>';
41
42
sub new {
43
my ( $class, %args ) = @_;
44
my @required_args = qw();
45
foreach my $arg ( @required_args ) {
46
die "I need a $arg argument" unless $args{$arg};
47
}
48
49
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
50
$program_name ||= $PROGRAM_NAME;
51
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
52
53
my %attributes = (
54
'type' => 1,
55
'short form' => 1,
56
'group' => 1,
57
'default' => 1,
58
'cumulative' => 1,
59
'negatable' => 1,
60
);
61
62
my $self = {
63
head1 => 'OPTIONS', # These args are used internally
64
skip_rules => 0, # to instantiate another Option-
65
item => '--(.*)', # Parser obj that parses the
66
attributes => \%attributes, # DSN OPTIONS section. Tools
67
parse_attributes => \&_parse_attribs, # don't tinker with these args.
68
69
%args,
70
71
strict => 1, # disabled by a special rule
72
program_name => $program_name,
73
opts => {},
74
got_opts => 0,
75
short_opts => {},
76
defaults => {},
77
groups => {},
78
allowed_groups => {},
79
errors => [],
80
rules => [], # desc of rules for --help
81
mutex => [], # rule: opts are mutually exclusive
82
atleast1 => [], # rule: at least one opt is required
83
disables => {}, # rule: opt disables other opts
84
defaults_to => {}, # rule: opt defaults to value of other opt
85
DSNParser => undef,
86
default_files => [
87
"/etc/percona-toolkit/percona-toolkit.conf",
88
"/etc/percona-toolkit/$program_name.conf",
89
"$home/.percona-toolkit.conf",
90
"$home/.$program_name.conf",
91
],
92
types => {
93
string => 's', # standard Getopt type
94
int => 'i', # standard Getopt type
95
float => 'f', # standard Getopt type
96
Hash => 'H', # hash, formed from a comma-separated list
97
hash => 'h', # hash as above, but only if a value is given
98
Array => 'A', # array, similar to Hash
99
array => 'a', # array, similar to hash
100
DSN => 'd', # DSN
101
size => 'z', # size with kMG suffix (powers of 2^10)
102
time => 'm', # time, with an optional suffix of s/h/m/d
103
},
104
};
105
106
return bless $self, $class;
107
}
108
109
sub get_specs {
110
my ( $self, $file ) = @_;
111
$file ||= $self->{file} || __FILE__;
112
my @specs = $self->_pod_to_specs($file);
113
$self->_parse_specs(@specs);
114
115
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
116
my $contents = do { local $/ = undef; <$fh> };
117
close $fh;
118
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
119
PTDEBUG && _d('Parsing DSN OPTIONS');
120
my $dsn_attribs = {
121
dsn => 1,
122
copy => 1,
123
};
124
my $parse_dsn_attribs = sub {
125
my ( $self, $option, $attribs ) = @_;
126
map {
127
my $val = $attribs->{$_};
128
if ( $val ) {
129
$val = $val eq 'yes' ? 1
130
: $val eq 'no' ? 0
131
: $val;
132
$attribs->{$_} = $val;
133
}
134
} keys %$attribs;
135
return {
136
key => $option,
137
%$attribs,
138
};
139
};
140
my $dsn_o = new OptionParser(
141
description => 'DSN OPTIONS',
142
head1 => 'DSN OPTIONS',
143
dsn => 0, # XXX don't infinitely recurse!
144
item => '\* (.)', # key opts are a single character
145
skip_rules => 1, # no rules before opts
146
attributes => $dsn_attribs,
147
parse_attributes => $parse_dsn_attribs,
148
);
149
my @dsn_opts = map {
150
my $opts = {
151
key => $_->{spec}->{key},
152
dsn => $_->{spec}->{dsn},
153
copy => $_->{spec}->{copy},
154
desc => $_->{desc},
155
};
156
$opts;
157
} $dsn_o->_pod_to_specs($file);
158
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
159
}
160
161
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
162
$self->{version} = $1;
163
PTDEBUG && _d($self->{version});
164
}
165
166
return;
167
}
168
169
sub DSNParser {
170
my ( $self ) = @_;
171
return $self->{DSNParser};
172
};
173
174
sub get_defaults_files {
175
my ( $self ) = @_;
176
return @{$self->{default_files}};
177
}
178
179
sub _pod_to_specs {
180
my ( $self, $file ) = @_;
181
$file ||= $self->{file} || __FILE__;
182
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
183
184
my @specs = ();
185
my @rules = ();
186
my $para;
187
188
local $INPUT_RECORD_SEPARATOR = '';
189
while ( $para = <$fh> ) {
190
next unless $para =~ m/^=head1 $self->{head1}/;
191
last;
192
}
193
194
while ( $para = <$fh> ) {
195
last if $para =~ m/^=over/;
196
next if $self->{skip_rules};
197
chomp $para;
198
$para =~ s/\s+/ /g;
199
$para =~ s/$POD_link_re/$1/go;
200
PTDEBUG && _d('Option rule:', $para);
201
push @rules, $para;
202
}
203
204
die "POD has no $self->{head1} section" unless $para;
205
206
do {
207
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
208
chomp $para;
209
PTDEBUG && _d($para);
210
my %attribs;
211
212
$para = <$fh>; # read next paragraph, possibly attributes
213
214
if ( $para =~ m/: / ) { # attributes
215
$para =~ s/\s+\Z//g;
216
%attribs = map {
217
my ( $attrib, $val) = split(/: /, $_);
218
die "Unrecognized attribute for --$option: $attrib"
219
unless $self->{attributes}->{$attrib};
220
($attrib, $val);
221
} split(/; /, $para);
222
if ( $attribs{'short form'} ) {
223
$attribs{'short form'} =~ s/-//;
224
}
225
$para = <$fh>; # read next paragraph, probably short help desc
226
}
227
else {
228
PTDEBUG && _d('Option has no attributes');
229
}
230
231
$para =~ s/\s+\Z//g;
232
$para =~ s/\s+/ /g;
233
$para =~ s/$POD_link_re/$1/go;
234
235
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
236
PTDEBUG && _d('Short help:', $para);
237
238
die "No description after option spec $option" if $para =~ m/^=item/;
239
240
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
241
$option = $base_option;
242
$attribs{'negatable'} = 1;
243
}
244
245
push @specs, {
246
spec => $self->{parse_attributes}->($self, $option, \%attribs),
247
desc => $para
248
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
249
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
250
};
251
}
252
while ( $para = <$fh> ) {
253
last unless $para;
254
if ( $para =~ m/^=head1/ ) {
255
$para = undef; # Can't 'last' out of a do {} block.
256
last;
257
}
258
last if $para =~ m/^=item /;
259
}
260
} while ( $para );
261
262
die "No valid specs in $self->{head1}" unless @specs;
263
264
close $fh;
265
return @specs, @rules;
266
}
267
268
sub _parse_specs {
269
my ( $self, @specs ) = @_;
270
my %disables; # special rule that requires deferred checking
271
272
foreach my $opt ( @specs ) {
273
if ( ref $opt ) { # It's an option spec, not a rule.
274
PTDEBUG && _d('Parsing opt spec:',
275
map { ($_, '=>', $opt->{$_}) } keys %$opt);
276
277
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
278
if ( !$long ) {
279
die "Cannot parse long option from spec $opt->{spec}";
280
}
281
$opt->{long} = $long;
282
283
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
284
$self->{opts}->{$long} = $opt;
285
286
if ( length $long == 1 ) {
287
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
288
$self->{short_opts}->{$long} = $long;
289
}
290
291
if ( $short ) {
292
die "Duplicate short option -$short"
293
if exists $self->{short_opts}->{$short};
294
$self->{short_opts}->{$short} = $long;
295
$opt->{short} = $short;
296
}
297
else {
298
$opt->{short} = undef;
299
}
300
301
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
302
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
303
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
304
305
$opt->{group} ||= 'default';
306
$self->{groups}->{ $opt->{group} }->{$long} = 1;
307
308
$opt->{value} = undef;
309
$opt->{got} = 0;
310
311
my ( $type ) = $opt->{spec} =~ m/=(.)/;
312
$opt->{type} = $type;
313
PTDEBUG && _d($long, 'type:', $type);
314
315
316
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
317
318
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
319
$self->{defaults}->{$long} = defined $def ? $def : 1;
320
PTDEBUG && _d($long, 'default:', $def);
321
}
322
323
if ( $long eq 'config' ) {
324
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
325
}
326
327
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
328
$disables{$long} = $dis;
329
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
330
}
331
332
$self->{opts}->{$long} = $opt;
333
}
334
else { # It's an option rule, not a spec.
335
PTDEBUG && _d('Parsing rule:', $opt);
336
push @{$self->{rules}}, $opt;
337
my @participants = $self->_get_participants($opt);
338
my $rule_ok = 0;
339
340
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
341
$rule_ok = 1;
342
push @{$self->{mutex}}, \@participants;
343
PTDEBUG && _d(@participants, 'are mutually exclusive');
344
}
345
if ( $opt =~ m/at least one|one and only one/ ) {
346
$rule_ok = 1;
347
push @{$self->{atleast1}}, \@participants;
348
PTDEBUG && _d(@participants, 'require at least one');
349
}
350
if ( $opt =~ m/default to/ ) {
351
$rule_ok = 1;
352
$self->{defaults_to}->{$participants[0]} = $participants[1];
353
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
354
}
355
if ( $opt =~ m/restricted to option groups/ ) {
356
$rule_ok = 1;
357
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
358
my @groups = split(',', $groups);
359
%{$self->{allowed_groups}->{$participants[0]}} = map {
360
s/\s+//;
361
$_ => 1;
362
} @groups;
363
}
364
if( $opt =~ m/accepts additional command-line arguments/ ) {
365
$rule_ok = 1;
366
$self->{strict} = 0;
367
PTDEBUG && _d("Strict mode disabled by rule");
368
}
369
370
die "Unrecognized option rule: $opt" unless $rule_ok;
371
}
372
}
373
374
foreach my $long ( keys %disables ) {
375
my @participants = $self->_get_participants($disables{$long});
376
$self->{disables}->{$long} = \@participants;
377
PTDEBUG && _d('Option', $long, 'disables', @participants);
378
}
379
380
return;
381
}
382
383
sub _get_participants {
384
my ( $self, $str ) = @_;
385
my @participants;
386
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
387
die "Option --$long does not exist while processing rule $str"
388
unless exists $self->{opts}->{$long};
389
push @participants, $long;
390
}
391
PTDEBUG && _d('Participants for', $str, ':', @participants);
392
return @participants;
393
}
394
395
sub opts {
396
my ( $self ) = @_;
397
my %opts = %{$self->{opts}};
398
return %opts;
399
}
400
401
sub short_opts {
402
my ( $self ) = @_;
403
my %short_opts = %{$self->{short_opts}};
404
return %short_opts;
405
}
406
407
sub set_defaults {
408
my ( $self, %defaults ) = @_;
409
$self->{defaults} = {};
410
foreach my $long ( keys %defaults ) {
411
die "Cannot set default for nonexistent option $long"
412
unless exists $self->{opts}->{$long};
413
$self->{defaults}->{$long} = $defaults{$long};
414
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
415
}
416
return;
417
}
418
419
sub get_defaults {
420
my ( $self ) = @_;
421
return $self->{defaults};
422
}
423
424
sub get_groups {
425
my ( $self ) = @_;
426
return $self->{groups};
427
}
428
429
sub _set_option {
430
my ( $self, $opt, $val ) = @_;
431
my $long = exists $self->{opts}->{$opt} ? $opt
432
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
433
: die "Getopt::Long gave a nonexistent option: $opt";
434
435
$opt = $self->{opts}->{$long};
436
if ( $opt->{is_cumulative} ) {
437
$opt->{value}++;
438
}
439
else {
440
$opt->{value} = $val;
441
}
442
$opt->{got} = 1;
443
PTDEBUG && _d('Got option', $long, '=', $val);
444
}
445
446
sub get_opts {
447
my ( $self ) = @_;
448
449
foreach my $long ( keys %{$self->{opts}} ) {
450
$self->{opts}->{$long}->{got} = 0;
451
$self->{opts}->{$long}->{value}
452
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
453
: $self->{opts}->{$long}->{is_cumulative} ? 0
454
: undef;
455
}
456
$self->{got_opts} = 0;
457
458
$self->{errors} = [];
459
460
if ( @ARGV && $ARGV[0] eq "--config" ) {
461
shift @ARGV;
462
$self->_set_option('config', shift @ARGV);
463
}
464
if ( $self->has('config') ) {
465
my @extra_args;
466
foreach my $filename ( split(',', $self->get('config')) ) {
467
eval {
468
push @extra_args, $self->_read_config_file($filename);
469
};
470
if ( $EVAL_ERROR ) {
471
if ( $self->got('config') ) {
472
die $EVAL_ERROR;
473
}
474
elsif ( PTDEBUG ) {
475
_d($EVAL_ERROR);
476
}
477
}
478
}
479
unshift @ARGV, @extra_args;
480
}
481
482
Getopt::Long::Configure('no_ignore_case', 'bundling');
483
GetOptions(
484
map { $_->{spec} => sub { $self->_set_option(@_); } }
485
grep { $_->{long} ne 'config' } # --config is handled specially above.
486
values %{$self->{opts}}
487
) or $self->save_error('Error parsing options');
488
489
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
490
if ( $self->{version} ) {
491
print $self->{version}, "\n";
492
}
493
else {
494
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
495
}
496
exit 1;
497
}
498
499
if ( @ARGV && $self->{strict} ) {
500
$self->save_error("Unrecognized command-line options @ARGV");
501
}
502
503
foreach my $mutex ( @{$self->{mutex}} ) {
504
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
505
if ( @set > 1 ) {
506
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
507
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
508
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
509
. ' are mutually exclusive.';
510
$self->save_error($err);
511
}
512
}
513
514
foreach my $required ( @{$self->{atleast1}} ) {
515
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
516
if ( @set == 0 ) {
517
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
518
@{$required}[ 0 .. scalar(@$required) - 2] )
519
.' or --'.$self->{opts}->{$required->[-1]}->{long};
520
$self->save_error("Specify at least one of $err");
521
}
522
}
523
524
$self->_check_opts( keys %{$self->{opts}} );
525
$self->{got_opts} = 1;
526
return;
527
}
528
529
sub _check_opts {
530
my ( $self, @long ) = @_;
531
my $long_last = scalar @long;
532
while ( @long ) {
533
foreach my $i ( 0..$#long ) {
534
my $long = $long[$i];
535
next unless $long;
536
my $opt = $self->{opts}->{$long};
537
if ( $opt->{got} ) {
538
if ( exists $self->{disables}->{$long} ) {
539
my @disable_opts = @{$self->{disables}->{$long}};
540
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
541
PTDEBUG && _d('Unset options', @disable_opts,
542
'because', $long,'disables them');
543
}
544
545
if ( exists $self->{allowed_groups}->{$long} ) {
546
547
my @restricted_groups = grep {
548
!exists $self->{allowed_groups}->{$long}->{$_}
549
} keys %{$self->{groups}};
550
551
my @restricted_opts;
552
foreach my $restricted_group ( @restricted_groups ) {
553
RESTRICTED_OPT:
554
foreach my $restricted_opt (
555
keys %{$self->{groups}->{$restricted_group}} )
556
{
557
next RESTRICTED_OPT if $restricted_opt eq $long;
558
push @restricted_opts, $restricted_opt
559
if $self->{opts}->{$restricted_opt}->{got};
560
}
561
}
562
563
if ( @restricted_opts ) {
564
my $err;
565
if ( @restricted_opts == 1 ) {
566
$err = "--$restricted_opts[0]";
567
}
568
else {
569
$err = join(', ',
570
map { "--$self->{opts}->{$_}->{long}" }
571
grep { $_ }
572
@restricted_opts[0..scalar(@restricted_opts) - 2]
573
)
574
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
575
}
576
$self->save_error("--$long is not allowed with $err");
577
}
578
}
579
580
}
581
elsif ( $opt->{is_required} ) {
582
$self->save_error("Required option --$long must be specified");
583
}
584
585
$self->_validate_type($opt);
586
if ( $opt->{parsed} ) {
587
delete $long[$i];
588
}
589
else {
590
PTDEBUG && _d('Temporarily failed to parse', $long);
591
}
592
}
593
594
die "Failed to parse options, possibly due to circular dependencies"
595
if @long == $long_last;
596
$long_last = @long;
597
}
598
599
return;
600
}
601
602
sub _validate_type {
603
my ( $self, $opt ) = @_;
604
return unless $opt;
605
606
if ( !$opt->{type} ) {
607
$opt->{parsed} = 1;
608
return;
609
}
610
611
my $val = $opt->{value};
612
613
if ( $val && $opt->{type} eq 'm' ) { # type time
614
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
615
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
616
if ( !$suffix ) {
617
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
618
$suffix = $s || 's';
619
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
620
$opt->{long}, '(value:', $val, ')');
621
}
622
if ( $suffix =~ m/[smhd]/ ) {
623
$val = $suffix eq 's' ? $num # Seconds
624
: $suffix eq 'm' ? $num * 60 # Minutes
625
: $suffix eq 'h' ? $num * 3600 # Hours
626
: $num * 86400; # Days
627
$opt->{value} = ($prefix || '') . $val;
628
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
629
}
630
else {
631
$self->save_error("Invalid time suffix for --$opt->{long}");
632
}
633
}
634
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
635
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
636
my $prev = {};
637
my $from_key = $self->{defaults_to}->{ $opt->{long} };
638
if ( $from_key ) {
639
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
640
if ( $self->{opts}->{$from_key}->{parsed} ) {
641
$prev = $self->{opts}->{$from_key}->{value};
642
}
643
else {
644
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
645
$from_key, 'parsed');
646
return;
647
}
648
}
649
my $defaults = $self->{DSNParser}->parse_options($self);
650
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
651
}
652
elsif ( $val && $opt->{type} eq 'z' ) { # type size
653
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
654
$self->_parse_size($opt, $val);
655
}
656
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
657
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
658
}
659
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
660
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
661
}
662
else {
663
PTDEBUG && _d('Nothing to validate for option',
664
$opt->{long}, 'type', $opt->{type}, 'value', $val);
665
}
666
667
$opt->{parsed} = 1;
668
return;
669
}
670
671
sub get {
672
my ( $self, $opt ) = @_;
673
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
674
die "Option $opt does not exist"
675
unless $long && exists $self->{opts}->{$long};
676
return $self->{opts}->{$long}->{value};
677
}
678
679
sub got {
680
my ( $self, $opt ) = @_;
681
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
682
die "Option $opt does not exist"
683
unless $long && exists $self->{opts}->{$long};
684
return $self->{opts}->{$long}->{got};
685
}
686
687
sub has {
688
my ( $self, $opt ) = @_;
689
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
690
return defined $long ? exists $self->{opts}->{$long} : 0;
691
}
692
693
sub set {
694
my ( $self, $opt, $val ) = @_;
695
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
696
die "Option $opt does not exist"
697
unless $long && exists $self->{opts}->{$long};
698
$self->{opts}->{$long}->{value} = $val;
699
return;
700
}
701
702
sub save_error {
703
my ( $self, $error ) = @_;
704
push @{$self->{errors}}, $error;
705
return;
706
}
707
708
sub errors {
709
my ( $self ) = @_;
710
return $self->{errors};
711
}
712
713
sub usage {
714
my ( $self ) = @_;
715
warn "No usage string is set" unless $self->{usage}; # XXX
716
return "Usage: " . ($self->{usage} || '') . "\n";
717
}
718
719
sub descr {
720
my ( $self ) = @_;
721
warn "No description string is set" unless $self->{description}; # XXX
722
my $descr = ($self->{description} || $self->{program_name} || '')
723
. " For more details, please use the --help option, "
724
. "or try 'perldoc $PROGRAM_NAME' "
725
. "for complete documentation.";
726
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
727
unless $ENV{DONT_BREAK_LINES};
728
$descr =~ s/ +$//mg;
729
return $descr;
730
}
731
732
sub usage_or_errors {
733
my ( $self, $file, $return ) = @_;
734
$file ||= $self->{file} || __FILE__;
735
736
if ( !$self->{description} || !$self->{usage} ) {
737
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
738
my %synop = $self->_parse_synopsis($file);
739
$self->{description} ||= $synop{description};
740
$self->{usage} ||= $synop{usage};
741
PTDEBUG && _d("Description:", $self->{description},
742
"\nUsage:", $self->{usage});
743
}
744
745
if ( $self->{opts}->{help}->{got} ) {
746
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
747
exit 0 unless $return;
748
}
749
elsif ( scalar @{$self->{errors}} ) {
750
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
751
exit 1 unless $return;
752
}
753
754
return;
755
}
756
757
sub print_errors {
758
my ( $self ) = @_;
759
my $usage = $self->usage() . "\n";
760
if ( (my @errors = @{$self->{errors}}) ) {
761
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
762
. "\n";
763
}
764
return $usage . "\n" . $self->descr();
765
}
766
767
sub print_usage {
768
my ( $self ) = @_;
769
die "Run get_opts() before print_usage()" unless $self->{got_opts};
770
my @opts = values %{$self->{opts}};
771
772
my $maxl = max(
773
map {
774
length($_->{long}) # option long name
775
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
776
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
777
}
778
@opts);
779
780
my $maxs = max(0,
781
map {
782
length($_)
783
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
784
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
785
}
786
values %{$self->{short_opts}});
787
788
my $lcol = max($maxl, ($maxs + 3));
789
my $rcol = 80 - $lcol - 6;
790
my $rpad = ' ' x ( 80 - $rcol );
791
792
$maxs = max($lcol - 3, $maxs);
793
794
my $usage = $self->descr() . "\n" . $self->usage();
795
796
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
797
push @groups, 'default';
798
799
foreach my $group ( reverse @groups ) {
800
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
801
foreach my $opt (
802
sort { $a->{long} cmp $b->{long} }
803
grep { $_->{group} eq $group }
804
@opts )
805
{
806
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
807
my $short = $opt->{short};
808
my $desc = $opt->{desc};
809
810
$long .= $opt->{type} ? "=$opt->{type}" : "";
811
812
if ( $opt->{type} && $opt->{type} eq 'm' ) {
813
my ($s) = $desc =~ m/\(suffix (.)\)/;
814
$s ||= 's';
815
$desc =~ s/\s+\(suffix .\)//;
816
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
817
. "d=days; if no suffix, $s is used.";
818
}
819
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
820
$desc =~ s/ +$//mg;
821
if ( $short ) {
822
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
823
}
824
else {
825
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
826
}
827
}
828
}
829
830
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
831
832
if ( (my @rules = @{$self->{rules}}) ) {
833
$usage .= "\nRules:\n\n";
834
$usage .= join("\n", map { " $_" } @rules) . "\n";
835
}
836
if ( $self->{DSNParser} ) {
837
$usage .= "\n" . $self->{DSNParser}->usage();
838
}
839
$usage .= "\nOptions and values after processing arguments:\n\n";
840
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
841
my $val = $opt->{value};
842
my $type = $opt->{type} || '';
843
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
844
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
845
: !defined $val ? '(No value)'
846
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
847
: $type =~ m/H|h/ ? join(',', sort keys %$val)
848
: $type =~ m/A|a/ ? join(',', @$val)
849
: $val;
850
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
851
}
852
return $usage;
853
}
854
855
sub prompt_noecho {
856
shift @_ if ref $_[0] eq __PACKAGE__;
857
my ( $prompt ) = @_;
858
local $OUTPUT_AUTOFLUSH = 1;
859
print $prompt
860
or die "Cannot print: $OS_ERROR";
861
my $response;
862
eval {
863
require Term::ReadKey;
864
Term::ReadKey::ReadMode('noecho');
865
chomp($response = <STDIN>);
866
Term::ReadKey::ReadMode('normal');
867
print "\n"
868
or die "Cannot print: $OS_ERROR";
869
};
870
if ( $EVAL_ERROR ) {
871
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
872
}
873
return $response;
874
}
875
876
sub _read_config_file {
877
my ( $self, $filename ) = @_;
878
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
879
my @args;
880
my $prefix = '--';
881
my $parse = 1;
882
883
LINE:
884
while ( my $line = <$fh> ) {
885
chomp $line;
886
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
887
$line =~ s/\s+#.*$//g;
888
$line =~ s/^\s+|\s+$//g;
889
if ( $line eq '--' ) {
890
$prefix = '';
891
$parse = 0;
892
next LINE;
893
}
894
if ( $parse
895
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
896
) {
897
push @args, grep { defined $_ } ("$prefix$opt", $arg);
898
}
899
elsif ( $line =~ m/./ ) {
900
push @args, $line;
901
}
902
else {
903
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
904
}
905
}
906
close $fh;
907
return @args;
908
}
909
910
sub read_para_after {
911
my ( $self, $file, $regex ) = @_;
912
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
913
local $INPUT_RECORD_SEPARATOR = '';
914
my $para;
915
while ( $para = <$fh> ) {
916
next unless $para =~ m/^=pod$/m;
917
last;
918
}
919
while ( $para = <$fh> ) {
920
next unless $para =~ m/$regex/;
921
last;
922
}
923
$para = <$fh>;
924
chomp($para);
925
close $fh or die "Can't close $file: $OS_ERROR";
926
return $para;
927
}
928
929
sub clone {
930
my ( $self ) = @_;
931
932
my %clone = map {
933
my $hashref = $self->{$_};
934
my $val_copy = {};
935
foreach my $key ( keys %$hashref ) {
936
my $ref = ref $hashref->{$key};
937
$val_copy->{$key} = !$ref ? $hashref->{$key}
938
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
939
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
940
: $hashref->{$key};
941
}
942
$_ => $val_copy;
943
} qw(opts short_opts defaults);
944
945
foreach my $scalar ( qw(got_opts) ) {
946
$clone{$scalar} = $self->{$scalar};
947
}
948
949
return bless \%clone;
950
}
951
952
sub _parse_size {
953
my ( $self, $opt, $val ) = @_;
954
955
if ( lc($val || '') eq 'null' ) {
956
PTDEBUG && _d('NULL size for', $opt->{long});
957
$opt->{value} = 'null';
958
return;
959
}
960
961
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
962
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
963
if ( defined $num ) {
964
if ( $factor ) {
965
$num *= $factor_for{$factor};
966
PTDEBUG && _d('Setting option', $opt->{y},
967
'to num', $num, '* factor', $factor);
968
}
969
$opt->{value} = ($pre || '') . $num;
970
}
971
else {
972
$self->save_error("Invalid size for --$opt->{long}: $val");
973
}
974
return;
975
}
976
977
sub _parse_attribs {
978
my ( $self, $option, $attribs ) = @_;
979
my $types = $self->{types};
980
return $option
981
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
982
. ($attribs->{'negatable'} ? '!' : '' )
983
. ($attribs->{'cumulative'} ? '+' : '' )
984
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
985
}
986
987
sub _parse_synopsis {
988
my ( $self, $file ) = @_;
989
$file ||= $self->{file} || __FILE__;
990
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
991
992
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
993
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
994
my $para;
995
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
996
die "$file does not contain a SYNOPSIS section" unless $para;
997
my @synop;
998
for ( 1..2 ) { # 1 for the usage, 2 for the description
999
my $para = <$fh>;
1000
push @synop, $para;
1001
}
1002
close $fh;
1003
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
1004
my ($usage, $desc) = @synop;
1005
die "The SYNOPSIS section in $file is not formatted properly"
1006
unless $usage && $desc;
1007
1008
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
1009
chomp $usage;
1010
1011
$desc =~ s/\n/ /g;
1012
$desc =~ s/\s{2,}/ /g;
1013
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
1014
$desc =~ s/\s+$//;
1015
1016
return (
1017
description => $desc,
1018
usage => $usage,
1019
);
1020
};
1021
1022
sub set_vars {
1023
my ($self, $file) = @_;
1024
$file ||= $self->{file} || __FILE__;
1025
1026
my %user_vars;
1027
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
1028
if ( $user_vars ) {
1029
foreach my $var_val ( @$user_vars ) {
1030
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1031
die "Invalid --set-vars value: $var_val\n" unless $var && $val;
1032
$user_vars{$var} = {
1033
val => $val,
1034
default => 0,
1035
};
1036
}
1037
}
1038
1039
my %default_vars;
1040
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
1041
if ( $default_vars ) {
1042
%default_vars = map {
1043
my $var_val = $_;
1044
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
1045
die "Invalid --set-vars value: $var_val\n" unless $var && $val;
1046
$var => {
1047
val => $val,
1048
default => 1,
1049
};
1050
} split("\n", $default_vars);
1051
}
1052
1053
my %vars = (
1054
%default_vars, # first the tool's defaults
1055
%user_vars, # then the user's which overwrite the defaults
1056
);
1057
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
1058
return \%vars;
1059
}
1060
1061
sub _d {
1062
my ($package, undef, $line) = caller 0;
1063
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1064
map { defined $_ ? $_ : 'undef' }
1065
@_;
1066
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1067
}
1068
1069
if ( PTDEBUG ) {
1070
print '# ', $^X, ' ', $], "\n";
1071
if ( my $uname = `uname -a` ) {
1072
$uname =~ s/\s+/ /g;
1073
print "# $uname\n";
1074
}
1075
print '# Arguments: ',
1076
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
1077
}
1078
1079
1;
1080
}
1081
# ###########################################################################
1082
# End OptionParser package
1083
# ###########################################################################
1084
7
1085
# ###########################################################################
8
1086
# This is a combination of modules and programs in one -- a runnable module.
9
1087
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
25
1103
26
1104
@ARGV = @_; # set global ARGV for this package
27
1105
1106
my $o = OptionParser->new();
1107
$o->get_specs();
1108
$o->get_opts();
1109
$o->usage_or_errors();
1110
28
1111
# Read all lines
29
1112
my @lines;
30
1113
my %word_count;
130
1213
131
1214
=head1 OPTIONS
132
1215
133
This tool does not have any command-line options.
1216
=over
1217
1218
=item --help
1219
1220
Show help and exit.
1221
1222
=item --version
1223
1224
Show version and exit.
1225
1226
=back
134
1227
135
1228
=head1 ENVIRONMENT
136
1229
Loggerhead is a web-based interface for Breezy
Version: 2.0.1