summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2019-03-10 21:56:14 +0000
committerKarl Berry <karl@freefriends.org>2019-03-10 21:56:14 +0000
commite0a2a718e89f9700d627f1e6a8eea8f21d2fbeb8 (patch)
tree39972f65008b0d70f306a5f976494d29411bc41e /Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm
parentb206fdc77d81ed1600949062f08de5690a4bf66f (diff)
tl19 perl 5.28.1 for Windows, from Siep
git-svn-id: svn://tug.org/texlive/trunk@50322 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Test2/Util/HashBase.pm174
1 files changed, 160 insertions, 14 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm b/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm
index 76041efe5ee..8e73af425e2 100755
--- a/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm
+++ b/Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm
@@ -2,18 +2,25 @@ package Test2::Util::HashBase;
use strict;
use warnings;
+our $VERSION = '1.302133';
+
#################################################################
# #
# This is a generated file! Do not modify this file directly! #
# Use hashbase_inc.pl script to regenerate this file. #
# The script is part of the Object::HashBase distribution. #
+# Note: You can modify the version number above this comment #
+# if needed, that is fine. #
# #
#################################################################
{
no warnings 'once';
- $Test2::Util::HashBase::VERSION = '0.002';
+ $Test2::Util::HashBase::HB_VERSION = '0.006';
*Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
+ *Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
+ *Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION;
+ *Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
}
@@ -46,9 +53,15 @@ sub import {
my $class = shift;
my $into = caller;
- my $isa = _isa($into);
+ # Make sure we list the OLDEST version used to create this class.
+ my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION;
+ $Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver;
+
+ my $isa = _isa($into);
+ my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= [];
my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {};
- my %subs = (
+
+ my %subs = (
($into->can('new') ? () : (new => \&_new)),
(map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
(
@@ -56,12 +69,13 @@ sub import {
my $p = substr($_, 0, 1);
my $x = $_;
substr($x, 0, 1) = '' if $STRIP{$p};
+ push @$attr_list => $x;
my ($sub, $attr) = (uc $x, $x);
$sub => ($attr_subs->{$sub} = sub() { $attr }),
- $attr => sub { $_[0]->{$attr} },
- $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") })
- : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] })
- : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }),
+ $attr => sub { $_[0]->{$attr} },
+ $p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") })
+ : $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] })
+ : ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }),
} @_
),
);
@@ -70,10 +84,65 @@ sub import {
*{"$into\::$_"} = $subs{$_} for keys %subs;
}
+sub attr_list {
+ my $class = shift;
+
+ my $isa = _isa($class);
+
+ my %seen;
+ my @list = grep { !$seen{$_}++ } map {
+ my @out;
+
+ if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) {
+ Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()");
+ }
+ else {
+ my $list = $Test2::Util::HashBase::ATTR_LIST{$_};
+ @out = $list ? @$list : ()
+ }
+
+ @out;
+ } reverse @$isa;
+
+ return @list;
+}
+
sub _new {
- my ($class, %params) = @_;
- my $self = bless \%params, $class;
- $self->init if $self->can('init');
+ my $class = shift;
+
+ my $self;
+
+ if (@_ == 1) {
+ my $arg = shift;
+ my $type = ref($arg);
+
+ if ($type eq 'HASH') {
+ $self = bless({%$arg}, $class)
+ }
+ else {
+ Carp::croak("Not sure what to do with '$type' in $class constructor")
+ unless $type eq 'ARRAY';
+
+ my %proto;
+ my @attributes = attr_list($class);
+ while (@$arg) {
+ my $val = shift @$arg;
+ my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
+ $proto{$key} = $val;
+ }
+
+ $self = bless(\%proto, $class);
+ }
+ }
+ else {
+ $self = bless({@_}, $class);
+ }
+
+ $Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init')
+ unless exists $Test2::Util::HashBase::CAN_CACHE{$class};
+
+ $self->init if $Test2::Util::HashBase::CAN_CACHE{$class};
+
$self;
}
@@ -139,7 +208,10 @@ use it:
use warnings;
use My::Class;
- my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
+ # These are all functionally identical
+ my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
+ my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'});
+ my $three = My::Class->new(['MyFoo', 'MyBar']);
# Accessors!
my $foo = $one->foo; # 'MyFoo'
@@ -180,9 +252,13 @@ script.
=over 4
-=item $it = $class->new(@VALUES)
+=item $it = $class->new(%PAIRS)
+
+=item $it = $class->new(\%PAIRS)
-Create a new instance using key/value pairs.
+=item $it = $class->new(\@ORDERED_VALUES)
+
+Create a new instance.
HashBase will not export C<new()> if there is already a C<new()> method in your
packages inheritance chain.
@@ -204,6 +280,21 @@ This makes it so that HashBase sees that you have your own C<new()> method.
Alternatively you can define the method before loading HashBase instead of just
declaring it, but that scatters your use statements.
+The most common way to create an object is to pass in key/value pairs where
+each key is an attribute and each value is what you want assigned to that
+attribute. No checking is done to verify the attributes or values are valid,
+you may do that in C<init()> if desired.
+
+If you would like, you can pass in a hashref instead of pairs. When you do so
+the hashref will be copied, and the copy will be returned blessed as an object.
+There is no way to ask HashBase to bless a specific hashref.
+
+In some cases an object may only have 1 or 2 attributes, in which case a
+hashref may be too verbose for your liking. In these cases you can pass in an
+arrayref with only values. The values will be assigned to attributes in the
+order the attributes were listed. When there is inheritance involved the
+attributes from parent classes will come before subclasses.
+
=back
=head2 HOOKS
@@ -215,10 +306,18 @@ declaring it, but that scatters your use statements.
This gives you the chance to set some default values to your fields. The only
argument is C<$self> with its indexes already set from the constructor.
+B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >>
+during construction. It DOES NOT call C<can()> on the created object. Also note
+that the result of the check is cached, it is only ever checked once, the first
+time an instance of your class is created. This means that adding an C<init()>
+method AFTER the first construction will result in it being ignored.
+
=back
=head1 ACCESSORS
+=head2 READ/WRITE
+
To generate accessors you list them when using the module:
use Test2::Util::HashBase qw/foo/;
@@ -246,6 +345,32 @@ and similar typos. It will not help you if you forget to prefix the '+' though.
=back
+=head2 READ ONLY
+
+ use Test2::Util::HashBase qw/-foo/;
+
+=over 4
+
+=item set_foo()
+
+Throws an exception telling you the attribute is read-only. This is exported to
+override any active setters for the attribute in a parent class.
+
+=back
+
+=head2 DEPRECATED SETTER
+
+ use Test2::Util::HashBase qw/^foo/;
+
+=over 4
+
+=item set_foo()
+
+This will set the value, but it will also warn you that the method is
+deprecated.
+
+=back
+
=head1 SUBCLASSING
You can subclass an existing HashBase class.
@@ -256,6 +381,27 @@ You can subclass an existing HashBase class.
The base class is added to C<@ISA> for you, and all constants from base classes
are added to subclasses automatically.
+=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS
+
+Test2::Util::HashBase provides a function for retrieving a list of attributes for an
+Test2::Util::HashBase class.
+
+=over 4
+
+=item @list = Test2::Util::HashBase::attr_list($class)
+
+=item @list = $class->Test2::Util::HashBase::attr_list()
+
+Either form above will work. This will return a list of attributes defined on
+the object. This list is returned in the attribute definition order, parent
+class attributes are listed before subclass attributes. Duplicate attributes
+will be removed before the list is returned.
+
+B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to
+determine the attribute to which each value will be paired.
+
+=back
+
=head1 SOURCE
The source code repository for HashBase can be found at
@@ -279,7 +425,7 @@ F<http://github.com/Test-More/HashBase/>.
=head1 COPYRIGHT
-Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.