Использование параметров получения и использования в Perl

Question

Я пытаюсь отредактировать программу 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 } 

################################################# 

Edited Версия:

#!/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; 
} 

Answer 1

Я полагаю, когда бежал с опцией -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 встраивать в программу - которая в ваше дело - нет.