view release on metacpan or  search on metacpan

lib/App/PerlPPP.pm  view on Meta::CPAN

      no strict 'refs';
      my $validator = $spec->[1] || sub { shift; shift };
      *{ __PACKAGE__ . '::' . $name } = sub {
        my $self = shift;
        $self->{$name} = $self->$validator( @_ )
         if ( @_ );
        my $value = $self->{$name};
        return ( wantarray && 'ARRAY' eq ref $value )
         ? @$value
         : $value;
      };
    }
  }

  sub new {
    my ( $class, %args ) = @_;

    my $self = bless {}, $class;

    while ( my ( $name, $spec ) = each %ARG_SPEC ) {
      my $value
       = exists $args{$name} ? delete $args{$name} : $spec->[0];
      $self->$name( $value )
       if defined $value;
    }

    croak "Unknown options: ", join( ', ', sort keys %args )
     if keys %args;

    return $self;
  }
}

=head2 C<< args >>

=head2 C<< alphabet >>

=head2 C<< codelen >>

=head2 C<< columns >>

=head2 C<< rows >>

=head2 C<< key >>

=head2 C<< passphrase >>

=head2 C<< title >>

=head2 C<< show_help >>

=head2 C<< show_man >>

=head2 C<< parse_args >>

=cut

sub parse_args {
  my ( $self, @args ) = @_;

  local @ARGV = @args;

  my %options;

  GetOptions(
    'help|?'       => \$options{show_help},
    man            => \$options{show_man},
    'key=s'        => \$options{key},
    'passphrase=s' => \$options{passphrase},
    'columns=i'    => \$options{columns},
    'rows=i'       => \$options{rows},
    'title=s'      => \$options{title},
    'alphabet=s'   => \$options{alphabet},
    'codelen=i'    => \$options{codelen},
  ) or pod2usage();

  while ( my ( $name, $value ) = each %options ) {
    $self->$name( $value ) if defined $value;
  }

  $self->args( @ARGV );
}

=head2 C<< run >>

=cut

sub run {
  my $self = shift;

  if ( $self->show_help ) {
    $self->do_help;
  }
  elsif ( $self->show_man ) {
    pod2usage( -verbose => 2, -exitstatus => 0 );
  }
  else {
    my @args = $self->args;
    pod2usage() unless @args;
    my $verb = shift @args;
    if ( my $code = $self->can( "do_$verb" ) ) {
      $self->$code( @args );
    }
    else {
      die "Unknown action: $verb\n";
    }
  }
}

=head1 ACTIONS

=head2 C<< do_card >>

Output a card

=cut

sub do_card {
  my ( $self, @args ) = @_;
  my $card_no = @args ? shift @args : 1;
  die "Card numbers start at 1\n" if $card_no < 1;