Utilisation des options Get et de l'utilisation du pod en Perl

Question

Je suis en train d'éditer un programme Perl pour utiliser les modules Get Options et Pod Usage. Quand j'essaye de le faire, cela semble le briser. Le premier exemple de code est le fichier d'origine qui fonctionne et le deuxième exemple de code est la version modifiée qui ne fonctionne pas.

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

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

Modifié Version:

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

Je suppose que quand a couru avec l'option -h, vous attendez un message assez expliquant comment le programme doit être exécuté en fonction de la spécification GetOptions plus tôt.

pod2usage simplement faire cela pour vous.

Selon la documentation (voir perldoc Pod::Usage) lorsqu'il est fourni avec un seul argument numérique, pod2usage se ferme simplement en utilisant l'argument comme état de sortie. Si vous exécutez votre script mis à jour avec -h, puis examinez le statut de sortie avec echo $? juste après, vous verrez qu'il fait ce qu'il a dit qu'il le ferait.

Peut-être la documentation perldoc Getopt::Long pourrait être plus claire - où il est dit:

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. 

... vous devez fournir en fait que POD pour que cela fonctionne (comme l'un des commentateurs a déjà noté). Juste pour être complet, la partie pertinente de perldoc Pod::Usage est:

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. 

Mais le point essentiel est qu'il génère que « synopsis », « description » ou « page de manuel » du POD vous intégrez dans votre programme - qui votre cas n'en est aucun.