/usr/share/perl5/Getopt/Long/Descriptive/Opts.pm is in libgetopt-long-descriptive-perl 0.096-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | use strict;
use warnings;
package Getopt::Long::Descriptive::Opts;
{
$Getopt::Long::Descriptive::Opts::VERSION = '0.096';
}
# ABSTRACT: object representing command line switches
use Scalar::Util qw(blessed weaken);
my %_CREATED_OPTS;
my $SERIAL_NUMBER = 1;
sub _specified {
my ($self, $name) = @_;
my $meta = $_CREATED_OPTS{ blessed $self }{meta};
return $meta->{given}{ $name };
}
sub _specified_opts {
my ($self) = @_;
my $class = blessed $self;
my $meta = $_CREATED_OPTS{ $class }{meta};
return $meta->{specified_opts} if $meta->{specified_opts};
my @keys = grep { $meta->{given}{ $_ } } (keys %{ $meta->{given} });
my %opts;
@opts{ @keys } = @$self{ @keys };
$meta->{specified_opts} = \%opts;
bless $meta->{specified_opts} => $class;
weaken $meta->{specified_opts};
$meta->{specified_opts};
}
sub _complete_opts {
my ($self) = @_;
my $class = blessed $self;
my $meta = $_CREATED_OPTS{ $class }{meta};
return $meta->{complete_opts};
}
sub ___class_for_opt {
my ($class, $arg) = @_;
my $values = $arg->{values};
my @bad = grep { $_ !~ /^[a-z_]\w*$/ } keys %$values;
Carp::confess("perverse option names given: @bad") if @bad;
my $new_class = "$class\::__OPT__::" . $SERIAL_NUMBER++;
$_CREATED_OPTS{ $new_class } = { meta => $arg };
{
no strict 'refs';
${"$new_class\::VERSION"} = $class->VERSION;
*{"$new_class\::ISA"} = [ 'Getopt::Long::Descriptive::Opts' ];
for my $opt (keys %$values) {
*{"$new_class\::$opt"} = sub { $_[0]->{ $opt } };
}
}
return $new_class;
}
sub ___new_opt_obj {
my ($class, $arg) = @_;
my $copy = { %{ $arg->{values} } };
my $new_class = $class->___class_for_opt($arg);
# This is stupid, but the traditional behavior was that if --foo was not
# given, there is no $opt->{foo}; it started to show up when we "needed" all
# the keys to generate a class, but was undef; this wasn't a problem, but
# broke tests of things that were relying on not-exists like tests of %$opt
# contents or MooseX::Getopt which wanted to use things as args for new --
# undef would not pass an Int TC. Easier to just do this. -- rjbs,
# 2009-11-27
delete $copy->{$_} for grep { ! defined $copy->{$_} } keys %$copy;
my $self = bless $copy => $new_class;
$_CREATED_OPTS{ $new_class }{meta}{complete_opts} = $self;
# weaken $_CREATED_OPTS{ $new_class }{meta}{complete_opts};
return $self;
}
1;
__END__
=pod
=head1 NAME
Getopt::Long::Descriptive::Opts - object representing command line switches
=head1 VERSION
version 0.096
=head1 DESCRIPTION
This class is the base class of all C<$opt> objects returned by
L<Getopt::Long::Descriptive>. In general, you do not want to think about this
class, look at it, or alter it. Seriously, it's pretty dumb.
Every call to C<describe_options> will return a object of a new subclass of
this class. It will have a method for the canonical name of each option
possible given the option specifications.
Method names beginning with an single underscore are public, and are named that
way to avoid conflict with automatically generated methods. Methods with
multiple underscores (in case you're reading the source) are private.
=head1 METHODS
B<Achtung!> All methods beginning with an underscore are experimental as of
today, 2009-12-12. They are likely to be formally made permanent soon.
=head2 _specified
This method returns true if the given name was specified on the command line.
For example, if C<@ARGS> was "C<< --foo --bar 10 >>" and C<baz> is defined by a
default, C<_specified> will return true for foo and bar, and false for baz.
=head2 _specified_opts
This method returns an opt object in which only explicitly specified values are
defined. Values which were set by defaults will appear undef.
=head2 _complete_opts
This method returns the opts object with all values, including those set by
defaults. It is probably not going to be very often-used.
=head1 AUTHORS
=over 4
=item *
Hans Dieter Pearcey <hdp@cpan.org>
=item *
Ricardo Signes <rjbs@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2005 by Hans Dieter Pearcey.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
|