diff options
author | Karl Berry <karl@freefriends.org> | 2019-03-10 21:56:14 +0000 |
---|---|---|
committer | Karl Berry <karl@freefriends.org> | 2019-03-10 21:56:14 +0000 |
commit | e0a2a718e89f9700d627f1e6a8eea8f21d2fbeb8 (patch) | |
tree | 39972f65008b0d70f306a5f976494d29411bc41e /Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm | |
parent | b206fdc77d81ed1600949062f08de5690a4bf66f (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-x | Master/tlpkg/tlperl/lib/Test2/Util/HashBase.pm | 174 |
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. |