Using Get Options and Pod Usage in Perl

Question

I'm trying to edit a Perl program to use the Get Options and Pod Usage modules. When I try to do so it seem to break it. The first code sample is the original file that works and the second code sample is the edited version that does not work.

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

I presume when ran with the -h option, you're expecting a pretty message explaining how the program should be ran based on the earlier GetOptions specification.

pod2usage simply wont do that for you.

According to the documentation (see perldoc Pod::Usage) when supplied with a single numeric argument, pod2usage simply exits using the argument as an exit status. If you run your updated script with -h and then examine the exit status with echo $? straight after, you'll see it's doing what it said it would.

Perhaps the documentation in perldoc Getopt::Long could be clearer - where it says:

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.

... you have to actually supply that POD for it to work (as one of the commenters has already noted). Just for completeness, the relevant part of perldoc Pod::Usage is:

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.

But the key point is that it generates that "synopsis", "description" or "manual page" from the POD you embed in your program - which in your case is none.