我正在尝试编辑Perl程序以使用Get Options和Pod Usage模块。当我试图这样做时，它似乎打破了它。第一个代码示例是有效的原始文件，第二个代码示例是不起作用的已编辑版本。
#!/usr/bin/env perl
use strict;
use warnings;
use 5.012;
use File::Basename;
use FindBin;
use lib "$FindBin::Bin/../../lib";
use TNT::Utils::Crypto;
use TNT::Utils::DB;
$|=1 if _running_interactively(); # autoflush STDOUT for better status feedback
my $survey = shift or die "Must provide survey name";
my $db_type = shift or die "Must provide database type (mysql|prod|sqlite|test)";
my $mode = shift or die "Must provide mode 'NORMAL' or 'ROLLOVER'";
my @files = (shift) or die "Must provide file names to load or 'FAKE' for fake data";
my $qaname = shift;
my $schema = TNT::Utils::DB->get_schema( env => $db_type, survey => 'ufo', qaname => $qaname );
my $data_rs = $schema->resultset('Data');
my $respondents_rs = $schema->resultset('Respondents');
my $units_rs = $schema->resultset('Units');
my $users_rs = $schema->resultset('Users');
if ( $mode eq 'ROLLOVER' ) {
$data_rs->delete();
$units_rs->delete();
$respondents_rs->delete();
$users_rs->update( { created_for_survey => 'DISABLED' } );
}
my $rec_1_cnt = 0;
my $rec_2_cnt = 0;
my $rec_3_cnt = 0;
my $rec_4_cnt = 0;
my $rec_5_cnt = 0;
my $line_count = 0;
#my $file = "states.txt";
my $file = "steps_standard_state_values.txt";
my $state_file = "$FindBin::Bin/../../doc/ufo/$file";
die "can't find '$file'!\n\n" unless -e $state_file;
my @states;
my $delimiter = ":";
open my $FILE, '<', $state_file
or die "can't open $state_file: $!";
while ( my $line = <$FILE> ) {
chomp $line;
push @states, _make_state_record($line, $delimiter);
}
close $FILE or die "couldn't close $state_file: $!";
my $record1_metadata = {};
foreach my $file ( @files ) {
my $fh = _get_file_handle( $survey , $file );
my $display_name = fileparse( $file );
chomp( my $line = <$fh> );
my $current_id = _get_id($line);
my @buffer = ( $line );
$schema->txn_begin;
my $count = 0;
while ( $line = <$fh> ) {
chomp($line);
my $id = _get_id( $line );
if ( $id eq $current_id ) {
push @buffer, $line;
}
else {
_process_buffer( $survey , @buffer );
if ( _running_interactively() ) {
printf "\n [LOADING %20s] %6d" , $display_name , $count unless $count % 50;
print '.';
$count++;
}
@buffer = ( $line );
$current_id = $id;
}
}
_process_buffer( $survey , @buffer);
close( $fh );
$schema->txn_commit;
}
print "\n\nRecords Loaded.\n";
print "\nRecord Type 1: $rec_1_cnt\n";
print "\nRecord Type 2: $rec_2_cnt\n";
print "\nRecord Type 3: $rec_3_cnt\n";
print "\nRecord Type 4: $rec_4_cnt\n";
print "\nRecord Type 5: $rec_5_cnt\n";
print "\n" x 3;
sub _get_file_handle {
my( $survey , $file ) = @_;
$file = "./script/$survey/fake-label.dat"
if ( $file eq 'FAKE' );
open( my $IN , '<' , $file ) or die "$file ($!)";
return $IN;
}
sub _get_id {
my( $id ) = shift =~ /^.{19}(.{16})/ ;
return $id;
}
sub _process_buffer {
my( $survey , @buffer ) = @_;
my( %data , %metadata , %priordata );
my $common_regex = qr/^(.{4}).(.{6}).(.{6}).(.{16}).(...).(.{6}).(..)/;
my @common_fields = qw(mcstype survey statp id colcde alpha mgpcde);
@metadata{@common_fields} = $buffer[0] =~ $common_regex
or die "Something blew up parsing the common fields:\n$_";
%metadata = map { $_ => _trim_whitespace( $metadata{$_} ) } keys %metadata;
my( $leading_metadata ) = $buffer[0] =~ /^(.{35})/;
my $leading_metadata_re = qr/^$leading_metadata/;
my %seen = ( 2 => 0 , 4 => 0 );
foreach my $record (@buffer) {
my ( $record_type ) = $record =~ /^.{50}(.)/;
unless ( $record =~ $leading_metadata_re ) {
printf STDERR "Non-matching leading metadata -- SKIPPING!\n%s\n%s" ,
$record , $leading_metadata_re;
return;
}
$line_count++;
given($record_type) {
when (1) {
my $rec1_regex = qr/^.{59}.{6}(.{6}).(..).(....).(.{6})...(.{6})(.{36})(.{36})(.{36})(.{36})(.{36})(.{24})(..)(.{5})(.{0,4})/;
my @rec1_fields = qw(alpha mgpcde numids statp survey survdef attn name1 name2 street city state zip zip4);
my %captures;
@captures{@rec1_fields} = $record =~ $rec1_regex
or die "Something blew up parsing record type 1:\n$_";
%captures = map { $_ => _trim_whitespace( $captures{$_} ) } keys %captures;
die "Got a buffer size greater than 1 while parsing record type 1:\n$_"
unless ( scalar @buffer == 1 );
$record1_metadata = \%captures;
$rec_1_cnt++;
return;
}
when (2) {
$seen{2}++;
my $rec2_regex = qr/^.{59}(.{11})(...)(..)(....).(.).{36}(..)....(.).{19}(.{10})(.{36})(.{36})(.{36})(.{36})(.{36})(.{24})(..)(.{5})(.{0,4})/;
my @rec2_fields = qw(short_id chksurv sortfild statp_4 chkdgt type colnum form survdef attn name1 name2 street city state zip zip4);
my %captures;
@captures{@rec2_fields} = $record =~ $rec2_regex
or die "Something blew up parsing record type 2:\n$_" . "\n\nXXX-> Near line $line_count";
map {
my $value = _trim_whitespace( $captures{$_} );
die "Dupe metadata seen for key '$_'!" if( $metadata{$_} );
$metadata{$_} = $value;
} keys %captures;
$rec_2_cnt++;
}
when (3) {
my $rec3_regex = qr/^.{59}(.{5}).(..).(.{13})/;
my @rec3_fields = qw(key rel_statp value);
my %captures;
@captures{@rec3_fields} = $record =~ $rec3_regex
or die "Something blew up parsing record type 3:\n$_";
%captures = map { $_ => _trim_whitespace( $captures{$_} ) } keys %captures;
$priordata{$captures{rel_statp}}{$captures{key}} = $captures{value};
$rec_3_cnt++;
}
when (4) {
$seen{4}++;
my $rec4_regex = qr/^.{59}(.{11}).(.{8}).?(.{0,60}).?(.{0,60})/;
my @rec4_fields = qw(username password url email);
my %captures;
@captures{@rec4_fields} = $record =~ $rec4_regex
or die "Something blew up parsing record type 4:\n$_";
map {
my $value = _trim_whitespace( $captures{$_} );
die "Dupe metadata seen for key '$_'!" if( $metadata{$_} );
$metadata{$_} = $value;
} keys %captures;
$rec_4_cnt++;
}
when (5) {
my $rec5_regex = qr/^.{59}(.{8})..{1,4}.?(.*)/;
my @rec5_fields = qw/ name value /;
my %captures;
@captures{@rec5_fields} = $record =~ $rec5_regex
or die "Something blew up parsing record type 5:\n$_";
%captures = map { $_ => _trim_whitespace( $captures{$_} ) } keys %captures;
die "Dupe data seen for key '$captures{name}'!"
if( $data{$captures{name}} );
$data{$captures{name}} = $captures{value};
$rec_5_cnt++;
}
}
}
unless (($seen{2} == 1 ) and ( $seen{4} == 1 )) {
printf STDERR "\n\nRecord for ID %s doesn't have all required field types:\n" , $metadata{id};
printf STDERR " Need 1 type 2 record; saw %d\n" , $seen{2} || 0;
printf STDERR " Need 1 type 4 record; saw %d\n" , $seen{4} || 0;
return;
}
foreach ( qw/ username password / ) {
if ( length( $metadata{$_} ) < 1 ) {
printf STDERR "SKIPPING id %s -- Can't have a blank %s\n" , $metadata{id} , $_;
return;
}
}
my $user = _find_or_create_user( $metadata{username} ,
$metadata{password} ,
$survey );
my $respondent = _find_or_create_respondent( $user->uid ,
$metadata{alpha} ,
$metadata{mgpcde} ,
$metadata{id} );
my $unit = _create_unit( $respondent->rid ,
\%metadata ,
\%data ,
\%priordata );
_create_data_table_entry( $respondent->rid ,
$unit->uid ,
\%metadata ,
\%data ,
\%priordata );
}
#################################################
sub _trim_whitespace {
my( $data ) = @_;
$data =~ s/\s*$//;
$data =~ s/^\s*//;
return $data;
}
sub _find_or_create_user {
my( $user , $pass , $survey ) = @_;
my $u = $users_rs->find_or_create({
username => $user,
password => TNT::Utils::Crypto->make_password_hash( $pass ),
#confirmation => TNT::Utils::Crypto->make_password_hash( rand(1000) ),
timestamp => time(),
created_for_survey => uc( $survey ),
status => 1,
#qid => 0,
#answer => '',
});
$u->update( { created_for_survey => uc( $survey ) } );
return $u;
}
sub _find_or_create_respondent {
my( $uid , $alpha , $mgpcde , $id ) = @_;
my $respondent_tag = _generate_respondent_tag( $alpha ,
$mgpcde ,
$id );
my $respondent = $respondents_rs->find_or_create({
uid => $uid,
respondent_tag => $respondent_tag,
paths => {},
data => {},
metadata => $record1_metadata,
});
$record1_metadata = {};
return $respondent;
}
sub _generate_respondent_tag {
my( $alpha , $mgpcde , $id ) = @_;
my $tag = $alpha . $mgpcde;
$tag = $id if ( length($tag) != 8 );
return $tag;
}
#################################################
sub _create_data_table_entry {
no warnings;
my( $rid , $uid , $metadata ,$data, $priordata ) = @_;
my $org_1 = $metadata->{name1} if $metadata->{name1} ; # Company Name
my $org_2 = $metadata->{name2} if $metadata->{name2} ; # Division (optional)
my $org_3 = $metadata->{street} if $metadata->{street}; # Street address
my $org_4 = $metadata->{city} if $metadata->{city} ; # City
my $org_5 = $metadata->{state} if $metadata->{state} ; # State
my $org_7 = $metadata->{attn} if $metadata->{attn} ; # State
foreach my $st (@states) {
if ( $metadata->{state} =~ /$st->{state_abbr}/) { $org_5 = $st->{state_code} };
}
my $org_6 = $metadata->{zip}; # Zip code
$org_6 .= "-" . $metadata->{zip4} if $metadata->{zip4}; # Zip code +4
my $prior = $priordata->{'01'};
my %newhash;
foreach my $key ( keys %$prior ) {
$newhash{ substr($key, 0, 3) } = 1;
}
my $data_hashref;
my $count = 1;
foreach my $key ( sort keys %newhash ) {
$data_hashref->{"MAJ_ACT_$count"} = $key;
$count++;
}
$data_hashref->{NAME1} = $org_1 , # Company Name
$data_hashref->{NAME2} = $org_2 , # Division (optional)
$data_hashref->{STREET} = $org_3 , # Street address
$data_hashref->{CITY} = $org_4 , # City
$data_hashref->{STATE} = $org_5 , # State (number as determined above)
$data_hashref->{ZIP} = $org_6 , # Zip
$data_hashref->{ATTN} = $org_7 , # Attn
$data_rs->create({
rid => $rid ,
form => "main/$uid" ,
data => $data_hashref ,
errors => 0 ,
modified => time() ,
});
}
#################################################
sub _create_unit {
my( $rid , $meta_ref , $data_ref , $prior_ref ) = @_;
return $units_rs->create({
rid => $rid,
unit_tag => $meta_ref->{id},
alpha => $meta_ref->{alpha},
mailgroup => $meta_ref->{mgpcde},
form => $meta_ref->{form},
data => $data_ref,
metadata => $meta_ref,
priordata => $prior_ref,
});
}
#################################################
sub _make_state_record {
my $line = $_[0];
my $delimiter = $_[1];
my @fields = split(/$delimiter/,$line);
my %state_record = (
state_code => $fields[0],
state_name => $fields[1],
state_abbr => $fields[2],
);
return (\%state_record);
}
#################################################
sub _running_interactively { return -t STDIN && -t STDOUT }
#################################################
编辑版本：
#!/usr/bin/env perl
use strict;
use warnings;
use 5.012;
use Getopt::Long;
use Pod::Usage;
use IO::File;
use File::Basename;
use FindBin;
use lib "$FindBin::Bin/../../lib";
use TNT::Utils::Crypto;
use TNT::Utils::DB;
STDOUT->autoflush(1);
my %opt = ();
GetOptions(
\%opt,
'help|h|?',
'dbtype=s',
'mode=s' ,
'file=s@' ,
'qaname=s',
) || pod2usage(1);
_validate_inputs(%opt);
my $survey = 'ufo'; #"Must provide survey name"
my $db_type = $opt{dbtype}; #"Must provide database type (mysql|prod|sqlite|test)"
my $mode = $opt{mode}; #"Must provide mode 'NORMAL' or 'ROLLOVER'"
my @files = $opt{file}; #"Must provide file names to load or 'FAKE' for fake data"
my $qaname = $opt{qaname};
my $schema = TNT::Utils::DB->get_schema( env => $db_type, survey => $survey, qaname => $qaname );
#################################################
sub _validate_inputs {
my(%opt) = @_;
pod2usage(1) if $opt{help};
my @db_types = qw/ mysql prod sqlite test /;
pod2usage(
-exitstatus => 1,
-message => "Datebase type must be one of: mysql, prod, sqlite, test \n",
) unless $opt{dbtype} ~~ @db_types;
my @modes = qw/ NORMAL ROLLOVER /;
pod2usage(
-exitstatus => 1,
-message => "Mode must be either NORMAL or ROLLOVER \n",
) unless $opt{mode} ~~ @modes;
}
答案 0 :(得分：5)
我假设在使用-h选项运行时，您期望得到一条漂亮的消息，说明如何根据早期的GetOptions规范运行程序。
pod2usage根本不会为你做那件事。
根据文档（参见perldoc Pod::Usage），当提供单个数字参数时，pod2usage只是使用参数作为退出状态退出。如果您使用 -h 运行更新后的脚本，然后直接使用echo $?检查退出状态，您会看到它正在执行它所说的内容。
也许perldoc Getopt::Long中的文档可能更清晰 - 它说：
Getopt::Long encourages the use of Pod::Usage to produce help messages.
For example:
use Getopt::Long;
use Pod::Usage;
my $man = 0;
my $help = 0;
GetOptions('help|?' => \$help, man => \$man) or pod2usage(2);
pod2usage(1) if $help;
pod2usage(-exitval => 0, -verbose => 2) if $man;
__END__
=head1 NAME
sample - Using Getopt::Long and Pod::Usage
=head1 SYNOPSIS
sample [options] [file ...]
Options:
-help brief help message
-man full documentation
=head1 OPTIONS
=over 8
=item B<-help>
Print a brief help message and exits.
=item B<-man>
Prints the manual page and exits.
=back
=head1 DESCRIPTION
B<This program> will read the given input file(s) and do something
useful with the contents thereof.
=cut
See Pod::Usage for details.
...你必须真正提供POD才能发挥作用（正如其中一位评论者已经注意到的那样）。为了完整起见，perldoc Pod::Usage的相关部分是：
pod2usage will print a usage message for the invoking script (using its
embedded pod documentation) and then exit the script with the desired exit
status. The usage message printed may have any one of three levels of
"verboseness": If the verbose level is 0, then only a synopsis is printed.
If the verbose level is 1, then the synopsis is printed along with a
description (if present) of the command line options and arguments. If the
verbose level is 2, then the entire manual page is printed.
但关键是它会从您嵌入程序的POD中生成“概要”，“描述”或“手册页” - 在您的情况下是没有。