Added Cyg-Win
This commit is contained in:
parent
82cbc206eb
commit
413c315806
10586 changed files with 3806249 additions and 0 deletions
|
|
@ -0,0 +1,182 @@
|
|||
package Test2::Util::ExternalMeta;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
sub META_KEY() { '_meta' }
|
||||
|
||||
our @EXPORT = qw/meta set_meta get_meta delete_meta/;
|
||||
BEGIN { require Exporter; our @ISA = qw(Exporter) }
|
||||
|
||||
sub set_meta {
|
||||
my $self = shift;
|
||||
my ($key, $value) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
$self->{+META_KEY} ||= {};
|
||||
$self->{+META_KEY}->{$key} = $value;
|
||||
}
|
||||
|
||||
sub get_meta {
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
my $meta = $self->{+META_KEY} or return undef;
|
||||
return $meta->{$key};
|
||||
}
|
||||
|
||||
sub delete_meta {
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
my $meta = $self->{+META_KEY} or return undef;
|
||||
delete $meta->{$key};
|
||||
}
|
||||
|
||||
sub meta {
|
||||
my $self = shift;
|
||||
my ($key, $default) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
my $meta = $self->{+META_KEY};
|
||||
return undef unless $meta || defined($default);
|
||||
|
||||
unless($meta) {
|
||||
$meta = {};
|
||||
$self->{+META_KEY} = $meta;
|
||||
}
|
||||
|
||||
$meta->{$key} = $default
|
||||
if defined($default) && !defined($meta->{$key});
|
||||
|
||||
return $meta->{$key};
|
||||
}
|
||||
|
||||
sub validate_key {
|
||||
my $key = shift;
|
||||
|
||||
return if $key && !ref($key);
|
||||
|
||||
my $render_key = defined($key) ? "'$key'" : 'undef';
|
||||
croak "Invalid META key: $render_key, keys must be true, and may not be references";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data
|
||||
to your instances.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package lets you define a clear, and consistent way to allow third party
|
||||
tools to attach meta-data to your instances. If your object consumes this
|
||||
package, and imports its methods, then third party meta-data has a safe place
|
||||
to live.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package My::Object;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
|
||||
|
||||
...
|
||||
|
||||
Now to use it:
|
||||
|
||||
my $inst = My::Object->new;
|
||||
|
||||
$inst->set_meta(foo => 'bar');
|
||||
my $val = $inst->get_meta('foo');
|
||||
|
||||
=head1 WHERE IS THE DATA STORED?
|
||||
|
||||
This package assumes your instances are blessed hashrefs, it will not work if
|
||||
that is not true. It will store all meta-data in the C<_meta> key on your
|
||||
objects hash. If your object makes use of the C<_meta> key in its underlying
|
||||
hash, then there is a conflict and you cannot use this package.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $val = $obj->meta($key)
|
||||
|
||||
=item $val = $obj->meta($key, $default)
|
||||
|
||||
This will get the value for a specified meta C<$key>. Normally this will return
|
||||
C<undef> when there is no value for the C<$key>, however you can specify a
|
||||
C<$default> value to set when no value is already set.
|
||||
|
||||
=item $val = $obj->get_meta($key)
|
||||
|
||||
This will get the value for a specified meta C<$key>. This does not have the
|
||||
C<$default> overhead that C<meta()> does.
|
||||
|
||||
=item $val = $obj->delete_meta($key)
|
||||
|
||||
This will remove the value of a specified meta C<$key>. The old C<$val> will be
|
||||
returned.
|
||||
|
||||
=item $obj->set_meta($key, $val)
|
||||
|
||||
Set the value of a specified meta C<$key>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 META-KEY RESTRICTIONS
|
||||
|
||||
Meta keys must be defined, and must be true when used as a boolean. Keys may
|
||||
not be references. You are free to stringify a reference C<"$ref"> for use as a
|
||||
key, but this package will not stringify it for you.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
L<https://github.com/Test-More/test-more/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2020 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.
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,299 @@
|
|||
package Test2::Util::Facets2Legacy;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
use Carp qw/croak confess/;
|
||||
use Scalar::Util qw/blessed/;
|
||||
|
||||
use base 'Exporter';
|
||||
our @EXPORT_OK = qw{
|
||||
causes_fail
|
||||
diagnostics
|
||||
global
|
||||
increments_count
|
||||
no_display
|
||||
sets_plan
|
||||
subtest_id
|
||||
summary
|
||||
terminate
|
||||
uuid
|
||||
};
|
||||
our %EXPORT_TAGS = ( ALL => \@EXPORT_OK );
|
||||
|
||||
our $CYCLE_DETECT = 0;
|
||||
sub _get_facet_data {
|
||||
my $in = shift;
|
||||
|
||||
if (blessed($in) && $in->isa('Test2::Event')) {
|
||||
confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)"
|
||||
if $CYCLE_DETECT;
|
||||
|
||||
local $CYCLE_DETECT = 1;
|
||||
return $in->facet_data;
|
||||
}
|
||||
|
||||
return $in if ref($in) eq 'HASH';
|
||||
|
||||
croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref";
|
||||
}
|
||||
|
||||
sub causes_fail {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
|
||||
return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}};
|
||||
|
||||
if (my $control = $facet_data->{control}) {
|
||||
return 1 if $control->{halt};
|
||||
return 1 if $control->{terminate};
|
||||
}
|
||||
|
||||
return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}};
|
||||
return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass};
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub diagnostics {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return 1 if $facet_data->{errors} && @{$facet_data->{errors}};
|
||||
return 0 unless $facet_data->{info} && @{$facet_data->{info}};
|
||||
return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0;
|
||||
}
|
||||
|
||||
sub global {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return 0 unless $facet_data->{control};
|
||||
return $facet_data->{control}->{global};
|
||||
}
|
||||
|
||||
sub increments_count {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return $facet_data->{assert} ? 1 : 0;
|
||||
}
|
||||
|
||||
sub no_display {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return 0 unless $facet_data->{about};
|
||||
return $facet_data->{about}->{no_display};
|
||||
}
|
||||
|
||||
sub sets_plan {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
my $plan = $facet_data->{plan} or return;
|
||||
my @out = ($plan->{count} || 0);
|
||||
|
||||
if ($plan->{skip}) {
|
||||
push @out => 'SKIP';
|
||||
push @out => $plan->{details} if defined $plan->{details};
|
||||
}
|
||||
elsif ($plan->{none}) {
|
||||
push @out => 'NO PLAN'
|
||||
}
|
||||
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub subtest_id {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return undef unless $facet_data->{parent};
|
||||
return $facet_data->{parent}->{hid};
|
||||
}
|
||||
|
||||
sub summary {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return '' unless $facet_data->{about} && $facet_data->{about}->{details};
|
||||
return $facet_data->{about}->{details};
|
||||
}
|
||||
|
||||
sub terminate {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return undef unless $facet_data->{control};
|
||||
return $facet_data->{control}->{terminate};
|
||||
}
|
||||
|
||||
sub uuid {
|
||||
my $in = shift;
|
||||
|
||||
if ($CYCLE_DETECT) {
|
||||
if (blessed($in) && $in->isa('Test2::Event')) {
|
||||
my $meth = $in->can('uuid');
|
||||
$meth = $in->can('SUPER::uuid') if $meth == \&uuid;
|
||||
my $uuid = $in->$meth if $meth && $meth != \&uuid;
|
||||
return $uuid if $uuid;
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $facet_data = _get_facet_data($in);
|
||||
return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid};
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Facets2Legacy - Convert facet data to the legacy event API.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exports several subroutines from the older event API (see
|
||||
L<Test2::Event>). These subroutines can be used as methods on any object that
|
||||
provides a custom C<facet_data()> method. These subroutines can also be used as
|
||||
functions that take a facet data hashref as arguments.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=head2 AS METHODS
|
||||
|
||||
package My::Event;
|
||||
|
||||
use Test2::Util::Facets2Legacy ':ALL';
|
||||
|
||||
sub facet_data { return { ... } }
|
||||
|
||||
Then to use it:
|
||||
|
||||
my $e = My::Event->new(...);
|
||||
|
||||
my $causes_fail = $e->causes_fail;
|
||||
my $summary = $e->summary;
|
||||
....
|
||||
|
||||
=head2 AS FUNCTIONS
|
||||
|
||||
use Test2::Util::Facets2Legacy ':ALL';
|
||||
|
||||
my $f = {
|
||||
assert => { ... },
|
||||
info => [{...}, ...],
|
||||
control => {...},
|
||||
...
|
||||
};
|
||||
|
||||
my $causes_fail = causes_fail($f);
|
||||
my $summary = summary($f);
|
||||
|
||||
=head1 NOTE ON CYCLES
|
||||
|
||||
When used as methods, all these subroutines call C<< $e->facet_data() >>. The
|
||||
default C<facet_data()> method in L<Test2::Event> relies on the legacy methods
|
||||
this module emulates in order to work. As a result of this it is very easy to
|
||||
create infinite recursion bugs.
|
||||
|
||||
These methods have cycle detection and will throw an exception early if a cycle
|
||||
is detected. C<uuid()> is currently the only subroutine in this library that
|
||||
has a fallback behavior when cycles are detected.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
Nothing is exported by default. You must specify which methods to import, or
|
||||
use the ':ALL' tag.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $bool = $e->causes_fail()
|
||||
|
||||
=item $bool = causes_fail($f)
|
||||
|
||||
Check if the event or facets result in a failing state.
|
||||
|
||||
=item $bool = $e->diagnostics()
|
||||
|
||||
=item $bool = diagnostics($f)
|
||||
|
||||
Check if the event or facets contain any diagnostics information.
|
||||
|
||||
=item $bool = $e->global()
|
||||
|
||||
=item $bool = global($f)
|
||||
|
||||
Check if the event or facets need to be globally processed.
|
||||
|
||||
=item $bool = $e->increments_count()
|
||||
|
||||
=item $bool = increments_count($f)
|
||||
|
||||
Check if the event or facets make an assertion.
|
||||
|
||||
=item $bool = $e->no_display()
|
||||
|
||||
=item $bool = no_display($f)
|
||||
|
||||
Check if the event or facets should be rendered or hidden.
|
||||
|
||||
=item ($max, $directive, $reason) = $e->sets_plan()
|
||||
|
||||
=item ($max, $directive, $reason) = sets_plan($f)
|
||||
|
||||
Check if the event or facets set a plan, and return the plan details.
|
||||
|
||||
=item $id = $e->subtest_id()
|
||||
|
||||
=item $id = subtest_id($f)
|
||||
|
||||
Get the subtest id, if any.
|
||||
|
||||
=item $string = $e->summary()
|
||||
|
||||
=item $string = summary($f)
|
||||
|
||||
Get the summary of the event or facets hash, if any.
|
||||
|
||||
=item $undef_or_int = $e->terminate()
|
||||
|
||||
=item $undef_or_int = terminate($f)
|
||||
|
||||
Check if the event or facets should result in process termination, if so the
|
||||
exit code is returned (which could be 0). undef is returned if no termination
|
||||
is requested.
|
||||
|
||||
=item $uuid = $e->uuid()
|
||||
|
||||
=item $uuid = uuid($f)
|
||||
|
||||
Get the UUID of the facets or event.
|
||||
|
||||
B<Note:> This will fall back to C<< $e->SUPER::uuid() >> if a cycle is
|
||||
detected and an event is used as the argument.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
L<https://github.com/Test-More/test-more/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2020 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.
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
251
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Grabber.pm
Normal file
251
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Grabber.pm
Normal file
|
|
@ -0,0 +1,251 @@
|
|||
package Test2::Util::Grabber;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use Test2::Hub::Interceptor();
|
||||
use Test2::EventFacet::Trace();
|
||||
|
||||
use Test2::API qw/test2_stack test2_ipc/;
|
||||
|
||||
use Test2::Util::HashBase qw/hub finished _events term_size <state <trace/;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
# Make sure we have a hub on the stack
|
||||
test2_stack->top();
|
||||
|
||||
my $hub = test2_stack->new_hub(
|
||||
class => 'Test2::Hub::Interceptor',
|
||||
formatter => undef,
|
||||
no_ending => 1,
|
||||
);
|
||||
|
||||
$self->{+HUB} = $hub;
|
||||
|
||||
my @events;
|
||||
$hub->listen(sub { push @events => $_[1] });
|
||||
|
||||
$self->{+_EVENTS} = \@events;
|
||||
|
||||
$self->{+TERM_SIZE} = $ENV{TS_TERM_SIZE};
|
||||
$ENV{TS_TERM_SIZE} = 80;
|
||||
|
||||
my $trace = $self->{+TRACE} ||= Test2::EventFacet::Trace->new(frame => [caller(1)]);
|
||||
my $state = $self->{+STATE} ||= {};
|
||||
$hub->clean_inherited(trace => $trace, state => $state);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub flush {
|
||||
my $self = shift;
|
||||
my $out = [@{$self->{+_EVENTS}}];
|
||||
@{$self->{+_EVENTS}} = ();
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub events {
|
||||
my $self = shift;
|
||||
# Copy
|
||||
return [@{$self->{+_EVENTS}}];
|
||||
}
|
||||
|
||||
sub finish {
|
||||
my ($self) = @_; # Do not shift;
|
||||
$_[0] = undef;
|
||||
|
||||
if (defined $self->{+TERM_SIZE}) {
|
||||
$ENV{TS_TERM_SIZE} = $self->{+TERM_SIZE};
|
||||
}
|
||||
else {
|
||||
delete $ENV{TS_TERM_SIZE};
|
||||
}
|
||||
|
||||
my $hub = $self->{+HUB};
|
||||
|
||||
$self->{+FINISHED} = 1;
|
||||
test2_stack()->pop($hub);
|
||||
|
||||
my $trace = $self->{+TRACE} ||= Test2::EventFacet::Trace->new(frame => [caller(1)]);
|
||||
my $state = $self->{+STATE} ||= {};
|
||||
$hub->clean_inherited(trace => $trace, state => $state);
|
||||
|
||||
my $dbg = Test2::EventFacet::Trace->new(
|
||||
frame => [caller(0)],
|
||||
);
|
||||
$hub->finalize($dbg, 1)
|
||||
if !$hub->no_ending
|
||||
&& !$hub->state->ended;
|
||||
|
||||
return $self->flush;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
return if $self->{+FINISHED};
|
||||
test2_stack->pop($self->{+HUB});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Grabber - Object used to temporarily intercept all events.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Once created this object will intercept and stash all events sent to the shared
|
||||
L<Test2::Hub> object. Once the object is destroyed, events will once
|
||||
again be sent to the shared hub.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2 qw/Core Grab/;
|
||||
|
||||
my $grab = grab();
|
||||
|
||||
# Generate some events, they are intercepted.
|
||||
ok(1, "pass");
|
||||
ok(0, "fail");
|
||||
|
||||
my $events_a = $grab->flush;
|
||||
|
||||
# Generate some more events, they are intercepted.
|
||||
ok(1, "pass");
|
||||
ok(0, "fail");
|
||||
|
||||
# Same as flush, except it destroys the grab object.
|
||||
my $events_b = $grab->finish;
|
||||
|
||||
After calling C<finish()> the grab object is destroyed and C<$grab> is set to
|
||||
undef. C<$events_a> is an arrayref with the first two events. C<$events_b> is an
|
||||
arrayref with the second two events.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $grab = grab()
|
||||
|
||||
This lets you intercept all events for a section of code without adding
|
||||
anything to your call stack. This is useful for things that are sensitive to
|
||||
changes in the stack depth.
|
||||
|
||||
my $grab = grab();
|
||||
ok(1, 'foo');
|
||||
ok(0, 'bar');
|
||||
|
||||
# $grab is magically undef after this.
|
||||
my $events = $grab->finish;
|
||||
|
||||
is(@$events, 2, "grabbed two events.");
|
||||
|
||||
When you call C<finish()> the C<$grab> object will automagically undef itself,
|
||||
but only for the reference used in the method call. If you have other
|
||||
references to the C<$grab> object they will not be set to undef.
|
||||
|
||||
If the C<$grab> object is destroyed without calling C<finish()>, it will
|
||||
automatically clean up after itself and restore the parent hub.
|
||||
|
||||
{
|
||||
my $grab = grab();
|
||||
# Things are grabbed
|
||||
}
|
||||
# Things are back to normal
|
||||
|
||||
By default the hub used has C<no_ending> set to true. This will prevent the hub
|
||||
from enforcing that you issued a plan and ran at least one test. You can turn
|
||||
enforcement back one like this:
|
||||
|
||||
$grab->hub->set_no_ending(0);
|
||||
|
||||
With C<no_ending> turned off, C<finish> will run the post-test checks to
|
||||
enforce the plan and that tests were run. In many cases this will result in
|
||||
additional events in your events array.
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $grab = $class->new()
|
||||
|
||||
Create a new grab object, immediately starts intercepting events.
|
||||
|
||||
=item $ar = $grab->flush()
|
||||
|
||||
Get an arrayref of all the events so far, clearing the grab objects internal
|
||||
list.
|
||||
|
||||
=item $ar = $grab->events()
|
||||
|
||||
Get an arrayref of all events so far. Does not clear the internal list.
|
||||
|
||||
=item $ar = $grab->finish()
|
||||
|
||||
Get an arrayref of all the events, then destroy the grab object.
|
||||
|
||||
=item $hub = $grab->hub()
|
||||
|
||||
Get the hub that is used by the grab event.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ENDING BEHAVIOR
|
||||
|
||||
By default the hub used has C<no_ending> set to true. This will prevent the hub
|
||||
from enforcing that you issued a plan and ran at least one test. You can turn
|
||||
enforcement back one like this:
|
||||
|
||||
$grab->hub->set_no_ending(0);
|
||||
|
||||
With C<no_ending> turned off, C<finish> will run the post-test checks to
|
||||
enforce the plan and that tests were run. In many cases this will result in
|
||||
additional events in your events array.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test2::Tools::Intercept> - Accomplish the same thing, but using
|
||||
blocks instead.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<https://github.com/Test-More/Test2-Suite/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
See F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
76
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Guard.pm
Normal file
76
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Guard.pm
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
package Test2::Util::Guard;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw(confess);
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
sub new {
|
||||
confess "Can't create a Test2::Util::Guard in void context" unless (defined wantarray);
|
||||
|
||||
my $class = shift;
|
||||
my $handler = shift() || die 'Test2::Util::Guard::new: no handler supplied';
|
||||
my $ref = ref $handler || '';
|
||||
|
||||
die "Test2::Util::new: invalid handler - expected CODE ref, got: '$ref'"
|
||||
unless ref($handler) eq 'CODE';
|
||||
|
||||
bless [ 0, $handler ], ref $class || $class;
|
||||
}
|
||||
|
||||
sub dismiss {
|
||||
my $self = shift;
|
||||
my $dismiss = @_ ? shift : 1;
|
||||
|
||||
$self->[0] = $dismiss;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
my ($dismiss, $handler) = @$self;
|
||||
|
||||
$handler->() unless ($dismiss);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Guard - Inline copy of L<Scope::Guard>
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<Scope::Guard>
|
||||
|
||||
=head1 ORIGINAL AUTHOR
|
||||
|
||||
=over 4
|
||||
|
||||
=item chocolateboy <chocolate@cpan.org>
|
||||
|
||||
=back
|
||||
|
||||
=head2 INLINE AND MODIFICATION AUTHOR
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2005-2015, chocolateboy.
|
||||
|
||||
Modified copy is Copyright 2023 Chad Granum E<lt>exodist7@gmail.comE<gt>.
|
||||
|
||||
This module is free software. It may be used, redistributed and/or modified under the same terms
|
||||
as Perl itself.
|
||||
|
||||
=cut
|
||||
473
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/HashBase.pm
Normal file
473
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/HashBase.pm
Normal file
|
|
@ -0,0 +1,473 @@
|
|||
package Test2::Util::HashBase;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
#################################################################
|
||||
# #
|
||||
# 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::HB_VERSION = '0.009';
|
||||
*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;
|
||||
}
|
||||
|
||||
|
||||
require Carp;
|
||||
{
|
||||
no warnings 'once';
|
||||
$Carp::Internal{+__PACKAGE__} = 1;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
# these are not strictly equivalent, but for out use we don't care
|
||||
# about order
|
||||
*_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
|
||||
no strict 'refs';
|
||||
my @packages = ($_[0]);
|
||||
my %seen;
|
||||
for my $package (@packages) {
|
||||
push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
|
||||
}
|
||||
return \@packages;
|
||||
}
|
||||
}
|
||||
|
||||
my %SPEC = (
|
||||
'^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1},
|
||||
'-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1},
|
||||
'>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1},
|
||||
'<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
|
||||
'+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
|
||||
);
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my $into = caller;
|
||||
|
||||
# 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 = (
|
||||
($into->can('new') ? () : (new => \&_new)),
|
||||
(map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
|
||||
(
|
||||
map {
|
||||
my $p = substr($_, 0, 1);
|
||||
my $x = $_;
|
||||
|
||||
my $spec = $SPEC{$p} || {reader => 1, writer => 1};
|
||||
|
||||
substr($x, 0, 1) = '' if $spec->{strip};
|
||||
push @$attr_list => $x;
|
||||
my ($sub, $attr) = (uc $x, $x);
|
||||
|
||||
$attr_subs->{$sub} = sub() { $attr };
|
||||
my %out = ($sub => $attr_subs->{$sub});
|
||||
|
||||
$out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader};
|
||||
$out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer};
|
||||
$out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only};
|
||||
$out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer};
|
||||
|
||||
%out;
|
||||
} @_
|
||||
),
|
||||
);
|
||||
|
||||
no strict 'refs';
|
||||
*{"$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 = 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;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::HashBase - Build hash based classes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A class:
|
||||
|
||||
package My::Class;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Generate 3 accessors
|
||||
use Test2::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/;
|
||||
|
||||
# Chance to initialize defaults
|
||||
sub init {
|
||||
my $self = shift; # No other args
|
||||
$self->{+FOO} ||= "foo";
|
||||
$self->{+BAR} ||= "bar";
|
||||
$self->{+BAZ} ||= "baz";
|
||||
$self->{+BAT} ||= "bat";
|
||||
$self->{+BAN} ||= "ban";
|
||||
$self->{+BOO} ||= "boo";
|
||||
}
|
||||
|
||||
sub print {
|
||||
print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO;
|
||||
}
|
||||
|
||||
Subclass it
|
||||
|
||||
package My::Subclass;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Note, you should subclass before loading HashBase.
|
||||
use base 'My::Class';
|
||||
use Test2::Util::HashBase qw/bub/;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
# We get the constants from the base class for free.
|
||||
$self->{+FOO} ||= 'SubFoo';
|
||||
$self->{+BUB} ||= 'bub';
|
||||
|
||||
$self->SUPER::init();
|
||||
}
|
||||
|
||||
use it:
|
||||
|
||||
package main;
|
||||
use strict;
|
||||
use warnings;
|
||||
use My::Class;
|
||||
|
||||
# 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']);
|
||||
|
||||
# Readers!
|
||||
my $foo = $one->foo; # 'MyFoo'
|
||||
my $bar = $one->bar; # 'MyBar'
|
||||
my $baz = $one->baz; # Defaulted to: 'baz'
|
||||
my $bat = $one->bat; # Defaulted to: 'bat'
|
||||
# '>ban' means setter only, no reader
|
||||
# '+boo' means no setter or reader, just the BOO constant
|
||||
|
||||
# Setters!
|
||||
$one->set_foo('A Foo');
|
||||
|
||||
#'-bar' means read-only, so the setter will throw an exception (but is defined).
|
||||
$one->set_bar('A bar');
|
||||
|
||||
# '^baz' means deprecated setter, this will warn about the setter being
|
||||
# deprecated.
|
||||
$one->set_baz('A Baz');
|
||||
|
||||
# '<bat' means no setter defined at all
|
||||
# '+boo' means no setter or reader, just the BOO constant
|
||||
|
||||
$one->{+FOO} = 'xxx';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package is used to generate classes based on hashrefs. Using this class
|
||||
will give you a C<new()> method, as well as generating accessors you request.
|
||||
Generated accessors will be getters, C<set_ACCESSOR> setters will also be
|
||||
generated for you. You also get constants for each accessor (all caps) which
|
||||
return the key into the hash for that accessor. Single inheritance is also
|
||||
supported.
|
||||
|
||||
=head1 THIS IS A BUNDLED COPY OF HASHBASE
|
||||
|
||||
This is a bundled copy of L<Object::HashBase>. This file was generated using
|
||||
the
|
||||
C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl>
|
||||
script.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 PROVIDED BY HASH BASE
|
||||
|
||||
=over 4
|
||||
|
||||
=item $it = $class->new(%PAIRS)
|
||||
|
||||
=item $it = $class->new(\%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.
|
||||
|
||||
B<If you do not want this method you can define your own> you just have to
|
||||
declare it before loading L<Test2::Util::HashBase>.
|
||||
|
||||
package My::Package;
|
||||
|
||||
# predeclare new() so that HashBase does not give us one.
|
||||
sub new;
|
||||
|
||||
use Test2::Util::HashBase qw/foo bar baz/;
|
||||
|
||||
# Now we define our own new method.
|
||||
sub new { ... }
|
||||
|
||||
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
|
||||
|
||||
=over 4
|
||||
|
||||
=item $self->init()
|
||||
|
||||
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/;
|
||||
|
||||
This will generate the following subs in your namespace:
|
||||
|
||||
=over 4
|
||||
|
||||
=item foo()
|
||||
|
||||
Getter, used to get the value of the C<foo> field.
|
||||
|
||||
=item set_foo()
|
||||
|
||||
Setter, used to set the value of the C<foo> field.
|
||||
|
||||
=item FOO()
|
||||
|
||||
Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
|
||||
also get this function as a constant, not simply a method, that means it is
|
||||
copied into the subclass namespace.
|
||||
|
||||
The main reason for using these constants is to help avoid spelling mistakes
|
||||
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
|
||||
|
||||
=head2 NO SETTER
|
||||
|
||||
use Test2::Util::HashBase qw/<foo/;
|
||||
|
||||
Only gives you a reader, no C<set_foo> method is defined at all.
|
||||
|
||||
=head2 NO READER
|
||||
|
||||
use Test2::Util::HashBase qw/>foo/;
|
||||
|
||||
Only gives you a write (C<set_foo>), no C<foo> method is defined at all.
|
||||
|
||||
=head2 CONSTANT ONLY
|
||||
|
||||
use Test2::Util::HashBase qw/+foo/;
|
||||
|
||||
This does not create any methods for you, it just adds the C<FOO> constant.
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
You can subclass an existing HashBase class.
|
||||
|
||||
use base 'Another::HashBase::Class';
|
||||
use Test2::Util::HashBase qw/foo bar baz/;
|
||||
|
||||
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
|
||||
L<https://github.com/Test-More/HashBase/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2017 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.
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
812
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Importer.pm
Normal file
812
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Importer.pm
Normal file
|
|
@ -0,0 +1,812 @@
|
|||
package Test2::Util::Importer;
|
||||
use strict; no strict 'refs';
|
||||
use warnings; no warnings 'once';
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
my %SIG_TO_SLOT = (
|
||||
'&' => 'CODE',
|
||||
'$' => 'SCALAR',
|
||||
'%' => 'HASH',
|
||||
'@' => 'ARRAY',
|
||||
'*' => 'GLOB',
|
||||
);
|
||||
|
||||
our %IMPORTED;
|
||||
|
||||
# This will be used to check if an import arg is a version number
|
||||
my %NUMERIC = map +($_ => 1), 0 .. 9;
|
||||
|
||||
sub IMPORTER_MENU() {
|
||||
return (
|
||||
export_ok => [qw/optimal_import/],
|
||||
export_anon => {
|
||||
import => sub {
|
||||
my $from = shift;
|
||||
my @caller = caller(0);
|
||||
|
||||
_version_check($from, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)};
|
||||
|
||||
my $file = _mod_to_file($from);
|
||||
_load_file(\@caller, $file) unless $INC{$file};
|
||||
|
||||
return if optimal_import($from, $caller[0], \@caller, @_);
|
||||
|
||||
my $self = __PACKAGE__->new(
|
||||
from => $from,
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
$self->do_import($caller[0], @_);
|
||||
},
|
||||
},
|
||||
);
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
#
|
||||
# These are class methods
|
||||
# import and unimport are what you would expect.
|
||||
# import_into and unimport_from are the indirect forms you can use in other
|
||||
# package import() methods.
|
||||
#
|
||||
# These all attempt to do a fast optimal-import if possible, then fallback to
|
||||
# the full-featured import that constructs an object when needed.
|
||||
#
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
my @caller = caller(0);
|
||||
|
||||
_version_check($class, \@caller, shift @_) if @_ && $NUMERIC{substr($_[0], 0, 1)};
|
||||
|
||||
return unless @_;
|
||||
|
||||
my ($from, @args) = @_;
|
||||
|
||||
my $file = _mod_to_file($from);
|
||||
_load_file(\@caller, $file) unless $INC{$file};
|
||||
|
||||
return if optimal_import($from, $caller[0], \@caller, @args);
|
||||
|
||||
my $self = $class->new(
|
||||
from => $from,
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
$self->do_import($caller[0], @args);
|
||||
}
|
||||
|
||||
sub unimport {
|
||||
my $class = shift;
|
||||
my @caller = caller(0);
|
||||
|
||||
my $self = $class->new(
|
||||
from => $caller[0],
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
$self->do_unimport(@_);
|
||||
}
|
||||
|
||||
sub import_into {
|
||||
my $class = shift;
|
||||
my ($from, $into, @args) = @_;
|
||||
|
||||
my @caller;
|
||||
|
||||
if (ref($into)) {
|
||||
@caller = @$into;
|
||||
$into = $caller[0];
|
||||
}
|
||||
elsif ($into =~ m/^\d+$/) {
|
||||
@caller = caller($into + 1);
|
||||
$into = $caller[0];
|
||||
}
|
||||
else {
|
||||
@caller = caller(0);
|
||||
}
|
||||
|
||||
my $file = _mod_to_file($from);
|
||||
_load_file(\@caller, $file) unless $INC{$file};
|
||||
|
||||
return if optimal_import($from, $into, \@caller, @args);
|
||||
|
||||
my $self = $class->new(
|
||||
from => $from,
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
$self->do_import($into, @args);
|
||||
}
|
||||
|
||||
sub unimport_from {
|
||||
my $class = shift;
|
||||
my ($from, @args) = @_;
|
||||
|
||||
my @caller;
|
||||
if ($from =~ m/^\d+$/) {
|
||||
@caller = caller($from + 1);
|
||||
$from = $caller[0];
|
||||
}
|
||||
else {
|
||||
@caller = caller(0);
|
||||
}
|
||||
|
||||
my $self = $class->new(
|
||||
from => $from,
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
$self->do_unimport(@args);
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
#
|
||||
# Constructors
|
||||
#
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $caller = $params{caller} || [caller()];
|
||||
|
||||
die "You must specify a package to import from at $caller->[1] line $caller->[2].\n"
|
||||
unless $params{from};
|
||||
|
||||
return bless {
|
||||
from => $params{from},
|
||||
caller => $params{caller}, # Do not use our caller.
|
||||
}, $class;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
#
|
||||
# Shortcuts for getting symbols without any namespace modifications
|
||||
#
|
||||
|
||||
sub get {
|
||||
my $proto = shift;
|
||||
my @caller = caller(1);
|
||||
|
||||
my $self = ref($proto) ? $proto : $proto->new(
|
||||
from => shift(@_),
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
my %result;
|
||||
$self->do_import($caller[0], @_, sub { $result{$_[0]} = $_[1] });
|
||||
return \%result;
|
||||
}
|
||||
|
||||
sub get_list {
|
||||
my $proto = shift;
|
||||
my @caller = caller(1);
|
||||
|
||||
my $self = ref($proto) ? $proto : $proto->new(
|
||||
from => shift(@_),
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
my @result;
|
||||
$self->do_import($caller[0], @_, sub { push @result => $_[1] });
|
||||
return @result;
|
||||
}
|
||||
|
||||
sub get_one {
|
||||
my $proto = shift;
|
||||
my @caller = caller(1);
|
||||
|
||||
my $self = ref($proto) ? $proto : $proto->new(
|
||||
from => shift(@_),
|
||||
caller => \@caller,
|
||||
);
|
||||
|
||||
my $result;
|
||||
$self->do_import($caller[0], @_, sub { $result = $_[1] });
|
||||
return $result;
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
#
|
||||
# Object methods
|
||||
#
|
||||
|
||||
sub do_import {
|
||||
my $self = shift;
|
||||
|
||||
my ($into, $versions, $exclude, $import, $set) = $self->parse_args(@_);
|
||||
|
||||
# Exporter supported multiple version numbers being listed...
|
||||
_version_check($self->from, $self->get_caller, @$versions) if @$versions;
|
||||
|
||||
return unless @$import;
|
||||
|
||||
$self->_handle_fail($into, $import) if $self->menu($into)->{fail};
|
||||
$self->_set_symbols($into, $exclude, $import, $set);
|
||||
}
|
||||
|
||||
sub do_unimport {
|
||||
my $self = shift;
|
||||
|
||||
my $from = $self->from;
|
||||
my $imported = $IMPORTED{$from} or $self->croak("'$from' does not have any imports to remove");
|
||||
|
||||
my %allowed = map { $_ => 1 } @$imported;
|
||||
|
||||
my @args = @_ ? @_ : @$imported;
|
||||
|
||||
my $stash = \%{"$from\::"};
|
||||
|
||||
for my $name (@args) {
|
||||
$name =~ s/^&//;
|
||||
|
||||
$self->croak("Sub '$name' was not imported using " . ref($self)) unless $allowed{$name};
|
||||
|
||||
my $glob = delete $stash->{$name};
|
||||
local *GLOBCLONE = *$glob;
|
||||
|
||||
for my $type (qw/SCALAR HASH ARRAY FORMAT IO/) {
|
||||
next unless defined(*{$glob}{$type});
|
||||
*{"$from\::$name"} = *{$glob}{$type}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub from { $_[0]->{from} }
|
||||
|
||||
sub from_file {
|
||||
my $self = shift;
|
||||
|
||||
$self->{from_file} ||= _mod_to_file($self->{from});
|
||||
|
||||
return $self->{from_file};
|
||||
}
|
||||
|
||||
sub load_from {
|
||||
my $self = shift;
|
||||
my $from_file = $self->from_file;
|
||||
my $this_file = __FILE__;
|
||||
|
||||
return if $INC{$from_file};
|
||||
|
||||
my $caller = $self->get_caller;
|
||||
|
||||
_load_file($caller, $from_file);
|
||||
}
|
||||
|
||||
sub get_caller {
|
||||
my $self = shift;
|
||||
return $self->{caller} if $self->{caller};
|
||||
|
||||
my $level = 1;
|
||||
while(my @caller = caller($level++)) {
|
||||
return \@caller if @caller && !$caller[0]->isa(__PACKAGE__);
|
||||
last unless @caller;
|
||||
}
|
||||
|
||||
# Fallback
|
||||
return [caller(0)];
|
||||
}
|
||||
|
||||
sub croak {
|
||||
my $self = shift;
|
||||
my ($msg) = @_;
|
||||
my $caller = $self->get_caller;
|
||||
my $file = $caller->[1] || 'unknown file';
|
||||
my $line = $caller->[2] || 'unknown line';
|
||||
die "$msg at $file line $line.\n";
|
||||
}
|
||||
|
||||
sub carp {
|
||||
my $self = shift;
|
||||
my ($msg) = @_;
|
||||
my $caller = $self->get_caller;
|
||||
my $file = $caller->[1] || 'unknown file';
|
||||
my $line = $caller->[2] || 'unknown line';
|
||||
warn "$msg at $file line $line.\n";
|
||||
}
|
||||
|
||||
sub menu {
|
||||
my $self = shift;
|
||||
my ($into) = @_;
|
||||
|
||||
$self->croak("menu() requires the name of the destination package")
|
||||
unless $into;
|
||||
|
||||
my $for = $self->{menu_for};
|
||||
delete $self->{menu} if $for && $for ne $into;
|
||||
return $self->{menu} || $self->reload_menu($into);
|
||||
}
|
||||
|
||||
sub reload_menu {
|
||||
my $self = shift;
|
||||
my ($into) = @_;
|
||||
|
||||
$self->croak("reload_menu() requires the name of the destination package")
|
||||
unless $into;
|
||||
|
||||
my $from = $self->from;
|
||||
|
||||
if (my $menu_sub = *{"$from\::IMPORTER_MENU"}{CODE}) {
|
||||
# Hook, other exporter modules can define this method to be compatible with
|
||||
# Importer.pm
|
||||
|
||||
my %got = $from->$menu_sub($into, $self->get_caller);
|
||||
|
||||
$got{export} ||= [];
|
||||
$got{export_ok} ||= [];
|
||||
$got{export_tags} ||= {};
|
||||
$got{export_fail} ||= [];
|
||||
$got{export_anon} ||= {};
|
||||
$got{export_magic} ||= {};
|
||||
|
||||
$self->croak("'$from' provides both 'generate' and 'export_gen' in its IMPORTER_MENU (They are exclusive, module must pick 1)")
|
||||
if $got{export_gen} && $got{generate};
|
||||
|
||||
$got{export_gen} ||= {};
|
||||
|
||||
$self->{menu} = $self->_build_menu($into => \%got, 1);
|
||||
}
|
||||
else {
|
||||
my %got;
|
||||
$got{export} = \@{"$from\::EXPORT"};
|
||||
$got{export_ok} = \@{"$from\::EXPORT_OK"};
|
||||
$got{export_tags} = \%{"$from\::EXPORT_TAGS"};
|
||||
$got{export_fail} = \@{"$from\::EXPORT_FAIL"};
|
||||
$got{export_gen} = \%{"$from\::EXPORT_GEN"};
|
||||
$got{export_anon} = \%{"$from\::EXPORT_ANON"};
|
||||
$got{export_magic} = \%{"$from\::EXPORT_MAGIC"};
|
||||
|
||||
$self->{menu} = $self->_build_menu($into => \%got, 0);
|
||||
}
|
||||
|
||||
$self->{menu_for} = $into;
|
||||
|
||||
return $self->{menu};
|
||||
}
|
||||
|
||||
sub _build_menu {
|
||||
my $self = shift;
|
||||
my ($into, $got, $new_style) = @_;
|
||||
|
||||
my $from = $self->from;
|
||||
|
||||
my $export = $got->{export} || [];
|
||||
my $export_ok = $got->{export_ok} || [];
|
||||
my $export_tags = $got->{export_tags} || {};
|
||||
my $export_fail = $got->{export_fail} || [];
|
||||
my $export_anon = $got->{export_anon} || {};
|
||||
my $export_gen = $got->{export_gen} || {};
|
||||
my $export_magic = $got->{export_magic} || {};
|
||||
|
||||
my $generate = $got->{generate};
|
||||
|
||||
$generate ||= sub {
|
||||
my $symbol = shift;
|
||||
my ($sig, $name) = ($symbol =~ m/^(\W?)(.*)$/);
|
||||
$sig ||= '&';
|
||||
|
||||
my $do = $export_gen->{"${sig}${name}"};
|
||||
$do ||= $export_gen->{$name} if !$sig || $sig eq '&';
|
||||
|
||||
return undef unless $do;
|
||||
|
||||
$from->$do($into, $symbol);
|
||||
} if $export_gen && keys %$export_gen;
|
||||
|
||||
my $lookup = {};
|
||||
my $exports = {};
|
||||
for my $sym (@$export, @$export_ok, keys %$export_gen, keys %$export_anon) {
|
||||
my ($sig, $name) = ($sym =~ m/^(\W?)(.*)$/);
|
||||
$sig ||= '&';
|
||||
|
||||
$lookup->{"${sig}${name}"} = 1;
|
||||
$lookup->{$name} = 1 if $sig eq '&';
|
||||
|
||||
next if $export_gen->{"${sig}${name}"};
|
||||
next if $sig eq '&' && $export_gen->{$name};
|
||||
next if $got->{generate} && $generate->("${sig}${name}");
|
||||
|
||||
my $fqn = "$from\::$name";
|
||||
# We cannot use *{$fqn}{TYPE} here, it breaks for autoloaded subs, this
|
||||
# does not:
|
||||
$exports->{"${sig}${name}"} = $export_anon->{$sym} || (
|
||||
$sig eq '&' ? \&{$fqn} :
|
||||
$sig eq '$' ? \${$fqn} :
|
||||
$sig eq '@' ? \@{$fqn} :
|
||||
$sig eq '%' ? \%{$fqn} :
|
||||
$sig eq '*' ? \*{$fqn} :
|
||||
# Sometimes people (CGI::Carp) put invalid names (^name=) into
|
||||
# @EXPORT. We simply go to 'next' in these cases. These modules
|
||||
# have hooks to prevent anyone actually trying to import these.
|
||||
next
|
||||
);
|
||||
}
|
||||
|
||||
my $f_import = $new_style || $from->can('import');
|
||||
$self->croak("'$from' does not provide any exports")
|
||||
unless $new_style
|
||||
|| keys %$exports
|
||||
|| $from->isa('Exporter')
|
||||
|| ($INC{'Exporter.pm'} && $f_import && $f_import == \&Exporter::import);
|
||||
|
||||
# Do not cleanup or normalize the list added to the DEFAULT tag, legacy....
|
||||
my $tags = {
|
||||
%$export_tags,
|
||||
'DEFAULT' => [ @$export ],
|
||||
};
|
||||
|
||||
# Add 'ALL' tag unless already specified. We want to normalize it.
|
||||
$tags->{ALL} ||= [ sort grep {m/^[\&\$\@\%\*]/} keys %$lookup ];
|
||||
|
||||
my $fail = @$export_fail ? {
|
||||
map {
|
||||
my ($sig, $name) = (m/^(\W?)(.*)$/);
|
||||
$sig ||= '&';
|
||||
("${sig}${name}" => 1, $sig eq '&' ? ($name => 1) : ())
|
||||
} @$export_fail
|
||||
} : undef;
|
||||
|
||||
my $menu = {
|
||||
lookup => $lookup,
|
||||
exports => $exports,
|
||||
tags => $tags,
|
||||
fail => $fail,
|
||||
generate => $generate,
|
||||
magic => $export_magic,
|
||||
};
|
||||
|
||||
return $menu;
|
||||
}
|
||||
|
||||
sub parse_args {
|
||||
my $self = shift;
|
||||
my ($into, @args) = @_;
|
||||
|
||||
my $menu = $self->menu($into);
|
||||
|
||||
my @out = $self->_parse_args($into, $menu, \@args);
|
||||
pop @out;
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub _parse_args {
|
||||
my $self = shift;
|
||||
my ($into, $menu, $args, $is_tag) = @_;
|
||||
|
||||
my $from = $self->from;
|
||||
my $main_menu = $self->menu($into);
|
||||
$menu ||= $main_menu;
|
||||
|
||||
# First we strip out versions numbers and setters, this simplifies the logic late.
|
||||
my @sets;
|
||||
my @versions;
|
||||
my @leftover;
|
||||
for my $arg (@$args) {
|
||||
no warnings 'void';
|
||||
|
||||
# Code refs are custom setters
|
||||
# If the first character is an ASCII numeric then it is a version number
|
||||
push @sets => $arg and next if ref($arg) eq 'CODE';
|
||||
push @versions => $arg xor next if $NUMERIC{substr($arg, 0, 1)};
|
||||
push @leftover => $arg;
|
||||
}
|
||||
|
||||
$self->carp("Multiple setters specified, only 1 will be used") if @sets > 1;
|
||||
my $set = pop @sets;
|
||||
|
||||
$args = \@leftover;
|
||||
@$args = (':DEFAULT') unless $is_tag || @$args || @versions;
|
||||
|
||||
my %exclude;
|
||||
my @import;
|
||||
|
||||
while(my $full_arg = shift @$args) {
|
||||
my $arg = $full_arg;
|
||||
my $lead = substr($arg, 0, 1);
|
||||
|
||||
my ($spec, $exc);
|
||||
if ($lead eq '!') {
|
||||
$exc = $lead;
|
||||
|
||||
if ($arg eq '!') {
|
||||
# If the current arg is just '!' then we are negating the next item.
|
||||
$arg = shift @$args;
|
||||
}
|
||||
else {
|
||||
# Strip off the '!'
|
||||
substr($arg, 0, 1, '');
|
||||
}
|
||||
|
||||
# Exporter.pm legacy behavior
|
||||
# negated first item implies starting with default set:
|
||||
unshift @$args => ':DEFAULT' unless @import || keys %exclude || @versions;
|
||||
|
||||
# Now we have a new lead character
|
||||
$lead = substr($arg, 0, 1);
|
||||
}
|
||||
else {
|
||||
# If the item is followed by a reference then they are asking us to
|
||||
# do something special...
|
||||
$spec = ref($args->[0]) eq 'HASH' ? shift @$args : {};
|
||||
}
|
||||
|
||||
if($lead eq ':') {
|
||||
substr($arg, 0, 1, '');
|
||||
my $tag = $menu->{tags}->{$arg} or $self->croak("$from does not export the :$arg tag");
|
||||
|
||||
my (undef, $cvers, $cexc, $cimp, $cset, $newmenu) = $self->_parse_args($into, $menu, $tag, $arg);
|
||||
|
||||
$self->croak("Exporter specified version numbers (" . join(', ', @$cvers) . ") in the :$arg tag!")
|
||||
if @$cvers;
|
||||
|
||||
$self->croak("Exporter specified a custom symbol setter in the :$arg tag!")
|
||||
if $cset;
|
||||
|
||||
# Merge excludes
|
||||
%exclude = (%exclude, %$cexc);
|
||||
|
||||
if ($exc) {
|
||||
$exclude{$_} = 1 for grep {!ref($_) && substr($_, 0, 1) ne '+'} map {$_->[0]} @$cimp;
|
||||
}
|
||||
elsif ($spec && keys %$spec) {
|
||||
$self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg")
|
||||
if $spec->{'-as'} && @$cimp > 1;
|
||||
|
||||
for my $set (@$cimp) {
|
||||
my ($sym, $cspec) = @$set;
|
||||
|
||||
# Start with a blind squash, spec from tag overrides the ones inside.
|
||||
my $nspec = {%$cspec, %$spec};
|
||||
|
||||
$nspec->{'-prefix'} = "$spec->{'-prefix'}$cspec->{'-prefix'}" if $spec->{'-prefix'} && $cspec->{'-prefix'};
|
||||
$nspec->{'-postfix'} = "$cspec->{'-postfix'}$spec->{'-postfix'}" if $spec->{'-postfix'} && $cspec->{'-postfix'};
|
||||
|
||||
push @import => [$sym, $nspec];
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @import => @$cimp;
|
||||
}
|
||||
|
||||
# New menu
|
||||
$menu = $newmenu;
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
# Process the item to figure out what symbols are being touched, if it
|
||||
# is a tag or regex than it can be multiple.
|
||||
my @list;
|
||||
if(ref($arg) eq 'Regexp') {
|
||||
@list = sort grep /$arg/, keys %{$menu->{lookup}};
|
||||
}
|
||||
elsif($lead eq '/' && $arg =~ m{^/(.*)/$}) {
|
||||
my $pattern = $1;
|
||||
@list = sort grep /$1/, keys %{$menu->{lookup}};
|
||||
}
|
||||
else {
|
||||
@list = ($arg);
|
||||
}
|
||||
|
||||
# Normalize list, always have a sigil
|
||||
@list = map {m/^\W/ ? $_ : "\&$_" } @list;
|
||||
|
||||
if ($exc) {
|
||||
$exclude{$_} = 1 for @list;
|
||||
}
|
||||
else {
|
||||
$self->croak("Cannot use '-as' to rename multiple symbols included by: $full_arg")
|
||||
if $spec->{'-as'} && @list > 1;
|
||||
|
||||
push @import => [$_, $spec] for @list;
|
||||
}
|
||||
}
|
||||
|
||||
return ($into, \@versions, \%exclude, \@import, $set, $menu);
|
||||
}
|
||||
|
||||
sub _handle_fail {
|
||||
my $self = shift;
|
||||
my ($into, $import) = @_;
|
||||
|
||||
my $from = $self->from;
|
||||
my $menu = $self->menu($into);
|
||||
|
||||
# Historically Exporter would strip the '&' off of sub names passed into export_fail.
|
||||
my @fail = map {my $x = $_->[0]; $x =~ s/^&//; $x} grep $menu->{fail}->{$_->[0]}, @$import or return;
|
||||
|
||||
my @real_fail = $from->can('export_fail') ? $from->export_fail(@fail) : @fail;
|
||||
|
||||
if (@real_fail) {
|
||||
$self->carp(qq["$_" is not implemented by the $from module on this architecture])
|
||||
for @real_fail;
|
||||
|
||||
$self->croak("Can't continue after import errors");
|
||||
}
|
||||
|
||||
$self->reload_menu($menu);
|
||||
return;
|
||||
}
|
||||
|
||||
sub _set_symbols {
|
||||
my $self = shift;
|
||||
my ($into, $exclude, $import, $custom_set) = @_;
|
||||
|
||||
my $from = $self->from;
|
||||
my $menu = $self->menu($into);
|
||||
my $caller = $self->get_caller();
|
||||
|
||||
my $set_symbol = $custom_set || eval <<" EOT" || die $@;
|
||||
# Inherit the callers warning settings. If they have warnings and we
|
||||
# redefine their subs they will hear about it. If they do not have warnings
|
||||
# on they will not.
|
||||
BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] }
|
||||
#line $caller->[2] "$caller->[1]"
|
||||
sub { *{"$into\\::\$_[0]"} = \$_[1] }
|
||||
EOT
|
||||
|
||||
for my $set (@$import) {
|
||||
my ($symbol, $spec) = @$set;
|
||||
|
||||
my ($sig, $name) = ($symbol =~ m/^(\W)(.*)$/) or die "Invalid symbol: $symbol";
|
||||
|
||||
# Find the thing we are actually shoving in a new namespace
|
||||
my $ref = $menu->{exports}->{$symbol};
|
||||
$ref ||= $menu->{generate}->($symbol) if $menu->{generate};
|
||||
|
||||
# Exporter.pm supported listing items in @EXPORT that are not actually
|
||||
# available for export. So if it is listed (lookup) but nothing is
|
||||
# there (!$ref) we simply skip it.
|
||||
$self->croak("$from does not export $symbol") unless $ref || $menu->{lookup}->{"${sig}${name}"};
|
||||
next unless $ref;
|
||||
|
||||
my $type = ref($ref);
|
||||
$type = 'SCALAR' if $type eq 'REF';
|
||||
$self->croak("Symbol '$sig$name' requested, but reference (" . ref($ref) . ") does not match sigil ($sig)")
|
||||
if $ref && $type ne $SIG_TO_SLOT{$sig};
|
||||
|
||||
# If they directly renamed it then we assume they want it under the new
|
||||
# name, otherwise excludes get kicked. It is useful to be able to
|
||||
# exclude an item in a tag/match where the group has a prefix/postfix.
|
||||
next if $exclude->{"${sig}${name}"} && !$spec->{'-as'};
|
||||
|
||||
my $new_name = join '' => ($spec->{'-prefix'} || '', $spec->{'-as'} || $name, $spec->{'-postfix'} || '');
|
||||
|
||||
# Set the symbol (finally!)
|
||||
$set_symbol->($new_name, $ref, sig => $sig, symbol => $symbol, into => $into, from => $from, spec => $spec);
|
||||
|
||||
# The remaining things get skipped with a custom setter
|
||||
next if $custom_set;
|
||||
|
||||
# Record the import so that we can 'unimport'
|
||||
push @{$IMPORTED{$into}} => $new_name if $sig eq '&';
|
||||
|
||||
# Apply magic
|
||||
my $magic = $menu->{magic}->{$symbol};
|
||||
$magic ||= $menu->{magic}->{$name} if $sig eq '&';
|
||||
$from->$magic(into => $into, orig_name => $name, new_name => $new_name, ref => $ref)
|
||||
if $magic;
|
||||
}
|
||||
}
|
||||
|
||||
###########################################################################
|
||||
#
|
||||
# The rest of these are utility functions, not methods!
|
||||
#
|
||||
|
||||
sub _version_check {
|
||||
my ($mod, $caller, @versions) = @_;
|
||||
|
||||
eval <<" EOT" or die $@;
|
||||
#line $caller->[2] "$caller->[1]"
|
||||
\$mod->VERSION(\$_) for \@versions;
|
||||
1;
|
||||
EOT
|
||||
}
|
||||
|
||||
sub _mod_to_file {
|
||||
my $file = shift;
|
||||
$file =~ s{::}{/}g;
|
||||
$file .= '.pm';
|
||||
return $file;
|
||||
}
|
||||
|
||||
sub _load_file {
|
||||
my ($caller, $file) = @_;
|
||||
|
||||
eval <<" EOT" || die $@;
|
||||
#line $caller->[2] "$caller->[1]"
|
||||
require \$file;
|
||||
EOT
|
||||
}
|
||||
|
||||
|
||||
my %HEAVY_VARS = (
|
||||
IMPORTER_MENU => 'CODE', # Origin package has a custom menu
|
||||
EXPORT_FAIL => 'ARRAY', # Origin package has a failure handler
|
||||
EXPORT_GEN => 'HASH', # Origin package has generators
|
||||
EXPORT_ANON => 'HASH', # Origin package has anonymous exports
|
||||
EXPORT_MAGIC => 'HASH', # Origin package has magic to apply post-export
|
||||
);
|
||||
|
||||
sub optimal_import {
|
||||
my ($from, $into, $caller, @args) = @_;
|
||||
|
||||
defined(*{"$from\::$_"}{$HEAVY_VARS{$_}}) and return 0 for keys %HEAVY_VARS;
|
||||
|
||||
# Default to @EXPORT
|
||||
@args = @{"$from\::EXPORT"} unless @args;
|
||||
|
||||
# Subs will be listed without sigil in %allowed, all others keep sigil
|
||||
my %allowed = map +(substr($_, 0, 1) eq '&' ? substr($_, 1) : $_ => 1),
|
||||
@{"$from\::EXPORT"}, @{"$from\::EXPORT_OK"};
|
||||
|
||||
# First check if it is allowed, stripping '&' if necessary, which will also
|
||||
# let scalars in, we will deal with those shortly.
|
||||
# If not allowed return 0 (need to do a heavy import)
|
||||
# if it is allowed then see if it has a CODE slot, if so use it, otherwise
|
||||
# we have a symbol that needs heavy due to non-sub, autoload, etc.
|
||||
# This will not allow $foo to import foo() since '$from' still contains the
|
||||
# sigil making it an invalid symbol name in our globref below.
|
||||
my %final = map +(
|
||||
(!ref($_) && ($allowed{$_} || (substr($_, 0, 1, "") eq '&' && $allowed{$_})))
|
||||
? ($_ => *{"$from\::$_"}{CODE} || return 0)
|
||||
: return 0
|
||||
), @args;
|
||||
|
||||
eval <<" EOT" || die $@;
|
||||
# If the caller has redefine warnings enabled then we want to warn them if
|
||||
# their import redefines things.
|
||||
BEGIN { \${^WARNING_BITS} = \$caller->[9] if defined \$caller->[9] };
|
||||
#line $caller->[2] "$caller->[1]"
|
||||
(*{"$into\\::\$_"} = \$final{\$_}, push \@{\$Test2::Util::Importer::IMPORTED{\$into}} => \$_) for keys %final;
|
||||
1;
|
||||
EOT
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Importer - Inline copy of L<Importer>.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
See L<Importer>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2023 Chad Granum E<lt>exodist7@gmail.comE<gt>.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
See L<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
125
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Ref.pm
Normal file
125
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Ref.pm
Normal file
|
|
@ -0,0 +1,125 @@
|
|||
package Test2::Util::Ref;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use Scalar::Util qw/reftype blessed refaddr/;
|
||||
|
||||
our @EXPORT_OK = qw/rtype render_ref/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub rtype {
|
||||
my ($thing) = @_;
|
||||
return '' unless defined $thing;
|
||||
|
||||
my $rf = ref $thing;
|
||||
my $rt = reftype $thing;
|
||||
|
||||
return '' unless $rf || $rt;
|
||||
return 'REGEXP' if $rf =~ m/Regex/i;
|
||||
return 'REGEXP' if $rt =~ m/Regex/i;
|
||||
return $rt || '';
|
||||
}
|
||||
|
||||
sub render_ref {
|
||||
my ($in) = @_;
|
||||
|
||||
return 'undef' unless defined($in);
|
||||
|
||||
my $type = rtype($in);
|
||||
return "$in" unless $type;
|
||||
|
||||
# Look past overloading
|
||||
my $class = blessed($in) || '';
|
||||
|
||||
my $it = sprintf('0x%x', refaddr($in));
|
||||
my $ref = "$type($it)";
|
||||
|
||||
return $ref unless $class;
|
||||
|
||||
my $out = "$class=$ref";
|
||||
if ($class =~ m/bool/i) {
|
||||
my $bool = $in ? 'TRUE' : 'FALSE';
|
||||
return "<$bool: $out>";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Ref - Tools for inspecting or manipulating references.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These are used by L<Test2::Tools> to inspect, render, or manipulate references.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All exports are optional. You must specify subs to import.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $type = rtype($ref)
|
||||
|
||||
A normalization between C<Scalar::Util::reftype()> and C<ref()>.
|
||||
|
||||
Always returns a string.
|
||||
|
||||
Returns C<'REGEXP'> for regex types
|
||||
|
||||
Returns C<''> for non-refs
|
||||
|
||||
Otherwise returns what C<Scalar::Util::reftype()> returns.
|
||||
|
||||
=item $addr_str = render_ref($ref)
|
||||
|
||||
Always returns a string. For unblessed references this returns something like
|
||||
C<"SCALAR(0x...)">. For blessed references it returns
|
||||
C<"My::Thing=SCALAR(0x...)">. The only difference between this and C<$add_str =
|
||||
"$thing"> is that it ignores any overloading to ensure it is always the ref
|
||||
address.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
F<https://github.com/Test-More/Test2-Suite/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
See F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
247
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Stash.pm
Normal file
247
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Stash.pm
Normal file
|
|
@ -0,0 +1,247 @@
|
|||
package Test2::Util::Stash;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use Carp qw/croak/;
|
||||
use B;
|
||||
|
||||
our @EXPORT_OK = qw{
|
||||
get_stash
|
||||
get_glob
|
||||
get_symbol
|
||||
parse_symbol
|
||||
purge_symbol
|
||||
slot_to_sig sig_to_slot
|
||||
};
|
||||
use base 'Exporter';
|
||||
|
||||
my %SIGMAP = (
|
||||
'&' => 'CODE',
|
||||
'$' => 'SCALAR',
|
||||
'%' => 'HASH',
|
||||
'@' => 'ARRAY',
|
||||
);
|
||||
|
||||
my %SLOTMAP = reverse %SIGMAP;
|
||||
|
||||
sub slot_to_sig { $SLOTMAP{$_[0]} || croak "unsupported slot: '$_[0]'" }
|
||||
sub sig_to_slot { $SIGMAP{$_[0]} || croak "unsupported sigil: $_[0]" }
|
||||
|
||||
sub get_stash {
|
||||
my $package = shift || caller;
|
||||
no strict 'refs';
|
||||
return \%{"${package}\::"};
|
||||
}
|
||||
|
||||
sub get_glob {
|
||||
my $sym = _parse_symbol(scalar(caller), @_);
|
||||
no strict 'refs';
|
||||
no warnings 'once';
|
||||
return \*{"$sym->{package}\::$sym->{name}"};
|
||||
}
|
||||
|
||||
sub parse_symbol { _parse_symbol(scalar(caller), @_) }
|
||||
|
||||
sub _parse_symbol {
|
||||
my ($caller, $symbol, $package) = @_;
|
||||
|
||||
if (ref($symbol)) {
|
||||
my $pkg = $symbol->{package};
|
||||
|
||||
croak "Symbol package ($pkg) and package argument ($package) do not match"
|
||||
if $pkg && $package && $pkg ne $package;
|
||||
|
||||
$symbol->{package} ||= $caller;
|
||||
|
||||
return $symbol;
|
||||
}
|
||||
|
||||
utf8::downgrade($symbol) if $] == 5.010000; # prevent crash on 5.10.0
|
||||
my ($sig, $pkg, $name) = ($symbol =~ m/^(\W?)(.*::)?([^:]+)$/)
|
||||
or croak "Invalid symbol: '$symbol'";
|
||||
|
||||
# Normalize package, '::' becomes 'main', 'Foo::' becomes 'Foo'
|
||||
$pkg = $pkg
|
||||
? $pkg eq '::'
|
||||
? 'main'
|
||||
: substr($pkg, 0, -2)
|
||||
: undef;
|
||||
|
||||
croak "Symbol package ($pkg) and package argument ($package) do not match"
|
||||
if $pkg && $package && $pkg ne $package;
|
||||
|
||||
$sig ||= '&';
|
||||
my $type = $SIGMAP{$sig} || croak "unsupported sigil: '$sig'";
|
||||
|
||||
my $real_package = $package || $pkg || $caller;
|
||||
|
||||
return {
|
||||
name => $name,
|
||||
sigil => $sig,
|
||||
type => $type,
|
||||
symbol => "${sig}${real_package}::${name}",
|
||||
package => $real_package,
|
||||
};
|
||||
}
|
||||
|
||||
sub get_symbol {
|
||||
my $sym = _parse_symbol(scalar(caller), @_);
|
||||
|
||||
my $name = $sym->{name};
|
||||
my $type = $sym->{type};
|
||||
my $package = $sym->{package};
|
||||
my $symbol = $sym->{symbol};
|
||||
|
||||
my $stash = get_stash($package);
|
||||
return undef unless exists $stash->{$name};
|
||||
|
||||
my $glob = get_glob($sym);
|
||||
return *{$glob}{$type} if $type ne 'SCALAR' && defined(*{$glob}{$type});
|
||||
|
||||
if ($] < 5.010) {
|
||||
return undef unless defined(*{$glob}{$type});
|
||||
|
||||
{
|
||||
local ($@, $!);
|
||||
local $SIG{__WARN__} = sub { 1 };
|
||||
return *{$glob}{$type} if eval "package $package; my \$y = $symbol; 1";
|
||||
}
|
||||
|
||||
return undef unless defined *{$glob}{$type};
|
||||
return *{$glob}{$type} if defined ${*{$glob}{$type}};
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $sv = B::svref_2object($glob)->SV;
|
||||
return *{$glob}{$type} if $sv->isa('B::SV');
|
||||
return undef unless $sv->isa('B::SPECIAL');
|
||||
return *{$glob}{$type} if $B::specialsv_name[$$sv] ne 'Nullsv';
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub purge_symbol {
|
||||
my $sym = _parse_symbol(scalar(caller), @_);
|
||||
|
||||
local *GLOBCLONE = *{get_glob($sym)};
|
||||
delete get_stash($sym->{package})->{$sym->{name}};
|
||||
my $new_glob = get_glob($sym);
|
||||
|
||||
for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) {
|
||||
next if $type eq $sym->{type};
|
||||
my $ref = get_symbol({type => $type, name => 'GLOBCLONE', sigil => $SLOTMAP{$type}}, __PACKAGE__);
|
||||
next unless $ref;
|
||||
*$new_glob = $ref;
|
||||
}
|
||||
|
||||
return *GLOBCLONE{$sym->{type}};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Stash - Utilities for manipulating stashes and globs.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a collection of utilities for manipulating and inspecting package
|
||||
stashes and globs.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $stash = get_stash($package)
|
||||
|
||||
Gets the package stash. This is the same as C<$stash = \%Package::Name::>.
|
||||
|
||||
=item $sym_spec = parse_symbol($symbol)
|
||||
|
||||
=item $sym_spec = parse_symbol($symbol, $package)
|
||||
|
||||
Parse a symbol name, and return a hashref with info about the symbol.
|
||||
|
||||
C<$symbol> can be a simple name, or a fully qualified symbol name. The sigil is
|
||||
optional, and C<&> is assumed if none is provided. If C<$symbol> is fully qualified,
|
||||
and C<$package> is also provided, then the package of the symbol must match the
|
||||
C<$package>.
|
||||
|
||||
Returns a structure like this:
|
||||
|
||||
return {
|
||||
name => 'BAZ',
|
||||
sigil => '$',
|
||||
type => 'SCALAR',
|
||||
symbol => '&Foo::Bar::BAZ',
|
||||
package => 'Foo::Bar',
|
||||
};
|
||||
|
||||
=item $glob_ref = get_glob($symbol)
|
||||
|
||||
=item $glob_ref = get_glob($symbol, $package)
|
||||
|
||||
Get a glob ref. Arguments are the same as for C<parse_symbol>.
|
||||
|
||||
=item $ref = get_symbol($symbol)
|
||||
|
||||
=item $ref = get_symbol($symbol, $package)
|
||||
|
||||
Get a reference to the symbol. Arguments are the same as for C<parse_symbol>.
|
||||
|
||||
=item $ref = purge_symbol($symbol)
|
||||
|
||||
=item $ref = purge_symbol($symbol, $package)
|
||||
|
||||
Completely remove the symbol from the package symbol table. Arguments are the
|
||||
same as for C<parse_symbol>. A reference to the removed symbol is returned.
|
||||
|
||||
=item $sig = slot_to_sig($slot)
|
||||
|
||||
Convert a slot (like 'SCALAR') to a sigil (like '$').
|
||||
|
||||
=item $slot = sig_to_slot($sig)
|
||||
|
||||
Convert a sigil (like '$') to a slot (like 'SCALAR').
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
F<https://github.com/Test-More/Test2-Suite/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
See F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
220
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Sub.pm
Normal file
220
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Sub.pm
Normal file
|
|
@ -0,0 +1,220 @@
|
|||
package Test2::Util::Sub;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use Carp qw/croak carp/;
|
||||
use B();
|
||||
|
||||
our @EXPORT_OK = qw{
|
||||
sub_info
|
||||
sub_name
|
||||
|
||||
gen_reader gen_writer gen_accessor
|
||||
};
|
||||
use base 'Exporter';
|
||||
|
||||
sub gen_reader {
|
||||
my $field = shift;
|
||||
return sub { $_[0]->{$field} };
|
||||
}
|
||||
|
||||
sub gen_writer {
|
||||
my $field = shift;
|
||||
return sub { $_[0]->{$field} = $_[1] };
|
||||
}
|
||||
|
||||
sub gen_accessor {
|
||||
my $field = shift;
|
||||
return sub {
|
||||
my $self = shift;
|
||||
($self->{$field}) = @_ if @_;
|
||||
return $self->{$field};
|
||||
};
|
||||
}
|
||||
|
||||
sub sub_name {
|
||||
my ($sub) = @_;
|
||||
|
||||
croak "sub_name requires a coderef as its only argument"
|
||||
unless ref($sub) eq 'CODE';
|
||||
|
||||
my $cobj = B::svref_2object($sub);
|
||||
my $name = $cobj->GV->NAME;
|
||||
return $name;
|
||||
}
|
||||
|
||||
sub sub_info {
|
||||
my ($sub, @all_lines) = @_;
|
||||
my %in = map {$_ => 1} @all_lines;
|
||||
|
||||
croak "sub_info requires a coderef as its first argument"
|
||||
unless ref($sub) eq 'CODE';
|
||||
|
||||
my $cobj = B::svref_2object($sub);
|
||||
my $name = $cobj->GV->NAME;
|
||||
my $file = $cobj->FILE;
|
||||
my $package = $cobj->GV->STASH->NAME;
|
||||
|
||||
my $op = $cobj->START;
|
||||
while ($op) {
|
||||
push @all_lines => $op->line if $op->can('line');
|
||||
last unless $op->can('next');
|
||||
$op = $op->next;
|
||||
}
|
||||
|
||||
my ($start, $end, @lines);
|
||||
if (@all_lines) {
|
||||
@all_lines = sort { $a <=> $b } @all_lines;
|
||||
($start, $end) = ($all_lines[0], $all_lines[-1]);
|
||||
|
||||
# Adjust start and end for the most common case of a multi-line block with
|
||||
# parens on the lines before and after.
|
||||
if ($start < $end) {
|
||||
$start-- unless $start <= 1 || $in{$start};
|
||||
$end++ unless $in{$end};
|
||||
}
|
||||
@lines = ($start, $end);
|
||||
}
|
||||
|
||||
return {
|
||||
ref => $sub,
|
||||
cobj => $cobj,
|
||||
name => $name,
|
||||
file => $file,
|
||||
package => $package,
|
||||
start_line => $start,
|
||||
end_line => $end,
|
||||
all_lines => \@all_lines,
|
||||
lines => \@lines,
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Sub - Tools for inspecting and manipulating subs.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Utilities used by Test2::Tools to inspect and manipulate subroutines.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All exports are optional, you must specify subs to import.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $name = sub_name(\&sub)
|
||||
|
||||
Get the name of the sub.
|
||||
|
||||
=item my $hr = sub_info(\&code)
|
||||
|
||||
This returns a hashref with information about the sub:
|
||||
|
||||
{
|
||||
ref => \&code,
|
||||
cobj => $cobj,
|
||||
name => "Some::Mod::code",
|
||||
file => "Some/Mod.pm",
|
||||
package => "Some::Mod",
|
||||
|
||||
# Note: These have been adjusted based on guesswork.
|
||||
start_line => 22,
|
||||
end_line => 42,
|
||||
lines => [22, 42],
|
||||
|
||||
# Not a bug, these lines are different!
|
||||
all_lines => [23, 25, ..., 39, 41],
|
||||
};
|
||||
|
||||
=over 4
|
||||
|
||||
=item $info->{ref} => \&code
|
||||
|
||||
This is the original sub passed to C<sub_info()>.
|
||||
|
||||
=item $info->{cobj} => $cobj
|
||||
|
||||
This is the c-object representation of the coderef.
|
||||
|
||||
=item $info->{name} => "Some::Mod::code"
|
||||
|
||||
This is the name of the coderef. For anonymous coderefs this may end with
|
||||
C<'__ANON__'>. Also note that the package 'main' is special, and 'main::' may
|
||||
be omitted.
|
||||
|
||||
=item $info->{file} => "Some/Mod.pm"
|
||||
|
||||
The file in which the sub was defined.
|
||||
|
||||
=item $info->{package} => "Some::Mod"
|
||||
|
||||
The package in which the sub was defined.
|
||||
|
||||
=item $info->{start_line} => 22
|
||||
|
||||
=item $info->{end_line} => 42
|
||||
|
||||
=item $info->{lines} => [22, 42]
|
||||
|
||||
These three fields are the I<adjusted> start line, end line, and array with both.
|
||||
It is important to note that these lines have been adjusted and may not be
|
||||
accurate.
|
||||
|
||||
The lines are obtained by walking the ops. As such, the first line is the line
|
||||
of the first statement, and the last line is the line of the last statement.
|
||||
This means that in multi-line subs the lines are usually off by 1. The lines
|
||||
in these keys will be adjusted for you if it detects a multi-line sub.
|
||||
|
||||
=item $info->{all_lines} => [23, 25, ..., 39, 41]
|
||||
|
||||
This is an array with the lines of every statement in the sub. Unlike the other
|
||||
line fields, these have not been adjusted for you.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
F<https://github.com/Test-More/Test2-Suite/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
See F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
199
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Table.pm
Normal file
199
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Table.pm
Normal file
|
|
@ -0,0 +1,199 @@
|
|||
package Test2::Util::Table;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use base 'Term::Table';
|
||||
|
||||
use Test2::Util::Importer 'Test2::Util::Importer' => 'import';
|
||||
our @EXPORT_OK = qw/table/;
|
||||
our %EXPORT_GEN = (
|
||||
'&term_size' => sub {
|
||||
require Carp;
|
||||
Carp::cluck "term_size should be imported from Test2::Util::Term, not " . __PACKAGE__;
|
||||
Test2::Util::Term->can('term_size');
|
||||
},
|
||||
);
|
||||
|
||||
sub table {
|
||||
my %params = @_;
|
||||
|
||||
$params{collapse} ||= 0;
|
||||
$params{sanitize} ||= 0;
|
||||
$params{mark_tail} ||= 0;
|
||||
$params{show_header} ||= 0 unless $params{header} && @{$params{header}};
|
||||
|
||||
__PACKAGE__->new(%params)->render;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Table - Format a header and rows into a table
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is used by some failing tests to provide diagnostics about what has gone
|
||||
wrong. This module is able to generic format rows of data into tables.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Util::Table qw/table/;
|
||||
|
||||
my @table = table(
|
||||
max_width => 80,
|
||||
collapse => 1, # Do not show empty columns
|
||||
header => [ 'name', 'age', 'hair color' ],
|
||||
rows => [
|
||||
[ 'Fred Flinstone', 2000000, 'black' ],
|
||||
[ 'Wilma Flinstone', 1999995, 'red' ],
|
||||
...,
|
||||
],
|
||||
);
|
||||
|
||||
# The @table array contains each line of the table, no newlines added.
|
||||
say $_ for @table;
|
||||
|
||||
This prints a table like this:
|
||||
|
||||
+-----------------+---------+------------+
|
||||
| name | age | hair color |
|
||||
+-----------------+---------+------------+
|
||||
| Fred Flinstone | 2000000 | black |
|
||||
| Wilma Flinstone | 1999995 | red |
|
||||
| ... | ... | ... |
|
||||
+-----------------+---------+------------+
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=head2 @rows = table(...)
|
||||
|
||||
The function returns a list of lines, lines do not have the newline C<\n>
|
||||
character appended.
|
||||
|
||||
Options:
|
||||
|
||||
=over 4
|
||||
|
||||
=item header => [ ... ]
|
||||
|
||||
If you want a header specify it here. This takes an arrayref with each columns
|
||||
heading.
|
||||
|
||||
=item rows => [ [...], [...], ... ]
|
||||
|
||||
This should be an arrayref containing an arrayref per row.
|
||||
|
||||
=item collapse => $bool
|
||||
|
||||
Use this if you want to hide empty columns, that is any column that has no data
|
||||
in any row. Having a header for the column will not effect collapse.
|
||||
|
||||
=item max_width => $num
|
||||
|
||||
Set the maximum width of the table, the table may not be this big, but it will
|
||||
be no bigger. If none is specified it will attempt to find the width of your
|
||||
terminal and use that, otherwise it falls back to C<80>.
|
||||
|
||||
=item sanitize => $bool
|
||||
|
||||
This will sanitize all the data in the table such that newlines, control
|
||||
characters, and all whitespace except for ASCII 20 C<' '> are replaced with
|
||||
escape sequences. This prevents newlines, tabs, and similar whitespace from
|
||||
disrupting the table.
|
||||
|
||||
B<Note:> newlines are marked as '\n', but a newline is also inserted into the
|
||||
data so that it typically displays in a way that is useful to humans.
|
||||
|
||||
Example:
|
||||
|
||||
my $field = "foo\nbar\nbaz\n";
|
||||
|
||||
print join "\n" => table(
|
||||
sanitize => 1,
|
||||
rows => [
|
||||
[$field, 'col2' ],
|
||||
['row2 col1', 'row2 col2']
|
||||
]
|
||||
);
|
||||
|
||||
Prints:
|
||||
|
||||
+-----------------+-----------+
|
||||
| foo\n | col2 |
|
||||
| bar\n | |
|
||||
| baz\n | |
|
||||
| | |
|
||||
| row2 col1 | row2 col2 |
|
||||
+-----------------+-----------+
|
||||
|
||||
So it marks the newlines by inserting the escape sequence, but it also shows
|
||||
the data across as many lines as it would normally display.
|
||||
|
||||
=item mark_tail => $bool
|
||||
|
||||
This will replace the last whitespace character of any trailing whitespace with
|
||||
its escape sequence. This makes it easier to notice trailing whitespace when
|
||||
comparing values.
|
||||
|
||||
=back
|
||||
|
||||
=head2 my $cols = term_size()
|
||||
|
||||
Attempts to find the width in columns (characters) of the current terminal.
|
||||
Returns 80 as a safe bet if it cannot find it another way.
|
||||
|
||||
=head1 NOTE ON UNICODE/WIDE CHARACTERS
|
||||
|
||||
Some unicode characters, such as C<婧> (C<U+5A67>) are wider than others. These
|
||||
will render just fine if you C<use utf8;> as necessary, and
|
||||
L<Unicode::GCString> is installed, however if the module is not installed there
|
||||
will be anomalies in the table:
|
||||
|
||||
+-----+-----+---+
|
||||
| a | b | c |
|
||||
+-----+-----+---+
|
||||
| 婧 | x | y |
|
||||
| x | y | z |
|
||||
| x | 婧 | z |
|
||||
+-----+-----+---+
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
F<https://github.com/Test-More/Test2-Suite/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
See F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,9 @@
|
|||
package Test2::Util::Table::Cell;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use base 'Term::Table::Cell';
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
package Test2::Util::Table::LineBreak;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use base 'Term::Table::LineBreak';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Table::LineBreak - Break up lines for use in tables.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is meant for internal use. This package takes long lines of text and
|
||||
splits them so that they fit in table rows.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Util::Table::LineBreak;
|
||||
|
||||
my $lb = Test2::Util::Table::LineBreak->new(string => $STRING);
|
||||
|
||||
$lb->break($SIZE);
|
||||
while (my $part = $lb->next) {
|
||||
...
|
||||
}
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
F<https://github.com/Test-More/Test2-Suite/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
See F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
12
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Term.pm
Normal file
12
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Term.pm
Normal file
|
|
@ -0,0 +1,12 @@
|
|||
package Test2::Util::Term;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Term::Table::Util qw/term_size USE_GCS USE_TERM_READKEY uni_length/;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
use Test2::Util::Importer 'Test2::Util::Importer' => 'import';
|
||||
our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY uni_length/;
|
||||
|
||||
1;
|
||||
138
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Times.pm
Normal file
138
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Times.pm
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
package Test2::Util::Times;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use List::Util qw/sum/;
|
||||
|
||||
our $VERSION = '0.000162';
|
||||
|
||||
our @EXPORT_OK = qw/render_bench render_duration/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub render_duration {
|
||||
my $time;
|
||||
if (@_ == 1) {
|
||||
($time) = @_;
|
||||
}
|
||||
else {
|
||||
my ($start, $end) = @_;
|
||||
$time = $end - $start;
|
||||
}
|
||||
|
||||
return sprintf('%1.5fs', $time) if $time < 10;
|
||||
return sprintf('%2.4fs', $time) if $time < 60;
|
||||
|
||||
my $msec = substr(sprintf('%0.2f', $time - int($time)), -2, 2);
|
||||
my $secs = $time % 60;
|
||||
my $mins = int($time / 60) % 60;
|
||||
my $hours = int($time / 60 / 60) % 24;
|
||||
my $days = int($time / 60 / 60 / 24);
|
||||
|
||||
my @units = (qw/d h m/, '');
|
||||
|
||||
my $duration = '';
|
||||
for my $t ($days, $hours, $mins, $secs) {
|
||||
my $u = shift @units;
|
||||
next unless $t || $duration;
|
||||
$duration = join ':' => grep { length($_) } $duration, sprintf('%02u%s', $t, $u);
|
||||
}
|
||||
|
||||
$duration ||= '0';
|
||||
$duration .= ".$msec" if int($msec);
|
||||
$duration .= 's';
|
||||
|
||||
return $duration;
|
||||
}
|
||||
|
||||
sub render_bench {
|
||||
my ($start, $end, $user, $system, $cuser, $csystem) = @_;
|
||||
|
||||
my $duration = render_duration($start, $end);
|
||||
|
||||
my $bench = sprintf(
|
||||
"%s on wallclock (%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)",
|
||||
$duration, $user, $system, $cuser, $csystem, sum($user, $system, $cuser, $csystem),
|
||||
);
|
||||
$bench =~ s/\s+/ /g;
|
||||
$bench =~ s/(\(|\))\s+/$1/g;
|
||||
|
||||
return $bench;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Times - Format timing/benchmark information.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This modules exports tools for rendering timing data at the end of tests.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All exports are optional. You must specify subs to import.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $str = render_bench($start, $end, $user, $system, $cuser, $csystem)
|
||||
|
||||
=item $str = render_bench($start, time(), times())
|
||||
|
||||
This will produce a string like one of these (Note these numbers are completely
|
||||
made up). I<Which string is used depends on the time elapsed.>
|
||||
|
||||
0.12345s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
11.1234s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
01m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
04d:18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
The first 2 arguments are the C<$start> and C<$end> times in seconds (as
|
||||
returned by C<time()> or C<Time::HiRes::time()>).
|
||||
|
||||
The last 4 arguments are timing information as returned by the C<times()>
|
||||
function.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
F<https://github.com/Test-More/Test2-Suite/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
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.
|
||||
|
||||
See F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
58
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Trace.pm
Normal file
58
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Util/Trace.pm
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
package Test2::Util::Trace;
|
||||
require Test2::EventFacet::Trace;
|
||||
|
||||
use warnings;
|
||||
use strict;
|
||||
|
||||
our @ISA = ('Test2::EventFacet::Trace');
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Trace - Legacy wrapper fro L<Test2::EventFacet::Trace>.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
All the functionality for this class has been moved to
|
||||
L<Test2::EventFacet::Trace>.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
L<https://github.com/Test-More/test-more/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2020 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.
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
Loading…
Add table
Add a link
Reference in a new issue