1#@!#!123s

: / opt / dedrads / perl / IMH /
Filename : OptionParser.pm
back
#!/usr/bin/perl
# encoding: utf-8
#
# author: Kyle Yetter
#

package IMH::OptionParser;

use strict;
use warnings;
use Getopt::Long;
use File::Basename;
use Class::Struct;
use Switch;
use IMH::Terminal;
use Text::Wrap;

our $VERSION = '0.1';
our @TYPE_SIGNIFIERS = qw( s str string i int integer f float real o perl_int perl_integer );
our %CANONICAL_TYPES = (
  's' => 's',
  'str' => 's',
  'string' => 's',
  'i' => 'i',
  'int' => 'i',
  'integer' => 'i',
  'f' => 'f',
  'float' => 'f',
  'real' => 'f',
  'o' => 'o',
  'perl_int' => 'o',
  'perl_integer' => 'o'
);

our $TEMPLATE = q(
  package IMH::OptionParser::OptionSet<[id]>;

  use Class::Struct;

  struct( <[struct_spec]> );
);


sub new {
  my ( $class ) = shift;
  my $object = {};
  bless( $object, $class || __PACKAGE__ );
  $object->initialize( @_ );
  return $object;
}

sub initialize {
  my ( $self, @args ) = @_;
  $self->{name}            = basename( $0 );
  $self->{version}         = defined( $main::VERSION ) ? "$main::VERSION" : undef;
  $self->{description}     = undef;
  $self->{entries}         = [];
  $self->{config}          = { bundling => 1 };
  $self->{entries_by_name} = {};
  $self->{usage}           = undef;

  $self->{include_help}    = 1;
  $self->{include_version} = $self->{version} ? 1 : 0;

  for my $arg ( @args ) {
    switch ( ref( $arg ) ) {
      case 'HASH' {
        for my $prop ( qw( include_version include_help usage version name ) ) {
          exists( $arg->{$prop} ) and $self->{$prop} = $arg->{$prop};
        }
      }

      else {
        switch ( $arg ) {
          case qr(^(?:\d+\.)*\d+$) { $self->{version} = $arg;   }
          else                     { $self->{name}    = "$arg"; }
        }
      }
    }
  }

  return $self;
}

sub name {
  my $self = shift;
	if ( @_ ) {
	  $self->{name} = shift;
	}
	return $self->{name};
}

sub version {
  my $self = shift;
	if ( @_ ) {
	  $self->{version} = shift;
	}
	return $self->{version};
}

sub description {
  my $self = shift;
	if ( @_ ) {
	  $self->{description} = join( "\n", @_ );
	}
	return $self->{description};
}

sub usage {
  my $self = shift;
  if ( @_ ) {
    $self->{ usage } = join( "\n", @_ );
  }
  return $self->{ usage };
}

sub enable {
  my $self   = shift;
  my $config = $self->{config};
  for my $config_attr ( @_ ) {
    $config->{ $config_attr } = 1;
  }
  return $self;
}

sub disable {
  my $self   = shift;
  my $config = $self->{config};
  for my $config_attr ( @_ ) {
    $config->{ $config_attr } = 0;
  }
  return $self;
}

sub option {
  my $self     = shift;
  my %opts     = ( arity => 0, argument_required => 0, type => 's' );
  my @short    = ();
  my @long     = ();

  for my $arg ( @_ ) {
    switch ( ref( $arg ) ) {
      case 'HASH'  { %opts = ( %opts, %$arg ); }
      case 'CODE'  { $opts{callback} = $arg; }
      case 'ARRAY' { }
      else {
        switch ( $arg ) {
          case qr/^-([^\-])/        { push @short, $arg; }
          case qr/^--([^=:\s]+)/    { push @long,  $arg; }
          case [ @TYPE_SIGNIFIERS ] { $opts{type} = "$arg"; }
          else                      { $opts{desc} = "$arg"; }
        }
      }
    }
  }

  if ( exists($opts{type}) ) {
    if ( exists($CANONICAL_TYPES{$opts{type}}) ) {
      $opts{type} = $CANONICAL_TYPES{$opts{type}};
    } else {
      warn( "`$opts{type}' is not a valid option type specification" );
      $opts{type} = 's';
    }
  }


  unless ( exists( $opts{name} ) ) {
    if ( $long[0] =~ /^\-\-([^=:\s]+)/ ) {
      ( $opts{name} = $1 ) =~ y/- \t/_/;
    }
  }

  my $spec = OptionSpec->new( %opts );
  $spec->long( [ @long ] );
  $spec->short( [ @short ] );

  for ( @short ) {
    if ( /^-?([^-])/ ) {
      $self->{entries_by_name}->{$1} = $spec;
    }

    if ( /[\s=](.+)/ ) {
      $spec->arity( 1 );
      $spec->argument_required( 1 );
    } elsif ( /:(.+)/ ) {
      $spec->arity( 1 );
      $spec->argument_required( 0 );
    }
  }

  for ( @long  ) {
    if ( /^(?:--)?([^=\s:]+)/ ) {
      $self->{entries_by_name}->{$1} = $spec;
    }

    if ( /[\s=](.+)/ ) {
      $spec->arity( 1 );
      $spec->argument_required( 1 );
    } elsif ( /:(.+)/ ) {
      $spec->arity( 1 );
      $spec->argument_required( 0 );
    }
  }

  push @{ $self->{entries} }, $spec;
  return $spec;
}

sub build_option_object {
  my ( $self )     = @_;
  my $class_source = $TEMPLATE;
  my @struct_spec_parts = map {
    my $spec = $_;
    my $name = $spec->name;
    my $type = q('$');
    "$name => $type";
  } @{$self->{entries}};

  my $params = {
    id => 0 + $self,
    struct_spec => join( ', ', @struct_spec_parts )
  };

  $class_source =~ s(<\[(\w+)\]>)($params->{$1};)eg;
  eval( $class_source );
  my $option_object = eval( "IMH::OptionParser::OptionSet" . ( 0 + $self ) . "->new" );

  for my $spec ( @{$self->{entries}} ) {
    if ( $spec->default_value ) {
      my $n = $spec->name;
      $option_object->$n( $spec->default_value );
    }
  }


  return $option_object;
}

sub parse {
  my $self          = shift;
  my $args          = shift || [ @ARGV ];

  $self->add_special_opts;

  my $option_object = $self->build_option_object;
  my $getopt        = Getopt::Long::Parser->new;

  my $handler = sub {
    my ( $opt_info, $val ) = @_;
    my $oname = $opt_info->name;
    my $spec  = $self->{entries_by_name}->{$oname};

    if ( $spec->special ) {
      switch ( $spec->special ) {
        case 'h' {
          printf STDERR "%s\n", $self->build_help;
          exit( 0 );
        }
        case 'v' {
          printf STDERR "%s\n", $self->{version};
          exit( 0 );
        }
      }
    } elsif ( $spec->callback ) {
      $spec->callback->($spec, $val);
    } else {
      my $n     = $spec->name;
      if ( $spec->arity ) {
        $option_object->$n( $val );
      } else {
        $option_object->$n( 1 );
      }
    }
  };

  my %getopt_spec;
  for my $spec ( @{$self->{entries}} ) {
    $getopt_spec{ make_opt_string( $spec ) } = $handler;
  }

  # set the options for Getopt::Long::Parser by selecting the keys in the
  # config hash that are set to 1
  $getopt->configure( grep { $self->{config}->{ $_ } } keys %{$self->{config}} );

  my @original_argv = @ARGV;
  @ARGV = @$args;

  $getopt->getoptions( %getopt_spec );

  my @remaining_args = @ARGV;
  @ARGV = @original_argv;

  return ( $option_object, [ @remaining_args ] );
}

sub add_special_opts {
  my ( $self ) = @_;
  unless ( $self->{help_option} || !$self->{include_help} ) {

    my @params   = ();
    my $registry = $self->{entries_by_name};

    unless ( exists( $registry->{h} ) )    { push( @params, '-h' ); }
    unless ( exists( $registry->{help} ) ) { push( @params, '--help' ); }

    if ( @params ) {
      push @params, {
        desc    => "Show program usage details",
        special => 'h'
      };

      $self->{help_option} = $self->option( @params );
    } else {
      $self->{help_option} = $registry->{help};
    }
  }

  unless ( $self->{version_option} || !$self->{include_version} ) {
    my @params   = ();
    my $registry = $self->{entries_by_name};

    unless ( exists( $registry->{v} ) )       { push( @params, '-v' ); }
    unless ( exists( $registry->{version} ) ) { push( @params, '--version' ); }

    if ( @params ) {
      push @params, {
        desc    => "Print program version number and exit",
        special => 'v'
      };

      $self->{version_option} = $self->option( @params );
    } else {
      $self->{version_option} = $registry->{version};
    }
  }

  return;
}

sub fail_with_help {
  my ( $self, $message ) = @_;
  if ( $message ) {
    print STDERR "ERROR: $message\n\n";
  }

  printf STDERR "%s\n", $self->build_help;

  exit( 1 );
}

sub make_opt_string {
  my ( $spec ) = @_;
  my @frags;

  for ( @{$spec->short} ) { if ( /^-?([^-])/ ) { push @frags, $1; } }
  for ( @{$spec->long}  ) { if ( /^(?:--)?([^=\s:]+)/ ) { push @frags, $1; } }

  my $str = join( '|', @frags );
  if ( $spec->arity ) {
    if ( $spec->argument_required ) {
      $str .= "=" . $spec->type;
    } else {
      $str .= ':' . $spec->type;
    }
  }

  return $str;
}

sub build_help {
  my ( $self, %opts ) = @_;
  my $program         = $self->{name};
  my $version         = $self->{version};
  my $description     = $self->{description};
  my $full_name       = $version ? "$program v$version" : $program;
  my $width           = $opts{width}  || screen_width;
  my $indent          = $opts{indent} || 4;
  my @entries         = @{ $self->{entries} };
  my $text            = '';
  my $opt_width       = 0;
  my $usage           = $self->{usage} || $opts{usage}; # || "$program [options]";
  my $indent_text     = ' ' x $indent;


  open( my $out, ">", \$text );
  local $\ = "\n";
  $Text::Wrap::columns = $width - $indent - 2;

  print $out "NAME";
  print $out "$indent_text$full_name";
  print $out '';

  if ( $description ) {
    $description = wrap( '', '', $description );
    for my $l ( split /\n/, $description ) {
      print $out "$indent_text$l";
    }
    print $out '';
  }

  if ( $usage ) {
    print $out "USAGE";

    $usage = wrap( '', '', $usage );

    for my $l ( split /\n/, $usage ) {
      print $out "$indent_text$l";
    }
    print $out '';
  }

  print $out "OPTIONS";

  my @option_strings  =
    map {
      my $spec = $_;
      my @opts = ( @{ $spec->short }, @{ $spec->long } );
      my $s    = join( ", ", @opts );
      my $l    = clen( $s );
      if ( $l > $opt_width ) { $opt_width = $l; }
      $s;
    } @entries;

  my $desc_width = $width - $indent - 2 - $opt_width;
  if ( $desc_width < 20 ) { $desc_width = 20; }

  my $sep_span     = ' ' x 2;
  my $padding_span = ' ' x $opt_width;


  $Text::Wrap::columns = $desc_width;

  for my $i ( 0 ... $#entries ) {
    my $spec = $entries[ $i ];
    my $opt_string = $option_strings[ $i ];

    my $desc = $spec->desc || '';
    $desc = wrap( '', '', $desc );
    my @desc_lines = split( /\r?\n/, $desc );
    my $first_line = shift( @desc_lines ) || '';

    print $out $indent_text, ljust( $opt_string, $opt_width ), $sep_span, $first_line;
    for my $line ( @desc_lines ) {
      print $out $indent_text, $padding_span, $sep_span, $line;
    }
  }

  close( $out );

  return $text;
}

sub build_usage {
  my ( $self ) = @_;

}



struct(
  OptionSpec => [
    'short'             => '@',
    'long'              => '@',
    'name'              => '$',
    'arity'             => '$',
    'default_value'     => '$',
    'argument_required' => '$',
    'type'              => '$',
    'desc'              => '$',
    'callback'          => '$',
    'special'           => '$'
  ]
);



1;