view release on metacpan or  search on metacpan

lib/Class/Usul/Getopt/Usage.pm  view on Meta::CPAN

   length $desc <= $max_length and return $desc; my @lines;

   while (length $desc > $max_length) {
      my $idx = rindex( substr( $desc, 0, $max_length ), $SPC );

      $idx >= 0 or last;

      push @lines, substr $desc, 0, $idx; substr( $desc, 0, 1 + $idx ) = $NUL;
   }

   push @lines, $desc;
   return @lines;
};

my $_types = sub {
   my $k = shift; my $option_type = $USAGE_CONF->{option_type} // 'short';

   $option_type eq 'none'    and return;       # Old behaviour
   $option_type eq 'verbose' and return uc $k; # New behaviour

   my $types = $USAGE_CONF->{type_map}
            // { int => 'i', key => 'k', num => 'n', str => 's', };
   my $type  = $types->{ $k } // $NUL;         # Prefered behaviour

   return $type;
};

my $_parse_assignment = sub {
   my $assign_spec = shift; $assign_spec or return $NUL;

   length $assign_spec < 2 and return $NUL; # Empty, ! or +

   my $argument = substr $assign_spec, 1, 2;
   my $result   = $_types->( 'str' );

   if    ($argument eq 'i' or $argument eq 'o') { $result = $_types->( 'int' ) }
   elsif ($argument eq 'f') { $result = $_types->( 'num' ) }

   if (length $assign_spec > 2) {
      my $desttype = substr $assign_spec, 2, 1;

      # Imply it can be repeated
      if    ($desttype eq '@') { $result .= '...' }
      elsif ($desttype eq '%') {
         $result = $result ? $_types->( 'key' )."=${result}..." : $NUL;
      }
   }

   substr $assign_spec, 0, 1 eq ':' and return "[=${result}]";
   # With leading space so it can just blindly be appended.
   return $result ? " $result" : $NUL;
};

my $_assemble_spec = sub {
   my ($length, $spec) = @_;

   my $stripped  = [ Getopt::Long::Descriptive->_strip_assignment( $spec ) ];
   my $assign    = $_parse_assignment->( $stripped->[ 1 ] );
   my $plain     = join $SPC, reverse
                   map    { length > 1 ? "--${_}${assign}" : "-${_}${assign}" }
                   split m{ [|] }mx, $stripped->[ 0 ];
   my $pad       = $SPC x ($length - length $plain);
   my $highlight = $USAGE_CONF->{highlight} // 'bold';

   $highlight eq 'none' and return $plain.$pad; # Old behaviour

   $assign = color( $highlight ).$assign.color( 'reset' );

   my $markedup  = join $SPC, reverse
                   map    { length > 1 ? "--${_}${assign}" : "-${_}${assign}" }
                   split m{ [|] }mx, $stripped->[ 0 ];

   return $markedup.$pad; # Prefered behaviour works well with short types
};

my $_option_length = sub {
   my $fullspec         = shift;
   my $number_opts      = 1;
   my $last_pos         = 0;
   my $number_shortopts = 0;
   my ($spec, $assign)
      = Getopt::Long::Descriptive->_strip_assignment( $fullspec );
   my $length           = length $spec;
   my $arglen           = length $_parse_assignment->( $assign );
   # Spacing rules:
   # For short options we want 1 space (for '-'), for long options 2
   # spaces (for '--').  Then one space for separating the options,
   # but we here abuse that $spec has a '|' char for that.

   # For options that take arguments, we want 2 spaces for mandatory
   # options ('=X') and 4 for optional arguments ('[=X]').  Note we
   # consider {N,M} cases as "single argument" atm.

   # Count the number of "variants" (e.g. "long|s" has two variants)
   while ($spec =~ m{ [|] }gmx) {
      $number_opts++;
      (pos( $spec ) - $last_pos) == 2 and $number_shortopts++;
      $last_pos = pos( $spec );
   }

   # Was the last option a "short" one?
   # Getopt::Long::Descriptive has a 2 here and thats wrong
   ($length - $last_pos) == 1 and $number_shortopts++;
   # We got $number_opts options, each with an argument length of
   # $arglen.  Plus each option (after the first) needs 3 a char
   # spacing.  $length gives us the total length of all options and 1
   # char spacing per option (after the first).  It does not account
   # for argument length and we want (at least) one additional char
   # for space before the description.  So the result should be:
   my $number_longopts = $number_opts - $number_shortopts;
   my $total_arglen    = $number_opts * $arglen;
   my $total_optsep    = 2 * $number_longopts + $number_shortopts;
   my $total           = $length + $total_optsep + $total_arglen;

   return $total;
};

# Public methods
sub option_text {
   my $self     = shift;
   my @options  = @{ $self->{options} // [] };
   my @specs    = map { $_->{spec} } grep { $_->{desc} ne 'spacer' } @options;
   my $length   = max( map { $_option_length->( $_ ) } @specs ) || 0;
   my $tab      = $SPC x $_tabstop->(); # Originally an actual tab char
   my $spec_fmt = "${tab}%-${length}s";
   my $string   = $NUL;

   while (defined (my $opt = shift @options)) {
      my $spec  = $opt->{spec}; my $desc = $opt->{desc};

      if ($desc eq 'spacer') { $string .= sprintf "${spec_fmt}\n", $spec; next }