local-lib5/lib/perl5/Getopt/Long/Descriptive/Usage.pm

   1 package Getopt::Long::Descriptive::Usage;
   2 use strict;
   3 use warnings;
   4
   5 our $VERSION = '0.082';
   6
   7 use List::Util qw(max);
   8
   9 =head1 NAME
  10
  11 Getopt::Long::Descriptive::Usage - the usage description for GLD
  12
  13 =head1 SYNOPSIS
  14
  15   use Getopt::Long::Descriptive;
  16   my ($opt, $usage) = describe_options( ... );
  17
  18   $usage->text; # complete usage message
  19
  20   $usage->die;  # die with usage message
  21
  22 =head1 DESCRIPTION
  23
  24 This document only describes the methods of the Usage object.  For information
  25 on how to use L<Getopt::Long::Descriptive>, consult its documentation.
  26
  27 =head1 METHODS
  28
  29 =head2 new
  30
  31   my $usage = Getopt::Long::Descriptive::Usage->new(\%arg);
  32
  33 You B<really> don't need to call this.  GLD will do it for you.
  34
  35 Valid arguments are:
  36
  37   options     - an arrayref of options
  38   leader_text - the text that leads the usage; this may go away!
  39
  40 =cut
  41
  42 sub new {
  43   my ($class, $arg) = @_;
  44
  45   my @to_copy = qw(options leader_text);
  46
  47   my %copy;
  48   @copy{ @to_copy } = @$arg{ @to_copy };
  49
  50   bless \%copy => $class;
  51 }
  52
  53 =head2 text
  54
  55 This returns the full text of the usage message.
  56
  57 =cut
  58
  59 sub text {
  60   my ($self) = @_;
  61
  62   return join qq{\n}, $self->leader_text, $self->option_text;
  63 }
  64
  65 =head2 leader_text
  66
  67 This returns the text that comes at the beginning of the usage message.
  68
  69 =cut
  70
  71 sub leader_text { $_[0]->{leader_text} }
  72
  73 =head2 option_text
  74
  75 This returns the text describing the available options.
  76
  77 =cut
  78
  79 sub option_text {
  80   my ($self) = @_;
  81
  82   my @options  = @{ $self->{options} || [] };
  83   my $string   = q{};
  84
  85   # a spec can grow up to 4 characters in usage output:
  86   # '-' on short option, ' ' between short and long, '--' on long
  87   my @specs = map { $_->{spec} } grep { $_->{desc} ne 'spacer' } @options;
  88   my $length   = (max(map { length } @specs) || 0) + 4;
  89   my $spec_fmt = "\t%-${length}s";
  90
  91   while (@options) {
  92     my $opt  = shift @options;
  93     my $spec = $opt->{spec};
  94     my $desc = $opt->{desc};
  95     if ($desc eq 'spacer') {
  96       $string .= sprintf "$spec_fmt\n", $opt->{spec};
  97       next;
  98     }
  99
 100     $spec = Getopt::Long::Descriptive->_strip_assignment($spec);
 101     $spec = join " ", reverse map { length > 1 ? "--$_" : "-$_" }
 102                               split /\|/, $spec;
 103     $string .= sprintf "$spec_fmt  %s\n", $spec, $desc;
 104   }
 105
 106   return $string;
 107 }
 108
 109 =head2 warn
 110
 111 This warns with the usage message.
 112
 113 =cut
 114
 115 sub warn { warn shift->text }
 116
 117 =head2 die
 118
 119 This throws the usage message as an exception.
 120
 121   $usage_obj->die(\%arg);
 122
 123 Some arguments can be provided
 124
 125   pre_text  - text to be prepended to the usage message
 126   post_text - text to be appended to the usage message
 127
 128 The C<pre_text> and C<post_text> arguments are concatenated with the usage
 129 message with no line breaks, so supply this if you need them.
 130
 131 =cut
 132
 133 sub die  {
 134   my $self = shift;
 135   my $arg  = shift || {};
 136
 137   die(
 138     join q{}, grep { defined } $arg->{pre_text}, $self->text, $arg->{post_text}
 139   );
 140 }
 141
 142 use overload (
 143   q{""} => "text",
 144
 145   # This is only needed because Usage used to be a blessed coderef that worked
 146   # this way.  Later we can toss a warning in here. -- rjbs, 2009-08-19
 147   '&{}' => sub {
 148     my ($self) = @_;
 149     Carp::cluck("use of __PACKAGE__ objects as a code ref is deprecated");
 150     return sub { return $_[0] ? $self->text : $self->warn; };
 151   }
 152 );
 153
 154 =head1 AUTHOR
 155
 156 Hans Dieter Pearcey, C<< <hdp@cpan.org> >>
 157
 158 =head1 BUGS
 159
 160 Please report any bugs or feature requests through the web interface at
 161 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Getopt-Long-Descriptive>.  I
 162 will be notified, and then you'll automatically be notified of progress on your
 163 bug as I make changes.
 164
 165 =head1 COPYRIGHT & LICENSE
 166
 167 Copyright 2005 Hans Dieter Pearcey, all rights reserved.
 168
 169 This program is free software; you can redistribute it and/or modify it
 170 under the same terms as Perl itself.
 171
 172 =cut
 173
 174 1;