在 Perl 中使用 Get 选项和 Pod 使用
Using Get Options and Pod Usage in Perl
我正在尝试编辑 Perl 程序以使用获取选项和 Pod 使用模块。当我尝试这样做时，它似乎打破了它。第一个代码示例是有效的原始文件，第二个代码示例是无效的编辑版本。
#!/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;
}
我推测当 运行 带有 -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 中生成 "synopsis"、"description" 或 "manual page" - 在您的情况下是 none .
我正在尝试编辑 Perl 程序以使用获取选项和 Pod 使用模块。当我尝试这样做时，它似乎打破了它。第一个代码示例是有效的原始文件，第二个代码示例是无效的编辑版本。
#!/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;
}
我推测当 运行 带有 -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 中生成 "synopsis"、"description" 或 "manual page" - 在您的情况下是 none .