package Tak::STDIONode;
our $DATA = do { local $/; <DATA> };
1;
__DATA__
# This chunk of stuff was generated by App::FatPacker. To find the original
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
BEGIN {
my %fatpacked;
$fatpacked{"Algorithm/C3.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALGORITHM_C3';
package Algorithm::C3;
use strict;
use warnings;
use Carp 'confess';
our $VERSION = '0.08';
sub merge {
my ($root, $parent_fetcher, $cache) = @_;
$cache ||= {};
my @STACK; # stack for simulating recursion
my $pfetcher_is_coderef = ref($parent_fetcher) eq 'CODE';
unless ($pfetcher_is_coderef or $root->can($parent_fetcher)) {
confess "Could not find method $parent_fetcher in $root";
}
my $current_root = $root;
my $current_parents = [ $root->$parent_fetcher ];
my $recurse_mergeout = [];
my $i = 0;
my %seen = ( $root => 1 );
my ($new_root, $mergeout, %tails);
while(1) {
if($i < @$current_parents) {
$new_root = $current_parents->[$i++];
if($seen{$new_root}) {
my @isastack;
my $reached;
for(my $i = 0; $i < $#STACK; $i += 4) {
if($reached || ($reached = ($STACK[$i] eq $new_root))) {
push(@isastack, $STACK[$i]);
}
}
my $isastack = join(q{ -> }, @isastack, $current_root, $new_root);
die "Infinite loop detected in parents of '$root': $isastack";
}
$seen{$new_root} = 1;
unless ($pfetcher_is_coderef or $new_root->can($parent_fetcher)) {
confess "Could not find method $parent_fetcher in $new_root";
}
push(@STACK, $current_root, $current_parents, $recurse_mergeout, $i);
$current_root = $new_root;
$current_parents = $cache->{pfetch}->{$current_root} ||= [ $current_root->$parent_fetcher ];
$recurse_mergeout = [];
$i = 0;
next;
}
$seen{$current_root} = 0;
$mergeout = $cache->{merge}->{$current_root} ||= do {
# This do-block is the code formerly known as the function
# that was a perl-port of the python code at
# http://www.python.org/2.3/mro.html :)
# Initial set (make sure everything is copied - it will be modded)
my @seqs = map { [@$_] } @$recurse_mergeout;
push(@seqs, [@$current_parents]) if @$current_parents;
# Construct the tail-checking hash (actually, it's cheaper and still
# correct to re-use it throughout this function)
foreach my $seq (@seqs) {
$tails{$seq->[$_]}++ for (1..$#$seq);
}
my @res = ( $current_root );
while (1) {
my $cand;
my $winner;
foreach (@seqs) {
next if !@$_;
if(!$winner) { # looking for a winner
$cand = $_->[0]; # seq head is candidate
next if $tails{$cand}; # he loses if in %tails
# Handy warn to give a output like the ones on
# http://www.python.org/download/releases/2.3/mro/
#warn " = " . join(' + ', @res) . " + merge([" . join('] [', map { join(', ', @$_) } grep { @$_ } @seqs) . "])\n";
push @res => $winner = $cand;
shift @$_; # strip off our winner
$tails{$_->[0]}-- if @$_; # keep %tails sane
}
elsif($_->[0] eq $winner) {
shift @$_; # strip off our winner
$tails{$_->[0]}-- if @$_; # keep %tails sane
}
}
# Handy warn to give a output like the ones on
# http://www.python.org/download/releases/2.3/mro/
#warn " = " . join(' + ', @res) . "\n" if !$cand;
last if !$cand;
die q{Inconsistent hierarchy found while merging '}
. $current_root . qq{':\n\t}
. qq{current merge results [\n\t\t}
. (join ",\n\t\t" => @res)
. qq{\n\t]\n\t} . qq{merging failed on '$cand'\n}
if !$winner;
}
\@res;
};
return @$mergeout if !@STACK;
$i = pop(@STACK);
$recurse_mergeout = pop(@STACK);
$current_parents = pop(@STACK);
$current_root = pop(@STACK);
push(@$recurse_mergeout, $mergeout);
}
}
1;
__END__
=pod
=head1 NAME
Algorithm::C3 - A module for merging hierarchies using the C3 algorithm
=head1 SYNOPSIS
use Algorithm::C3;
# merging a classic diamond
# inheritance graph like this:
#
# <A>
# / \
# <B> <C>
# \ /
# <D>
my @merged = Algorithm::C3::merge(
'D',
sub {
# extract the ISA array
# from the package
no strict 'refs';
@{$_[0] . '::ISA'};
}
);
print join ", " => @merged; # prints D, B, C, A
=head1 DESCRIPTION
This module implements the C3 algorithm. I have broken this out
into it's own module because I found myself copying and pasting
it way too often for various needs. Most of the uses I have for
C3 revolve around class building and metamodels, but it could
also be used for things like dependency resolution as well since
it tends to do such a nice job of preserving local precedence
orderings.
Below is a brief explanation of C3 taken from the L<Class::C3>
module. For more detailed information, see the L<SEE ALSO> section
and the links there.
=head2 What is C3?
C3 is the name of an algorithm which aims to provide a sane method
resolution order under multiple inheritance. It was first introduced
in the language Dylan (see links in the L<SEE ALSO> section), and
then later adopted as the preferred MRO (Method Resolution Order)
for the new-style classes in Python 2.3. Most recently it has been
adopted as the 'canonical' MRO for Perl 6 classes, and the default
MRO for Parrot objects as well.
=head2 How does C3 work.
C3 works by always preserving local precedence ordering. This
essentially means that no class will appear before any of it's
subclasses. Take the classic diamond inheritance pattern for
instance:
<A>
/ \
<B> <C>
\ /
<D>
The standard Perl 5 MRO would be (D, B, A, C). The result being that
B<A> appears before B<C>, even though B<C> is the subclass of B<A>.
The C3 MRO algorithm however, produces the following MRO (D, B, C, A),
which does not have this same issue.
This example is fairly trivial, for more complex examples and a deeper
explanation, see the links in the L<SEE ALSO> section.
=head1 FUNCTION
=over 4
=item B<merge ($root, $func_to_fetch_parent, $cache)>
This takes a C<$root> node, which can be anything really it
is up to you. Then it takes a C<$func_to_fetch_parent> which
can be either a CODE reference (see L<SYNOPSIS> above for an
example), or a string containing a method name to be called
on all the items being linearized. An example of how this
might look is below:
{
package A;
sub supers {
no strict 'refs';
@{$_[0] . '::ISA'};
}
package C;
our @ISA = ('A');
package B;
our @ISA = ('A');
package D;
our @ISA = ('B', 'C');
}
print join ", " => Algorithm::C3::merge('D', 'supers');
The purpose of C<$func_to_fetch_parent> is to provide a way
for C<merge> to extract the parents of C<$root>. This is
needed for C3 to be able to do it's work.
The C<$cache> parameter is an entirely optional performance
measure, and should not change behavior.
If supplied, it should be a hashref that merge can use as a
private cache between runs to speed things up. Generally
speaking, if you will be calling merge many times on related
things, and the parent fetching function will return constant
results given the same arguments during all of these calls,
you can and should reuse the same shared cache hash for all
of the calls. Example:
sub do_some_merging {
my %merge_cache;
my @foo_mro = Algorithm::C3::Merge('Foo', \&get_supers, \%merge_cache);
my @bar_mro = Algorithm::C3::Merge('Bar', \&get_supers, \%merge_cache);
my @baz_mro = Algorithm::C3::Merge('Baz', \&get_supers, \%merge_cache);
my @quux_mro = Algorithm::C3::Merge('Quux', \&get_supers, \%merge_cache);
# ...
}
=back
=head1 CODE COVERAGE
I use B<Devel::Cover> to test the code coverage of my tests, below
is the B<Devel::Cover> report on this module's test suite.
------------------------ ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
------------------------ ------ ------ ------ ------ ------ ------ ------
Algorithm/C3.pm 100.0 100.0 100.0 100.0 100.0 100.0 100.0
------------------------ ------ ------ ------ ------ ------ ------ ------
Total 100.0 100.0 100.0 100.0 100.0 100.0 100.0
------------------------ ------ ------ ------ ------ ------ ------ ------
=head1 SEE ALSO
=head2 The original Dylan paper
=over 4
=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
=back
=head2 The prototype Perl 6 Object Model uses C3
=over 4
=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
=back
=head2 Parrot now uses C3
=over 4
=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
=item L<http://use.perl.org/~autrijus/journal/25768>
=back
=head2 Python 2.3 MRO related links
=over 4
=item L<http://www.python.org/2.3/mro.html>
=item L<http://www.python.org/2.2.2/descrintro.html#mro>
=back
=head2 C3 for TinyCLOS
=over 4
=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
=back
=head1 AUTHORS
Stevan Little, E<lt>stevan@iinteractive.comE<gt>
Brandon L. Black, E<lt>blblack@gmail.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2006 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
ALGORITHM_C3
$fatpacked{"App/Tak.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_TAK';
package App::Tak;
use Moo;
has env => (is => 'ro', required => 1);
sub new_from_environment {
my $class = shift;
my %env = (
env => { %ENV }, argv => [ @ARGV ],
stdin => \*STDIN, stdout => \*STDOUT, stderr => \*STDERR
);
$class->new(env => \%env);
}
sub run {
my ($self) = @_;
my @argv = @{$self->env->{argv}};
require Tak::MyScript;
my $opt = Tak::MyScript->_parse_options(
'config|c=s;host|h=s@;local|l!;verbose|v+;quiet|q+', \@argv
);
Tak::MyScript->new(
options => $opt,
env => { %{$self->env}, argv => \@argv }
)->run;
}
1;
APP_TAK
$fatpacked{"Capture/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CAPTURE_TINY';
use 5.006;
use strict;
use warnings;
package Capture::Tiny;
# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
our $VERSION = '0.27';
use Carp ();
use Exporter ();
use IO::Handle ();
use File::Spec ();
use File::Temp qw/tempfile tmpnam/;
use Scalar::Util qw/reftype blessed/;
# Get PerlIO or fake it
BEGIN {
local $@;
eval { require PerlIO; PerlIO->can('get_layers') }
or *PerlIO::get_layers = sub { return () };
}
#--------------------------------------------------------------------------#
# create API subroutines and export them
# [do STDOUT flag, do STDERR flag, do merge flag, do tee flag]
#--------------------------------------------------------------------------#
my %api = (
capture => [1,1,0,0],
capture_stdout => [1,0,0,0],
capture_stderr => [0,1,0,0],
capture_merged => [1,1,1,0],
tee => [1,1,0,1],
tee_stdout => [1,0,0,1],
tee_stderr => [0,1,0,1],
tee_merged => [1,1,1,1],
);
for my $sub ( keys %api ) {
my $args = join q{, }, @{$api{$sub}};
eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
}
our @ISA = qw/Exporter/;
our @EXPORT_OK = keys %api;
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
#--------------------------------------------------------------------------#
# constants and fixtures
#--------------------------------------------------------------------------#
my $IS_WIN32 = $^O eq 'MSWin32';
##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
##
##my $DEBUGFH;
##open $DEBUGFH, "> DEBUG" if $DEBUG;
##
##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0};
our $TIMEOUT = 30;
#--------------------------------------------------------------------------#
# command to tee output -- the argument is a filename that must
# be opened to signal that the process is ready to receive input.
# This is annoying, but seems to be the best that can be done
# as a simple, portable IPC technique
#--------------------------------------------------------------------------#
my @cmd = ($^X, '-C0', '-e', <<'HERE');
use Fcntl;
$SIG{HUP}=sub{exit};
if ( my $fn=shift ) {
sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
print {$fh} $$;
close $fh;
}
my $buf; while (sysread(STDIN, $buf, 2048)) {
syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
}
HERE
#--------------------------------------------------------------------------#
# filehandle manipulation
#--------------------------------------------------------------------------#
sub _relayer {
my ($fh, $layers) = @_;
# _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
my %seen = ( unix => 1, perlio => 1 ); # filter these out
my @unique = grep { !$seen{$_}++ } @$layers;
# _debug("# applying unique layers (@unique) to @{[fileno $fh]}\n");
binmode($fh, join(":", ":raw", @unique));
}
sub _name {
my $glob = shift;
no strict 'refs'; ## no critic
return *{$glob}{NAME};
}
sub _open {
open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!";
# _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" );
}
sub _close {
# _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" );
close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
}
my %dup; # cache this so STDIN stays fd0
my %proxy_count;
sub _proxy_std {
my %proxies;
if ( ! defined fileno STDIN ) {
$proxy_count{stdin}++;
if (defined $dup{stdin}) {
_open \*STDIN, "<&=" . fileno($dup{stdin});
# _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
}
else {
_open \*STDIN, "<" . File::Spec->devnull;
# _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
_open $dup{stdin} = IO::Handle->new, "<&=STDIN";
}
$proxies{stdin} = \*STDIN;
binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic
}
if ( ! defined fileno STDOUT ) {
$proxy_count{stdout}++;
if (defined $dup{stdout}) {
_open \*STDOUT, ">&=" . fileno($dup{stdout});
# _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
}
else {
_open \*STDOUT, ">" . File::Spec->devnull;
# _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
_open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
}
$proxies{stdout} = \*STDOUT;
binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic
}
if ( ! defined fileno STDERR ) {
$proxy_count{stderr}++;
if (defined $dup{stderr}) {
_open \*STDERR, ">&=" . fileno($dup{stderr});
# _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
}
else {
_open \*STDERR, ">" . File::Spec->devnull;
# _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
_open $dup{stderr} = IO::Handle->new, ">&=STDERR";
}
$proxies{stderr} = \*STDERR;
binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic
}
return %proxies;
}
sub _unproxy {
my (%proxies) = @_;
# _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" );
for my $p ( keys %proxies ) {
$proxy_count{$p}--;
# _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
if ( ! $proxy_count{$p} ) {
_close $proxies{$p};
_close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
delete $dup{$p};
}
}
}
sub _copy_std {
my %handles;
for my $h ( qw/stdout stderr stdin/ ) {
next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
my $redir = $h eq 'stdin' ? "<&" : ">&";
_open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
}
return \%handles;
}
# In some cases we open all (prior to forking) and in others we only open
# the output handles (setting up redirection)
sub _open_std {
my ($handles) = @_;
_open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
_open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
_open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
}
#--------------------------------------------------------------------------#
# private subs
#--------------------------------------------------------------------------#
sub _start_tee {
my ($which, $stash) = @_; # $which is "stdout" or "stderr"
# setup pipes
$stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
pipe $stash->{reader}{$which}, $stash->{tee}{$which};
# _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" );
select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
# setup desired redirection for parent and child
$stash->{new}{$which} = $stash->{tee}{$which};
$stash->{child}{$which} = {
stdin => $stash->{reader}{$which},
stdout => $stash->{old}{$which},
stderr => $stash->{capture}{$which},
};
# flag file is used to signal the child is ready
$stash->{flag_files}{$which} = scalar tmpnam();
# execute @cmd as a separate process
if ( $IS_WIN32 ) {
local $@;
eval "use Win32API::File qw/CloseHandle GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
# _debug( "# Win32API::File loaded\n") unless $@;
my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} );
# _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE();
my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0);
# _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n"));
_open_std( $stash->{child}{$which} );
$stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
# not restoring std here as it all gets redirected again shortly anyway
}
else { # use fork
_fork_exec( $which, $stash );
}
}
sub _fork_exec {
my ($which, $stash) = @_; # $which is "stdout" or "stderr"
my $pid = fork;
if ( not defined $pid ) {
Carp::confess "Couldn't fork(): $!";
}
elsif ($pid == 0) { # child
# _debug( "# in child process ...\n" );
untie *STDIN; untie *STDOUT; untie *STDERR;
_close $stash->{tee}{$which};
# _debug( "# redirecting handles in child ...\n" );
_open_std( $stash->{child}{$which} );
# _debug( "# calling exec on command ...\n" );
exec @cmd, $stash->{flag_files}{$which};
}
$stash->{pid}{$which} = $pid
}
my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
sub _files_exist {
return 1 if @_ == grep { -f } @_;
Time::HiRes::usleep(1000) if $have_usleep;
return 0;
}
sub _wait_for_tees {
my ($stash) = @_;
my $start = time;
my @files = values %{$stash->{flag_files}};
my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
unlink $_ for @files;
}
sub _kill_tees {
my ($stash) = @_;
if ( $IS_WIN32 ) {
# _debug( "# closing handles with CloseHandle\n");
CloseHandle( GetOsFHandle($_) ) for values %{ $stash->{tee} };
# _debug( "# waiting for subprocesses to finish\n");
my $start = time;
1 until wait == -1 || (time - $start > 30);
}
else {
_close $_ for values %{ $stash->{tee} };
waitpid $_, 0 for values %{ $stash->{pid} };
}
}
sub _slurp {
my ($name, $stash) = @_;
my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/;
# _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n");
seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
my $text = do { local $/; scalar readline $fh };
return defined($text) ? $text : "";
}
#--------------------------------------------------------------------------#
# _capture_tee() -- generic main sub for capturing or teeing
#--------------------------------------------------------------------------#
sub _capture_tee {
# _debug( "# starting _capture_tee with (@_)...\n" );
my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ());
Carp::confess("Custom capture options must be given as key/value pairs\n")
unless @opts % 2 == 0;
my $stash = { capture => { @opts } };
for ( keys %{$stash->{capture}} ) {
my $fh = $stash->{capture}{$_};
Carp::confess "Custom handle for $_ must be seekable\n"
unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable"));
}
# save existing filehandles and setup captures
local *CT_ORIG_STDIN = *STDIN ;
local *CT_ORIG_STDOUT = *STDOUT;
local *CT_ORIG_STDERR = *STDERR;
# find initial layers
my %layers = (
stdin => [PerlIO::get_layers(\*STDIN) ],
stdout => [PerlIO::get_layers(\*STDOUT, output => 1)],
stderr => [PerlIO::get_layers(\*STDERR, output => 1)],
);
# _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# get layers from underlying glob of tied filehandles if we can
# (this only works for things that work like Tie::StdHandle)
$layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
$layers{stderr} = [PerlIO::get_layers(tied *STDERR)]
if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB');
# _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# bypass scalar filehandles and tied handles
# localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN
my %localize;
$localize{stdin}++, local(*STDIN)
if grep { $_ eq 'scalar' } @{$layers{stdin}};
$localize{stdout}++, local(*STDOUT)
if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
$localize{stderr}++, local(*STDERR)
if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
$localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
if tied *STDIN && $] >= 5.008;
$localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
if $do_stdout && tied *STDOUT && $] >= 5.008;
$localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2")
if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008;
# _debug( "# localized $_\n" ) for keys %localize;
# proxy any closed/localized handles so we don't use fds 0, 1 or 2
my %proxy_std = _proxy_std();
# _debug( "# proxy std: @{ [%proxy_std] }\n" );
# update layers after any proxying
$layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
$layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr};
# _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# store old handles and setup handles for capture
$stash->{old} = _copy_std();
$stash->{new} = { %{$stash->{old}} }; # default to originals
for ( keys %do ) {
$stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
$stash->{pos}{$_} = tell $stash->{capture}{$_};
# _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
_start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
}
_wait_for_tees( $stash ) if $do_tee;
# finalize redirection
$stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
# _debug( "# redirecting in parent ...\n" );
_open_std( $stash->{new} );
# execute user provided code
my ($exit_code, $inner_error, $outer_error, @result);
{
local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
# _debug( "# finalizing layers ...\n" );
_relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
_relayer(\*STDERR, $layers{stderr}) if $do_stderr;
# _debug( "# running code $code ...\n" );
local $@;
eval { @result = $code->(); $inner_error = $@ };
$exit_code = $?; # save this for later
$outer_error = $@; # save this for later
}
# restore prior filehandles and shut down tees
# _debug( "# restoring filehandles ...\n" );
_open_std( $stash->{old} );
_close( $_ ) for values %{$stash->{old}}; # don't leak fds
# shouldn't need relayering originals, but see rt.perl.org #114404
_relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
_relayer(\*STDERR, $layers{stderr}) if $do_stderr;
_unproxy( %proxy_std );
# _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
_kill_tees( $stash ) if $do_tee;
# return captured output, but shortcut in void context
# unless we have to echo output to tied/scalar handles;
my %got;
if ( defined wantarray or ($do_tee && keys %localize) ) {
for ( keys %do ) {
_relayer($stash->{capture}{$_}, $layers{$_});
$got{$_} = _slurp($_, $stash);
# _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
}
print CT_ORIG_STDOUT $got{stdout}
if $do_stdout && $do_tee && $localize{stdout};
print CT_ORIG_STDERR $got{stderr}
if $do_stderr && $do_tee && $localize{stderr};
}
$? = $exit_code;
$@ = $inner_error if $inner_error;
die $outer_error if $outer_error;
# _debug( "# ending _capture_tee with (@_)...\n" );
return unless defined wantarray;
my @return;
push @return, $got{stdout} if $do_stdout;
push @return, $got{stderr} if $do_stderr && ! $do_merge;
push @return, @result;
return wantarray ? @return : $return[0];
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
=head1 VERSION
version 0.27
=head1 SYNOPSIS
use Capture::Tiny ':all';
# capture from external command
($stdout, $stderr, $exit) = capture {
system( $cmd, @args );
};
# capture from arbitrary code (Perl or external)
($stdout, $stderr, @result) = capture {
# your code here
};
# capture partial or merged output
$stdout = capture_stdout { ... };
$stderr = capture_stderr { ... };
$merged = capture_merged { ... };
# tee output
($stdout, $stderr) = tee {
# your code here
};
$stdout = tee_stdout { ... };
$stderr = tee_stderr { ... };
$merged = tee_merged { ... };
=head1 DESCRIPTION
Capture::Tiny provides a simple, portable way to capture almost anything sent
to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or
from an external program. Optionally, output can be teed so that it is
captured while being passed through to the original filehandles. Yes, it even
works on Windows (usually). Stop guessing which of a dozen capturing modules
to use in any particular situation and just use this one.
=head1 USAGE
The following functions are available. None are exported by default.
=head2 capture
($stdout, $stderr, @result) = capture \&code;
$stdout = capture \&code;
The C<<< capture >>> function takes a code reference and returns what is sent to
STDOUT and STDERR as well as any return values from the code reference. In
scalar context, it returns only STDOUT. If no output was received for a
filehandle, it returns an empty string for that filehandle. Regardless of calling
context, all output is captured -- nothing is passed to the existing filehandles.
It is prototyped to take a subroutine reference as an argument. Thus, it
can be called in block form:
($stdout, $stderr) = capture {
# your code here ...
};
Note that the coderef is evaluated in list context. If you wish to force
scalar context on the return value, you must use the C<<< scalar >>> keyword.
($stdout, $stderr, $count) = capture {
my @list = qw/one two three/;
return scalar @list; # $count will be 3
};
Also note that within the coderef, the C<<< @_ >>> variable will be empty. So don't
use arguments from a surrounding subroutine without copying them to an array
first:
sub wont_work {
my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG
...
}
sub will_work {
my @args = @_;
my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT
...
}
Captures are normally done to an anonymous temporary filehandle. To
capture via a named file (e.g. to externally monitor a long-running capture),
provide custom filehandles as a trailing list of option pairs:
my $out_fh = IO::File->new("out.txt", "w+");
my $err_fh = IO::File->new("out.txt", "w+");
capture { ... } stdout => $out_fh, stderr => $err_fh;
The filehandles must be readE<sol>write and seekable. Modifying the files or
filehandles during a capture operation will give unpredictable results.
Existing IO layers on them may be changed by the capture.
When called in void context, C<<< capture >>> saves memory and time by
not reading back from the capture handles.
=head2 capture_stdout
($stdout, @result) = capture_stdout \&code;
$stdout = capture_stdout \&code;
The C<<< capture_stdout >>> function works just like C<<< capture >>> except only
STDOUT is captured. STDERR is not captured.
=head2 capture_stderr
($stderr, @result) = capture_stderr \&code;
$stderr = capture_stderr \&code;
The C<<< capture_stderr >>> function works just like C<<< capture >>> except only
STDERR is captured. STDOUT is not captured.
=head2 capture_merged
($merged, @result) = capture_merged \&code;
$merged = capture_merged \&code;
The C<<< capture_merged >>> function works just like C<<< capture >>> except STDOUT and
STDERR are merged. (Technically, STDERR is redirected to the same capturing
handle as STDOUT before executing the function.)
Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
properly ordered due to buffering.
=head2 tee
($stdout, $stderr, @result) = tee \&code;
$stdout = tee \&code;
The C<<< tee >>> function works just like C<<< capture >>>, except that output is captured
as well as passed on to the original STDOUT and STDERR.
When called in void context, C<<< tee >>> saves memory and time by
not reading back from the capture handles, except when the
original STDOUT OR STDERR were tied or opened to a scalar
handle.
=head2 tee_stdout
($stdout, @result) = tee_stdout \&code;
$stdout = tee_stdout \&code;
The C<<< tee_stdout >>> function works just like C<<< tee >>> except only
STDOUT is teed. STDERR is not teed (output goes to STDERR as usual).
=head2 tee_stderr
($stderr, @result) = tee_stderr \&code;
$stderr = tee_stderr \&code;
The C<<< tee_stderr >>> function works just like C<<< tee >>> except only
STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual).
=head2 tee_merged
($merged, @result) = tee_merged \&code;
$merged = tee_merged \&code;
The C<<< tee_merged >>> function works just like C<<< capture_merged >>> except that output
is captured as well as passed on to STDOUT.
Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
properly ordered due to buffering.
=head1 LIMITATIONS
=head2 Portability
Portability is a goal, not a guarantee. C<<< tee >>> requires fork, except on
Windows where C<<< system(1, @cmd) >>> is used instead. Not tested on any
particularly esoteric platforms yet. See the
L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny>
for test result by platform.
=head2 PerlIO layers
Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or
':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to
STDOUT or STDERR I<before> the call to C<<< capture >>> or C<<< tee >>>. This may not work
for tied filehandles (see below).
=head2 Modifying filehandles before capturing
Generally speaking, you should do little or no manipulation of the standard IO
filehandles prior to using Capture::Tiny. In particular, closing, reopening,
localizing or tying standard filehandles prior to capture may cause a variety of
unexpected, undesirable andE<sol>or unreliable behaviors, as described below.
Capture::Tiny does its best to compensate for these situations, but the
results may not be what you desire.
B<Closed filehandles>
Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
closed. However, since they will be reopened to capture or tee output, any
code within the captured block that depends on finding them closed will, of
course, not find them to be closed. If they started closed, Capture::Tiny will
close them again when the capture block finishes.
Note that this reopening will happen even for STDIN or a filehandle not being
captured to ensure that the filehandle used for capture is not opened to file
descriptor 0, as this causes problems on various platforms.
Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles
and also breaks tee() for undiagnosed reasons. So don't do that.
B<Localized filehandles>
If code localizes any of Perl's standard filehandles before capturing, the capture
will affect the localized filehandles and not the original ones. External system
calls are not affected by localizing a filehandle in Perl and will continue
to send output to the original filehandles (which will thus not be captured).
B<Scalar filehandles>
If STDOUT or STDERR are reopened to scalar filehandles prior to the call to
C<<< capture >>> or C<<< tee >>>, then Capture::Tiny will override the output filehandle for
the duration of the C<<< capture >>> or C<<< tee >>> call and then, for C<<< tee >>>, send captured
output to the output filehandle after the capture is complete. (Requires Perl
5.8)
Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
reference, but note that external processes will not be able to read from such
a handle. Capture::Tiny tries to ensure that external processes will read from
the null device instead, but this is not guaranteed.
B<Tied output filehandles>
If STDOUT or STDERR are tied prior to the call to C<<< capture >>> or C<<< tee >>>, then
Capture::Tiny will attempt to override the tie for the duration of the
C<<< capture >>> or C<<< tee >>> call and then send captured output to the tied filehandle after
the capture is complete. (Requires Perl 5.8)
Capture::Tiny may not succeed resending UTF-8 encoded data to a tied
STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle
is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine
appropriate layers like C<<< :utf8 >>> from the underlying filehandle and do the right
thing.
B<Tied input filehandle>
Capture::Tiny attempts to preserve the semantics of tied STDIN, but this
requires Perl 5.8 and is not entirely predictable. External processes
will not be able to read from such a handle.
Unless having STDIN tied is crucial, it may be safest to localize STDIN when
capturing:
my ($out, $err) = do { local *STDIN; capture { ... } };
=head2 Modifying filehandles during a capture
Attempting to modify STDIN, STDOUT or STDERR I<during> C<<< capture >>> or C<<< tee >>> is
almost certainly going to cause problems. Don't do that.
=head2 No support for Perl 5.8.0
It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later
is recommended.
=head2 Limited support for Perl 5.6
Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly.
=head1 ENVIRONMENT
=head2 PERL_CAPTURE_TINY_TIMEOUT
Capture::Tiny uses subprocesses for C<<< tee >>>. By default, Capture::Tiny will
timeout with an error if the subprocesses are not ready to receive data within
30 seconds (or whatever is the value of C<<< $Capture::Tiny::TIMEOUT >>>). An
alternate timeout may be specified by setting the C<<< PERL_CAPTURE_TINY_TIMEOUT >>>
environment variable. Setting it to zero will disable timeouts.
=head1 SEE ALSO
This module was, inspired by L<IO::CaptureOutput>, which provides
similar functionality without the ability to tee output and with more
complicated code and API. L<IO::CaptureOutput> does not handle layers
or most of the unusual cases described in the L</Limitations> section and
I no longer recommend it.
There are many other CPAN modules that provide some sort of output capture,
albeit with various limitations that make them appropriate only in particular
circumstances. I'm probably missing some. The long list is provided to show
why I felt Capture::Tiny was necessary.
=over
=item *
L<IO::Capture>
=item *
L<IO::Capture::Extended>
=item *
L<IO::CaptureOutput>
=item *
L<IPC::Capture>
=item *
L<IPC::Cmd>
=item *
L<IPC::Open2>
=item *
L<IPC::Open3>
=item *
L<IPC::Open3::Simple>
=item *
L<IPC::Open3::Utils>
=item *
L<IPC::Run>
=item *
L<IPC::Run::SafeHandles>
=item *
L<IPC::Run::Simple>
=item *
L<IPC::Run3>
=item *
L<IPC::System::Simple>
=item *
L<Tee>
=item *
L<IO::Tee>
=item *
L<File::Tee>
=item *
L<Filter::Handle>
=item *
L<Tie::STDERR>
=item *
L<Tie::STDOUT>
=item *
L<Test::Output>
=back
=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/Capture-Tiny/issues>.
You will be notified automatically of any progress on your issue.
=head2 Source Code
This is open source software. The code repository is available for
public review and contribution under the terms of the license.
L<https://github.com/dagolden/Capture-Tiny>
git clone https://github.com/dagolden/Capture-Tiny.git
=head1 AUTHOR
David Golden <dagolden@cpan.org>
=head1 CONTRIBUTORS
=for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler
=over 4
=item *
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
=item *
David E. Wheeler <david@justatheory.com>
=back
=head1 COPYRIGHT AND LICENSE
This software is Copyright (c) 2009 by David Golden.
This is free software, licensed under:
The Apache License, Version 2.0, January 2004
=cut
CAPTURE_TINY
$fatpacked{"Class/C3.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_C3';
package Class::C3;
use strict;
use warnings;
our $VERSION = '0.25';
our $C3_IN_CORE;
our $C3_XS;
BEGIN {
if($] > 5.009_004) {
$C3_IN_CORE = 1;
require mro;
}
elsif($C3_XS or not defined $C3_XS) {
my $error = do {
local $@;
eval { require Class::C3::XS };
$@;
};
if ($error) {
die $error if $error !~ /\blocate\b/;
if ($C3_XS) {
require Carp;
Carp::croak( "XS explicitly requested but Class::C3::XS is not available" );
}
require Algorithm::C3;
require Class::C3::next;
}
else {
$C3_XS = 1;
}
}
}
# this is our global stash of both
# MRO's and method dispatch tables
# the structure basically looks like
# this:
#
# $MRO{$class} = {
# MRO => [ <class precedence list> ],
# methods => {
# orig => <original location of method>,
# code => \&<ref to original method>
# },
# has_overload_fallback => (1 | 0)
# }
#
our %MRO;
# use these for debugging ...
sub _dump_MRO_table { %MRO }
our $TURN_OFF_C3 = 0;
# state tracking for initialize()/uninitialize()
our $_initialized = 0;
sub import {
my $class = caller();
# skip if the caller is main::
# since that is clearly not relevant
return if $class eq 'main';
return if $TURN_OFF_C3;
mro::set_mro($class, 'c3') if $C3_IN_CORE;
# make a note to calculate $class
# during INIT phase
$MRO{$class} = undef unless exists $MRO{$class};
}
## initializers
# This prevents silly warnings when Class::C3 is
# used explicitly along with MRO::Compat under 5.9.5+
{ no warnings 'redefine';
sub initialize {
%next::METHOD_CACHE = ();
# why bother if we don't have anything ...
return unless keys %MRO;
if($C3_IN_CORE) {
mro::set_mro($_, 'c3') for keys %MRO;
}
else {
if($_initialized) {
uninitialize();
$MRO{$_} = undef foreach keys %MRO;
}
_calculate_method_dispatch_tables();
_apply_method_dispatch_tables();
$_initialized = 1;
}
}
sub uninitialize {
# why bother if we don't have anything ...
%next::METHOD_CACHE = ();
return unless keys %MRO;
if($C3_IN_CORE) {
mro::set_mro($_, 'dfs') for keys %MRO;
}
else {
_remove_method_dispatch_tables();
$_initialized = 0;
}
}
sub reinitialize { goto &initialize }
} # end of "no warnings 'redefine'"
## functions for applying C3 to classes
sub _calculate_method_dispatch_tables {
return if $C3_IN_CORE;
my %merge_cache;
foreach my $class (keys %MRO) {
_calculate_method_dispatch_table($class, \%merge_cache);
}
}
sub _calculate_method_dispatch_table {
return if $C3_IN_CORE;
my ($class, $merge_cache) = @_;
no strict 'refs';
my @MRO = calculateMRO($class, $merge_cache);
$MRO{$class} = { MRO => \@MRO };
my $has_overload_fallback;
my %methods;
# NOTE:
# we do @MRO[1 .. $#MRO] here because it
# makes no sense to interrogate the class
# which you are calculating for.
foreach my $local (@MRO[1 .. $#MRO]) {
# if overload has tagged this module to
# have use "fallback", then we want to
# grab that value
$has_overload_fallback = ${"${local}::()"}
if !defined $has_overload_fallback && defined ${"${local}::()"};
foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
# skip if already overridden in local class
next unless !defined *{"${class}::$method"}{CODE};
$methods{$method} = {
orig => "${local}::$method",
code => \&{"${local}::$method"}
} unless exists $methods{$method};
}
}
# now stash them in our %MRO table
$MRO{$class}->{methods} = \%methods;
$MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
}
sub _apply_method_dispatch_tables {
return if $C3_IN_CORE;
foreach my $class (keys %MRO) {
_apply_method_dispatch_table($class);
}
}
sub _apply_method_dispatch_table {
return if $C3_IN_CORE;
my $class = shift;
no strict 'refs';
${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
if !defined &{"${class}::()"}
&& defined $MRO{$class}->{has_overload_fallback};
foreach my $method (keys %{$MRO{$class}->{methods}}) {
if ( $method =~ /^\(/ ) {
my $orig = $MRO{$class}->{methods}->{$method}->{orig};
${"${class}::$method"} = $$orig if defined $$orig;
}
*{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
}
}
sub _remove_method_dispatch_tables {
return if $C3_IN_CORE;
foreach my $class (keys %MRO) {
_remove_method_dispatch_table($class);
}
}
sub _remove_method_dispatch_table {
return if $C3_IN_CORE;
my $class = shift;
no strict 'refs';
delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
foreach my $method (keys %{$MRO{$class}->{methods}}) {
delete ${"${class}::"}{$method}
if defined *{"${class}::${method}"}{CODE} &&
(*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
}
}
sub calculateMRO {
my ($class, $merge_cache) = @_;
return Algorithm::C3::merge($class, sub {
no strict 'refs';
@{$_[0] . '::ISA'};
}, $merge_cache);
}
# Method overrides to support 5.9.5+ or Class::C3::XS
sub _core_calculateMRO { @{mro::get_linear_isa($_[0], 'c3')} }
if($C3_IN_CORE) {
no warnings 'redefine';
*Class::C3::calculateMRO = \&_core_calculateMRO;
}
elsif($C3_XS) {
no warnings 'redefine';
*Class::C3::calculateMRO = \&Class::C3::XS::calculateMRO;
*Class::C3::_calculate_method_dispatch_table
= \&Class::C3::XS::_calculate_method_dispatch_table;
}
1;
__END__
=pod
=head1 NAME
Class::C3 - A pragma to use the C3 method resolution order algorithm
=head1 SYNOPSIS
# NOTE - DO NOT USE Class::C3 directly as a user, use MRO::Compat instead!
package ClassA;
use Class::C3;
sub hello { 'A::hello' }
package ClassB;
use base 'ClassA';
use Class::C3;
package ClassC;
use base 'ClassA';
use Class::C3;
sub hello { 'C::hello' }
package ClassD;
use base ('ClassB', 'ClassC');
use Class::C3;
# Classic Diamond MI pattern
# <A>
# / \
# <B> <C>
# \ /
# <D>
package main;
# initializez the C3 module
# (formerly called in INIT)
Class::C3::initialize();
print join ', ' => Class::C3::calculateMRO('ClassD'); # prints ClassD, ClassB, ClassC, ClassA
print ClassD->hello(); # prints 'C::hello' instead of the standard p5 'A::hello'
ClassD->can('hello')->(); # can() also works correctly
UNIVERSAL::can('ClassD', 'hello'); # as does UNIVERSAL::can()
=head1 DESCRIPTION
This is pragma to change Perl 5's standard method resolution order from depth-first left-to-right
(a.k.a - pre-order) to the more sophisticated C3 method resolution order.
B<NOTE:> YOU SHOULD NOT USE THIS MODULE DIRECTLY - The feature provided
is integrated into perl version >= 5.9.5, and you should use L<MRO::Compat>
instead, which will use the core implementation in newer perls, but fallback
to using this implementation on older perls.
=head2 What is C3?
C3 is the name of an algorithm which aims to provide a sane method resolution order under multiple
inheritance. It was first introduced in the language Dylan (see links in the L<SEE ALSO> section),
and then later adopted as the preferred MRO (Method Resolution Order) for the new-style classes in
Python 2.3. Most recently it has been adopted as the 'canonical' MRO for Perl 6 classes, and the
default MRO for Parrot objects as well.
=head2 How does C3 work.
C3 works by always preserving local precedence ordering. This essentially means that no class will
appear before any of its subclasses. Take the classic diamond inheritance pattern for instance:
<A>
/ \
<B> <C>
\ /
<D>
The standard Perl 5 MRO would be (D, B, A, C). The result being that B<A> appears before B<C>, even
though B<C> is the subclass of B<A>. The C3 MRO algorithm however, produces the following MRO
(D, B, C, A), which does not have this same issue.
This example is fairly trivial, for more complex examples and a deeper explanation, see the links in
the L<SEE ALSO> section.
=head2 How does this module work?
This module uses a technique similar to Perl 5's method caching. When C<Class::C3::initialize> is
called, this module calculates the MRO of all the classes which called C<use Class::C3>. It then
gathers information from the symbol tables of each of those classes, and builds a set of method
aliases for the correct dispatch ordering. Once all these C3-based method tables are created, it
then adds the method aliases into the local classes symbol table.
The end result is actually classes with pre-cached method dispatch. However, this caching does not
do well if you start changing your C<@ISA> or messing with class symbol tables, so you should consider
your classes to be effectively closed. See the L<CAVEATS> section for more details.
=head1 OPTIONAL LOWERCASE PRAGMA
This release also includes an optional module B<c3> in the F<opt/> folder. I did not include this in
the regular install since lowercase module names are considered I<"bad"> by some people. However I
think that code looks much nicer like this:
package MyClass;
use c3;
This is more clunky:
package MyClass;
use Class::C3;
But hey, it's your choice, that's why it is optional.
=head1 FUNCTIONS
=over 4
=item B<calculateMRO ($class)>
Given a C<$class> this will return an array of class names in the proper C3 method resolution order.
=item B<initialize>
This B<must be called> to initialize the C3 method dispatch tables, this module B<will not work> if
you do not do this. It is advised to do this as soon as possible B<after> loading any classes which
use C3. Here is a quick code example:
package Foo;
use Class::C3;
# ... Foo methods here
package Bar;
use Class::C3;
use base 'Foo';
# ... Bar methods here
package main;
Class::C3::initialize(); # now it is safe to use Foo and Bar
This function used to be called automatically for you in the INIT phase of the perl compiler, but
that lead to warnings if this module was required at runtime. After discussion with my user base
(the L<DBIx::Class> folks), we decided that calling this in INIT was more of an annoyance than a
convenience. I apologize to anyone this causes problems for (although I would be very surprised if I had
any other users other than the L<DBIx::Class> folks). The simplest solution of course is to define
your own INIT method which calls this function.
NOTE:
If C<initialize> detects that C<initialize> has already been executed, it will L</uninitialize> and
clear the MRO cache first.
=item B<uninitialize>
Calling this function results in the removal of all cached methods, and the restoration of the old Perl 5
style dispatch order (depth-first, left-to-right).
=item B<reinitialize>
This is an alias for L</initialize> above.
=back
=head1 METHOD REDISPATCHING
It is always useful to be able to re-dispatch your method call to the "next most applicable method". This
module provides a pseudo package along the lines of C<SUPER::> or C<NEXT::> which will re-dispatch the
method along the C3 linearization. This is best shown with an example.
# a classic diamond MI pattern ...
# <A>
# / \
# <B> <C>
# \ /
# <D>
package A;
use c3;
sub foo { 'A::foo' }
package B;
use base 'A';
use c3;
sub foo { 'B::foo => ' . (shift)->next::method() }
package C;
use base 'A';
use c3;
sub foo { 'C::foo => ' . (shift)->next::method() }
package D;
use base ('B', 'C');
use c3;
sub foo { 'D::foo => ' . (shift)->next::method() }
print D->foo; # prints out "D::foo => B::foo => C::foo => A::foo"
A few things to note. First, we do not require you to add on the method name to the C<next::method>
call (this is unlike C<NEXT::> and C<SUPER::> which do require that). This helps to enforce the rule
that you cannot dispatch to a method of a different name (this is how C<NEXT::> behaves as well).
The next thing to keep in mind is that you will need to pass all arguments to C<next::method>. It can
not automatically use the current C<@_>.
If C<next::method> cannot find a next method to re-dispatch the call to, it will throw an exception.
You can use C<next::can> to see if C<next::method> will succeed before you call it like so:
$self->next::method(@_) if $self->next::can;
Additionally, you can use C<maybe::next::method> as a shortcut to only call the next method if it exists.
The previous example could be simply written as:
$self->maybe::next::method(@_);
There are some caveats about using C<next::method>, see below for those.
=head1 CAVEATS
This module used to be labeled as I<experimental>, however it has now been pretty heavily tested by
the good folks over at L<DBIx::Class> and I am confident this module is perfectly usable for
whatever your needs might be.
But there are still caveats, so here goes ...
=over 4
=item Use of C<SUPER::>.
The idea of C<SUPER::> under multiple inheritance is ambiguous, and generally not recommended anyway.
However, its use in conjunction with this module is very much not recommended, and in fact very
discouraged. The recommended approach is to instead use the supplied C<next::method> feature, see
more details on its usage above.
=item Changing C<@ISA>.
It is the author's opinion that changing C<@ISA> at runtime is pure insanity anyway. However, people
do it, so I must caveat. Any changes to the C<@ISA> will not be reflected in the MRO calculated by this
module, and therefore probably won't even show up. If you do this, you will need to call C<reinitialize>
in order to recalculate B<all> method dispatch tables. See the C<reinitialize> documentation and an example
in F<t/20_reinitialize.t> for more information.
=item Adding/deleting methods from class symbol tables.
This module calculates the MRO for each requested class by interrogating the symbol tables of said classes.
So any symbol table manipulation which takes place after our INIT phase is run will not be reflected in
the calculated MRO. Just as with changing the C<@ISA>, you will need to call C<reinitialize> for any
changes you make to take effect.
=item Calling C<next::method> from methods defined outside the class
There is an edge case when using C<next::method> from within a subroutine which was created in a different
module than the one it is called from. It sounds complicated, but it really isn't. Here is an example which
will not work correctly:
*Foo::foo = sub { (shift)->next::method(@_) };
The problem exists because the anonymous subroutine being assigned to the glob C<*Foo::foo> will show up
in the call stack as being called C<__ANON__> and not C<foo> as you might expect. Since C<next::method>
uses C<caller> to find the name of the method it was called in, it will fail in this case.
But fear not, there is a simple solution. The module C<Sub::Name> will reach into the perl internals and
assign a name to an anonymous subroutine for you. Simply do this:
use Sub::Name 'subname';
*Foo::foo = subname 'Foo::foo' => sub { (shift)->next::method(@_) };
and things will Just Work. Of course this is not always possible to do, but to be honest, I just can't
manage to find a workaround for it, so until someone gives me a working patch this will be a known
limitation of this module.
=back
=head1 COMPATIBILITY
If your software requires Perl 5.9.5 or higher, you do not need L<Class::C3>, you can simply C<use mro 'c3'>, and not worry about C<initialize()>, avoid some of the above caveats, and get the best possible performance. See L<mro> for more details.
If your software is meant to work on earlier Perls, use L<Class::C3> as documented here. L<Class::C3> will detect Perl 5.9.5+ and take advantage of the core support when available.
=head1 Class::C3::XS
This module will load L<Class::C3::XS> if it's installed and you are running on a Perl version older than 5.9.5. The optional module will be automatically installed for you if a C compiler is available, as it results in significant performance improvements (but unlike the 5.9.5+ core support, it still has all of the same caveats as L<Class::C3>).
=head1 CODE COVERAGE
L<Devel::Cover> was reporting 94.4% overall test coverage earlier in this module's life. Currently, the test suite does things that break under coverage testing, but it is fair to assume the coverage is still close to that value.
=head1 SEE ALSO
=head2 The original Dylan paper
=over 4
=item L<http://www.webcom.com/haahr/dylan/linearization-oopsla96.html>
=back
=head2 The prototype Perl 6 Object Model uses C3
=over 4
=item L<http://svn.openfoundry.org/pugs/perl5/Perl6-MetaModel/>
=back
=head2 Parrot now uses C3
=over 4
=item L<http://aspn.activestate.com/ASPN/Mail/Message/perl6-internals/2746631>
=item L<http://use.perl.org/~autrijus/journal/25768>
=back
=head2 Python 2.3 MRO related links
=over 4
=item L<http://www.python.org/2.3/mro.html>
=item L<http://www.python.org/2.2.2/descrintro.html#mro>
=back
=head2 C3 for TinyCLOS
=over 4
=item L<http://www.call-with-current-continuation.org/eggs/c3.html>
=back
=head1 ACKNOWLEGEMENTS
=over 4
=item Thanks to Matt S. Trout for using this module in his module L<DBIx::Class>
and finding many bugs and providing fixes.
=item Thanks to Justin Guenther for making C<next::method> more robust by handling
calls inside C<eval> and anon-subs.
=item Thanks to Robert Norris for adding support for C<next::can> and
C<maybe::next::method>.
=back
=head1 AUTHOR
Stevan Little, E<lt>stevan@iinteractive.comE<gt>
Brandon L. Black, E<lt>blblack@gmail.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2005, 2006 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
CLASS_C3
$fatpacked{"Class/C3/next.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_C3_NEXT';
package # hide me from PAUSE
next;
use strict;
use warnings;
no warnings 'redefine'; # for 00load.t w/ core support
use Scalar::Util 'blessed';
our $VERSION = '0.24';
our %METHOD_CACHE;
sub method {
my $self = $_[0];
my $class = blessed($self) || $self;
my $indirect = caller() =~ /^(?:next|maybe::next)$/;
my $level = $indirect ? 2 : 1;
my ($method_caller, $label, @label);
while ($method_caller = (caller($level++))[3]) {
@label = (split '::', $method_caller);
$label = pop @label;
last unless
$label eq '(eval)' ||
$label eq '__ANON__';
}
my $method;
my $caller = join '::' => @label;
$method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
my @MRO = Class::C3::calculateMRO($class);
my $current;
while ($current = shift @MRO) {
last if $caller eq $current;
}
no strict 'refs';
my $found;
foreach my $class (@MRO) {
next if (defined $Class::C3::MRO{$class} &&
defined $Class::C3::MRO{$class}{methods}{$label});
last if (defined ($found = *{$class . '::' . $label}{CODE}));
}
$found;
};
return $method if $indirect;
die "No next::method '$label' found for $self" if !$method;
goto &{$method};
}
sub can { method($_[0]) }
package # hide me from PAUSE
maybe::next;
use strict;
use warnings;
no warnings 'redefine'; # for 00load.t w/ core support
our $VERSION = '0.24';
sub method { (next::method($_[0]) || return)->(@_) }
1;
__END__
=pod
=head1 NAME
Class::C3::next - Pure-perl next::method and friends
=head1 DESCRIPTION
This module is used internally by L<Class::C3> when
necessary, and shouldn't be used (or required in
distribution dependencies) directly. It
defines C<next::method>, C<next::can>, and
C<maybe::next::method> in pure perl.
=head1 AUTHOR
Stevan Little, E<lt>stevan@iinteractive.comE<gt>
Brandon L. Black, E<lt>blblack@gmail.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2005, 2006 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
CLASS_C3_NEXT
$fatpacked{"Data/Dumper/Concise.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_DUMPER_CONCISE';
package Data::Dumper::Concise;
use 5.006;
$VERSION = '2.021';
require Exporter;
require Data::Dumper;
BEGIN { @ISA = qw(Exporter) }
@EXPORT = qw(Dumper DumperF DumperObject);
sub DumperObject {
my $dd = Data::Dumper->new([]);
$dd->Terse(1)->Indent(1)->Useqq(1)->Deparse(1)->Quotekeys(0)->Sortkeys(1);
}
sub Dumper { DumperObject->Values([ @_ ])->Dump }
sub DumperF (&@) {
my $code = shift;
return $code->(map Dumper($_), @_);
}
=head1 NAME
Data::Dumper::Concise - Less indentation and newlines plus sub deparsing
=head1 SYNOPSIS
use Data::Dumper::Concise;
warn Dumper($var);
is equivalent to:
use Data::Dumper;
{
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Useqq = 1;
local $Data::Dumper::Deparse = 1;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Sortkeys = 1;
warn Dumper($var);
}
So for the structure:
{ foo => "bar\nbaz", quux => sub { "fleem" } };
Data::Dumper::Concise will give you:
{
foo => "bar\nbaz",
quux => sub {
use warnings;
use strict 'refs';
'fleem';
}
}
instead of the default Data::Dumper output:
$VAR1 = {
'quux' => sub { "DUMMY" },
'foo' => 'bar
baz'
};
(note the tab indentation, oh joy ...)
If you need to get the underlying L<Dumper> object just call C<DumperObject>.
Also try out C<DumperF> which takes a C<CodeRef> as the first argument to
format the output. For example:
use Data::Dumper::Concise;
warn DumperF { "result: $_[0] result2: $_[1]" } $foo, $bar;
Which is the same as:
warn 'result: ' . Dumper($foo) . ' result2: ' . Dumper($bar);
=head1 DESCRIPTION
This module always exports a single function, Dumper, which can be called
with an array of values to dump those values.
It exists, fundamentally, as a convenient way to reproduce a set of Dumper
options that we've found ourselves using across large numbers of applications,
primarily for debugging output.
The principle guiding theme is "all the concision you can get while still
having a useful dump and not doing anything cleverer than setting Data::Dumper
options" - it's been pointed out to us that Data::Dump::Streamer can produce
shorter output with less lines of code. We know. This is simpler and we've
never seen it segfault. But for complex/weird structures, it generally rocks.
You should use it as well, when Concise is underkill. We do.
Why is deparsing on when the aim is concision? Because you often want to know
what subroutine refs you have when debugging and because if you were planning
to eval this back in you probably wanted to remove subrefs first and add them
back in a custom way anyway. Note that this -does- force using the pure perl
Dumper rather than the XS one, but I've never in my life seen Data::Dumper
show up in a profile so "who cares?".
=head1 BUT BUT BUT ...
Yes, we know. Consider this module in the ::Tiny spirit and feel free to
write a Data::Dumper::Concise::ButWithExtraTwiddlyBits if it makes you
happy. Then tell us so we can add it to the see also section.
=head1 SUGARY SYNTAX
This package also provides:
L<Data::Dumper::Concise::Sugar> - provides Dwarn and DwarnS convenience functions
L<Devel::Dwarn> - shorter form for Data::Dumper::Concise::Sugar
=head1 SEE ALSO
We use for some purposes, and dearly love, the following alternatives:
L<Data::Dump> - prettiness oriented but not amazingly configurable
L<Data::Dump::Streamer> - brilliant. beautiful. insane. extensive. excessive. try it.
L<JSON::XS> - no, really. If it's just plain data, JSON is a great option.
=head1 AUTHOR
mst - Matt S. Trout <mst@shadowcat.co.uk>
=head1 CONTRIBUTORS
frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
=head1 COPYRIGHT
Copyright (c) 2010 the Data::Dumper::Concise L</AUTHOR> and L</CONTRIBUTORS>
as listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself.
=cut
1;
DATA_DUMPER_CONCISE
$fatpacked{"Data/Dumper/Concise/Sugar.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DATA_DUMPER_CONCISE_SUGAR';
package Data::Dumper::Concise::Sugar;
use 5.006;
use Exporter ();
use Data::Dumper::Concise ();
BEGIN { @ISA = qw(Exporter) }
@EXPORT = qw(
$Dwarn $DwarnN Dwarn DwarnS DwarnL DwarnN DwarnF
$Ddie $DdieN Ddie DdieS DdieL DdieN DdieD
);
sub Dwarn { DwarnL(@_); return wantarray ? @_ : $_[0] }
our $Dwarn = \&Dwarn;
our $DwarnN = \&DwarnN;
sub DwarnL { warn Data::Dumper::Concise::Dumper @_; @_ }
sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
sub DwarnN ($) {
require Devel::ArgNames;
my $x = Devel::ArgNames::arg_names();
warn(($x?$x:'(anon)') . ' => ' . Data::Dumper::Concise::Dumper $_[0]); $_[0]
}
sub DwarnF (&@) { my $c = shift; warn &Data::Dumper::Concise::DumperF($c, @_); @_ }
sub Ddie { DdieL(@_); return wantarray ? @_ : $_[0] }
our $Ddie = \&Ddie;
our $DdieN = \&DdieN;
sub DdieL { die Data::Dumper::Concise::Dumper @_ }
sub DdieS ($) { die Data::Dumper::Concise::Dumper $_[0] }
sub DdieN ($) {
require Devel::ArgNames;
my $x = Devel::ArgNames::arg_names();
die(($x?$x:'(anon)') . ' => ' . Data::Dumper::Concise::Dumper $_[0]);
}
=head1 NAME
Data::Dumper::Concise::Sugar - return Dwarn @return_value
=head1 SYNOPSIS
use Data::Dumper::Concise::Sugar;
return Dwarn some_call(...)
is equivalent to:
use Data::Dumper::Concise;
if (wantarray) {
my @return = some_call(...);
warn Dumper(@return);
return @return;
} else {
my $return = some_call(...);
warn Dumper($return);
return $return;
}
but shorter. If you need to force scalar context on the value,
use Data::Dumper::Concise::Sugar;
return DwarnS some_call(...)
is equivalent to:
use Data::Dumper::Concise;
my $return = some_call(...);
warn Dumper($return);
return $return;
If you need to force list context on the value,
use Data::Dumper::Concise::Sugar;
return DwarnL some_call(...)
is equivalent to:
use Data::Dumper::Concise;
my @return = some_call(...);
warn Dumper(@return);
return @return;
If you want to label your output, try DwarnN
use Data::Dumper::Concise::Sugar;
return DwarnN $foo
is equivalent to:
use Data::Dumper::Concise;
my @return = some_call(...);
warn '$foo => ' . Dumper(@return);
return @return;
If you want to output a reference returned by a method easily, try $Dwarn
$foo->bar->{baz}->$Dwarn
is equivalent to:
my $return = $foo->bar->{baz};
warn Dumper($return);
return $return;
If you want to format the output of your data structures, try DwarnF
my ($a, $c) = DwarnF { "awesome: $_[0] not awesome: $_[1]" } $awesome, $cheesy;
is equivalent to:
my @return = ($awesome, $cheesy);
warn DumperF { "awesome: $_[0] not awesome: $_[1]" } $awesome, $cheesy;
return @return;
If you want to immediately die after outputting the data structure, every
Dwarn subroutine has a paired Ddie version, so just replace the warn with die.
For example:
DdieL 'foo', { bar => 'baz' };
=head1 DESCRIPTION
use Data::Dumper::Concise::Sugar;
will import Dwarn, $Dwarn, DwarnL, DwarnN, and DwarnS into your namespace. Using
L<Exporter>, so see its docs for ways to make it do something else.
=head2 Dwarn
sub Dwarn { return DwarnL(@_) if wantarray; DwarnS($_[0]) }
=head2 $Dwarn
$Dwarn = \&Dwarn
=head2 $DwarnN
$DwarnN = \&DwarnN
=head2 DwarnL
sub Dwarn { warn Data::Dumper::Concise::Dumper @_; @_ }
=head2 DwarnS
sub DwarnS ($) { warn Data::Dumper::Concise::Dumper $_[0]; $_[0] }
=head2 DwarnN
sub DwarnN { warn '$argname => ' . Data::Dumper::Concise::Dumper $_[0]; $_[0] }
B<Note>: this requires L<Devel::ArgNames> to be installed.
=head2 DwarnF
sub DwarnF (&@) { my $c = shift; warn &Data::Dumper::Concise::DumperF($c, @_); @_ }
=head1 TIPS AND TRICKS
=head2 global usage
Instead of always just doing:
use Data::Dumper::Concise::Sugar;
Dwarn ...
We tend to do:
perl -MData::Dumper::Concise::Sugar foo.pl
(and then in the perl code:)
::Dwarn ...
That way, if you leave them in and run without the
C<< use Data::Dumper::Concise::Sugar >> the program will fail to compile and
you are less likely to check it in by accident. Furthmore it allows that
much less friction to add debug messages.
=head2 method chaining
One trick which is useful when doing method chaining is the following:
my $foo = Bar->new;
$foo->bar->baz->Data::Dumper::Concise::Sugar::DwarnS->biff;
which is the same as:
my $foo = Bar->new;
(DwarnS $foo->bar->baz)->biff;
=head1 SEE ALSO
You probably want L<Devel::Dwarn>, it's the shorter name for this module.
=cut
1;
DATA_DUMPER_CONCISE_SUGAR
$fatpacked{"Devel/Dwarn.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DEVEL_DWARN';
package Devel::Dwarn;
use Data::Dumper::Concise::Sugar;
sub import {
Data::Dumper::Concise::Sugar->export_to_level(1, @_);
}
=head1 NAME
Devel::Dwarn - return Dwarn @return_value
=head1 SYNOPSIS
use Devel::Dwarn;
return Dwarn some_call(...)
is equivalent to:
use Data::Dumper::Concise;
if (wantarray) {
my @return = some_call(...);
warn Dumper(@return);
return @return;
} else {
my $return = some_call(...);
warn Dumper($return);
return $return;
}
but shorter. If you need to force scalar context on the value,
use Devel::Dwarn;
return DwarnS some_call(...)
is equivalent to:
use Data::Dumper::Concise;
my $return = some_call(...);
warn Dumper($return);
return $return;
If you need to force list context on the value,
use Devel::Dwarn;
return DwarnL some_call(...)
is equivalent to:
use Data::Dumper::Concise;
my @return = some_call(...);
warn Dumper(@return);
return @return;
If you want to label your output, try DwarnN
use Devel::Dwarn;
return DwarnN $foo
is equivalent to:
use Data::Dumper::Concise;
my @return = some_call(...);
warn '$foo => ' . Dumper(@return);
return @return;
If you want to output a reference returned by a method easily, try $Dwarn
$foo->bar->{baz}->$Dwarn
is equivalent to:
my $return = $foo->bar->{baz};
warn Dumper($return);
return $return;
If you want to immediately die after outputting the data structure, every
Dwarn subroutine has a paired Ddie version, so just replace the warn with die.
For example:
DdieL 'foo', { bar => 'baz' };
=head1 TIPS AND TRICKS
=head2 global usage
Instead of always just doing:
use Devel::Dwarn;
Dwarn ...
We tend to do:
perl -MDevel::Dwarn foo.pl
(and then in the perl code:)
::Dwarn ...
That way, if you leave them in and run without the C<< use Devel::Dwarn >>
the program will fail to compile and you are less likely to check it in by
accident. Furthmore it allows that much less friction to add debug messages.
=head2 method chaining
One trick which is useful when doing method chaining is the following:
my $foo = Bar->new;
$foo->bar->baz->Devel::Dwarn::DwarnS->biff;
which is the same as:
my $foo = Bar->new;
(DwarnS $foo->bar->baz)->biff;
=head1 SEE ALSO
This module is really just a shortcut for L<Data::Dumper::Concise::Sugar>, check
it out for more complete documentation.
=cut
1;
DEVEL_DWARN
$fatpacked{"Exporter/Declare.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE';
package Exporter::Declare;
use strict;
use warnings;
use Carp qw/croak/;
use Scalar::Util qw/reftype/;
use aliased 'Exporter::Declare::Meta';
use aliased 'Exporter::Declare::Specs';
use aliased 'Exporter::Declare::Export::Sub';
use aliased 'Exporter::Declare::Export::Variable';
use aliased 'Exporter::Declare::Export::Generator';
BEGIN { Meta->new(__PACKAGE__) }
our $VERSION = '0.113';
our @CARP_NOT = qw/
Exporter::Declare
Exporter::Declare::Specs
Exporter::Declare::Meta
Exporter::Declare::Magic
/;
default_exports(
qw/
import
exports
default_exports
import_options
import_arguments
export_tag
export
gen_export
default_export
gen_default_export
/
);
exports(
qw/
reexport
export_to
/
);
export_tag(
magic => qw/
!export
!gen_export
!default_export
!gen_default_export
/
);
sub import {
my $class = shift;
my $caller = caller;
$class->alter_import_args( $caller, \@_ )
if $class->can('alter_import_args');
my $specs = _parse_specs( $class, @_ );
$class->before_import( $caller, $specs )
if $class->can('before_import');
$specs->export($caller);
$class->after_import( $caller, $specs )
if $class->can('after_import');
}
sub after_import {
my $class = shift;
my ( $caller, $specs ) = @_;
Meta->new($caller);
return unless my $args = $specs->config->{'magic'};
$args = ['-default'] unless ref $args && ref $args eq 'ARRAY';
croak "Exporter::Declare::Magic must be installed seperately for -magic to work"
unless eval { require Exporter::Declare::Magic };
warn "Exporter::Declare -magic is deprecated. Please use Exporter::Declare::Magic directly";
export_to( 'Exporter::Declare::Magic', $caller, @$args );
}
sub _parse_specs {
my $class = _find_export_class( \@_ );
my (@args) = @_;
# XXX This is ugly!
unshift @args => '-default'
if $class eq __PACKAGE__
&& grep { $_ eq '-magic' } @args;
return Specs->new( $class, @args );
}
sub export_to {
my $class = _find_export_class( \@_ );
my ( $dest, @args ) = @_;
my $specs = _parse_specs( $class, @args );
$specs->export($dest);
return $specs;
}
sub export_tag {
my $class = _find_export_class( \@_ );
my ( $tag, @list ) = @_;
$class->export_meta->export_tags_push( $tag, @list );
}
sub exports {
my $class = _find_export_class( \@_ );
my $meta = $class->export_meta;
_export( $class, undef, $_ ) for @_;
$meta->export_tags_get('all');
}
sub default_exports {
my $class = _find_export_class( \@_ );
my $meta = $class->export_meta;
$meta->export_tags_push( 'default', _export( $class, undef, $_ ) ) for @_;
$meta->export_tags_get('default');
}
sub export {
my $class = _find_export_class( \@_ );
_export( $class, undef, @_ );
}
sub gen_export {
my $class = _find_export_class( \@_ );
_export( $class, Generator(), @_ );
}
sub default_export {
my $class = _find_export_class( \@_ );
my $meta = $class->export_meta;
$meta->export_tags_push( 'default', _export( $class, undef, @_ ) );
}
sub gen_default_export {
my $class = _find_export_class( \@_ );
my $meta = $class->export_meta;
$meta->export_tags_push( 'default', _export( $class, Generator(), @_ ) );
}
sub import_options {
my $class = _find_export_class( \@_ );
my $meta = $class->export_meta;
$meta->options_add($_) for @_;
}
sub import_arguments {
my $class = _find_export_class( \@_ );
my $meta = $class->export_meta;
$meta->arguments_add($_) for @_;
}
sub _parse_export_params {
my ( $class, $expclass, $name, @param ) = @_;
my $ref = ref( $param[-1] ) ? pop(@param) : undef;
my $meta = $class->export_meta;
( $ref, $name ) = $meta->get_ref_from_package($name)
unless $ref;
( my $type, $name ) = ( $name =~ m/^([\$\@\&\%]?)(.*)$/ );
$type = "" if $type eq '&';
my $fullname = "$type$name";
return (
class => $class,
export_class => $expclass || undef,
name => $name,
ref => $ref,
type => $type || "",
fullname => $fullname,
args => \@param,
);
}
sub _export {
_add_export( _parse_export_params(@_) );
}
sub _add_export {
my %params = @_;
my $meta = $params{class}->export_meta;
$params{export_class} ||=
reftype( $params{ref} ) eq 'CODE'
? Sub()
: Variable();
$params{export_class}->new(
$params{ref},
exported_by => $params{class},
(
$params{type} ? ( type => 'variable' )
: ( type => 'sub' )
),
(
$params{extra_exporter_props} ? %{$params{extra_exporter_props}}
: ()
),
);
$meta->exports_add( $params{fullname}, $params{ref} );
return $params{fullname};
}
sub _is_exporter_class {
my ($name) = @_;
return 0 unless $name;
# This is to work around a bug in older versions of UNIVERSAL::can which
# would issue a warning about $name->can() when $name was not a valid
# package.
# This will first verify that $name is a namespace, if not it will return false.
# If the namespace defines 'export_meta' we know it is an exporter.
# If there is no @ISA array in the namespace we simply return false,
# otherwise we fall back to $name->can().
{
no strict 'refs';
no warnings 'once';
return 0 unless keys %{"$name\::"};
return 1 if defined *{"$name\::export_meta"}{CODE};
return 0 unless @{"$name\::ISA"};
}
return eval { $name->can('export_meta'); 1 };
}
sub _find_export_class {
my $args = shift;
return shift(@$args)
if @$args && _is_exporter_class(@$args);
return caller(1);
}
sub reexport {
my $from = pop;
my $class = shift || caller;
$class->export_meta->reexport($from);
}
1;
=head1 NAME
Exporter::Declare - Exporting done right
=head1 DESCRIPTION
Exporter::Declare is a meta-driven exporting tool. Exporter::Declare tries to
adopt all the good features of other exporting tools, while throwing away
horrible interfaces. Exporter::Declare also provides hooks that allow you to add
options and arguments for import. Finally, Exporter::Declare's meta-driven
system allows for top-notch introspection.
=head1 FEATURES
=over 4
=item Declarative exporting (like L<Moose> for exporting)
=item Meta-driven for introspection
=item Customizable import() method
=item Export groups (tags)
=item Export generators for subs and variables
=item Clear and concise OO API
=item Exports are blessed, allowing for more introspection
=item Import syntax based off of L<Sub::Exporter>
=item Packages export aliases
=back
=head1 SYNOPSIS
=head2 EXPORTER
package Some::Exporter;
use Exporter::Declare;
default_exports qw/ do_the_thing /;
exports qw/ subA subB $SCALAR @ARRAY %HASH /;
# Create a couple tags (import lists)
export_tag subs => qw/ subA subB do_the_thing /;
export_tag vars => qw/ $SCALAR @ARRAY %HASH /;
# These are simple boolean options, pass '-optionA' to enable it.
import_options qw/ optionA optionB /;
# These are options which slurp in the next argument as their value, pass
# '-optionC' => 'foo' to give it a value.
import_arguments qw/ optionC optionD /;
export anon_export => sub { ... };
export '@anon_var' => [...];
default_export a_default => sub { 'default!' }
our $X = "x";
default_export '$X';
my $iterator = 'a';
gen_export unique_class_id => sub {
my $current = $iterator++;
return sub { $current };
};
gen_default_export '$my_letter' => sub {
my $letter = $iterator++;
return \$letter;
};
# You can create a function to mangle the arguments before they are
# parsed into a Exporter::Declare::Spec object.
sub alter_import_args {
my ($class, $args) = @_;
# fiddle with args before importing routines are called
@$args = grep { !/^skip_/ } @$args
}
# There is no need to fiddle with import() or do any wrapping.
# the $specs data structure means you generally do not need to parse
# arguments yourself (but you can if you want using alter_import_args())
# Change the spec object before export occurs
sub before_import {
my $class = shift;
my ( $importer, $specs ) = @_;
if ($specs->config->{optionA}) {
# Modify $spec attributes accordingly
}
}
# Use spec object after export occurs
sub after_import {
my $class = shift;
my ( $importer, $specs ) = @_;
do_option_a() if $specs->config->{optionA};
do_option_c( $specs->config->{optionC} )
if $specs->config->{optionC};
print "-subs tag was used\n"
if $specs->config->{subs};
print "exported 'subA'\n"
if $specs->exports->{subA};
}
...
=head2 IMPORTER
package Some::Importer;
use Some::Exporter qw/ subA $SCALAR !%HASH /,
-default => { -prefix => 'my_' },
qw/ -optionA !-optionB /,
subB => { -as => 'sub_b' };
subA();
print $SCALAR;
sub_b();
my_do_the_thing();
...
=head1 IMPORT INTERFACE
Importing from a package that uses Exporter::Declare will be familiar to anyone
who has imported from modules before. Arguments are all assumed to be export
names, unless prefixed with C<-> or C<:> In which case they may be a tag or an
option. Exports without a sigil are assumed to be code exports, variable
exports must be listed with their sigil.
Items prefixed with the C<!> symbol are forcfully excluded, regardless of any
listed item that may normally include them. Tags can also be excluded, this
will effectively exclude everything in the tag.
Tags are simply lists of exports, the exporting class may define any number of
tags. Exporter::Declare also has the concept of options, they have the same
syntax as tags. Options may be boolean or argument based. Boolean options are
actually 3 value, undef, false C<!>, or true. Argument based options will grab
the next value in the arguments list as their own, regardless of what type of
value it is.
When you use the module, or call import(), all the arguments are transformed
into an L<Exporter::Declare::Specs> object. Arguments are parsed for you into a
list of imports, and a configuration hash in which tags/options are keys. Tags
are listed in the config hash as true, false, or undef depending on if they
were included, negated, or unlisted. Boolean options will be treated in the
same way as tags. Options that take arguments will have the argument as their
value.
=head2 SELECTING ITEMS TO IMPORT
Exports can be subs, or package variables (scalar, hash, array). For subs
simply ask for the sub by name, you may optionally prefix the subs name with
the sub sigil C<&>. For variables list the variable name along with its sigil
C<$, %, or @>.
use Some::Exporter qw/ somesub $somescalar %somehash @somearray /;
=head2 TAGS
Every exporter automatically has the following 3 tags, in addition they may
define any number of custom tags. Tags can be specified by their name prefixed
by either C<-> or C<:>.
=over 4
=item -all
This tag may be used to import everything the exporter provides.
=item -default
This tag is used to import the default items exported. This will be used when
no argument is provided to import.
=item -alias
Every package has an alias that it can export. This is the last segmant of the
packages namespace. IE C<My::Long::Package::Name::Foo> could export the C<Foo()>
function. These alias functionis simply return the full package name as a
string, in this case C<'My::Long::Package::Name::Foo'>. This is similar to
L<aliased>.
The -alias tag is a shortcut so that you do not need to think about what the
alias name would be when adding it to the import arguments.
use My::Long::Package::Name::Foo -alias;
my $foo = Foo()->new(...);
=back
=head2 RENAMING IMPORTED ITEMS
You can prefix, suffix, or completely rename the items you import. Whenever an
item is followed by a hash in the import list, that hash will be used for
configuration. Configuration items always start with a dash C<->.
The 3 available configuration options that effect import names are C<-prefix>,
C<-suffix>, and C<-as>. If C<-as> is seen it will be used as is. If prefix or
suffix are seen they will be attached to the original name (unless -as is
present in which case they are ignored).
use Some::Exporter subA => { -as => 'DoThing' },
subB => { -prefix => 'my_', -suffix => '_ok' };
The example above will import C<subA()> under the name C<DoThing()>. It will
also import C<subB()> under the name C<my_subB_ok()>.
You may als specify a prefix and/or suffix for tags. The following example will
import all the default exports with 'my_' prefixed to each name.
use Some::Exporter -default => { -prefix => 'my_' };
=head2 OPTIONS
Some exporters will recognise options. Options look just like tags, and are
specified the same way. What options do, and how they effect things is
exporter-dependant.
use Some::Exporter qw/ -optionA -optionB /;
=head2 ARGUMENTS
Some options require an argument. These options are just like other
tags/options except that the next item in the argument list is slurped in as
the option value.
use Some::Exporter -ArgOption => 'Value, not an export',
-ArgTakesHash => { ... };
Once again available options are exporter specific.
=head2 PROVIDING ARGUMENTS FOR GENERATED ITEMS
Some items are generated at import time. These items may accept arguments.
There are 3 ways to provide arguments, and they may all be mixed (though that
is not recommended).
As a hash
use Some::Exporter generated => { key => 'val', ... };
As an array
use Some::Exporter generated => [ 'Arg1', 'Arg2', ... ];
As an array in a config hash
use Some::Exporter generated => { -as => 'my_gen', -args => [ 'arg1', ... ]};
You can use all three at once, but this is really a bad idea, documented for completeness:
use Some::Exporter generated => { -as => 'my_gen, key => 'value', -args => [ 'arg1', 'arg2' ]}
generated => [ 'arg3', 'arg4' ];
The example above will work fine, all the arguments will make it into the
generator. The only valid reason for this to work is that you may provide
arguments such as C<-prefix> to a tag that brings in generator(), while also
desiring to give arguments to generator() independantly.
=head1 PRIMARY EXPORT API
With the exception of import(), all the following work equally well as
functions or class methods.
=over 4
=item import( @args )
The import() class method. This turns the @args list into an
L<Exporter::Declare::Specs> object.
=item exports( @add_items )
Add items to be exported.
=item @list = exports()
Retrieve list of exports.
=item default_exports( @add_items )
Add items to be exported, and add them to the -default tag.
=item @list = default_exports()
List of exports in the -default tag
=item import_options(@add_items)
Specify boolean options that should be accepted at import time.
=item import_arguments(@add_items)
Specify options that should be accepted at import that take arguments.
=item export_tag( $name, @add_items );
Define an export tag, or add items to an existing tag.
=back
=head1 EXTENDED EXPORT API
These all work fine in function or method form, however the syntax sugar will
only work in function form.
=over 4
=item reexport( $package )
Make this exporter inherit all the exports and tags of $package. Works for
Exporter::Declare or Exporter.pm based exporters. Re-Exporting of
L<Sub::Exporter> based classes is not currently supported.
=item export_to( $package, @args )
Export to the specified class.
=item export( $name )
=item export( $name, $ref )
export is a keyword that lets you export any 1 item at a time. The item can be
exported by name, or name + ref. When a ref is provided, the export is created,
but there is no corresponding variable/sub in the packages namespace.
=item default_export( $name )
=item default_export( $name, $ref )
=item gen_export( $name )
=item gen_export( $name, $ref )
=item gen_default_export( $name )
=item gen_default_export( $name, $ref )
These all act just like export(), except that they add subrefs as generators,
and/or add exports to the -default tag.
=back
=head1 MAGIC
Please use L<Exporter::Declare::Magic> directly from now on.
=head2 DEPRECATED USAGE OF MAGIC
use Exporter::Declare '-magic';
This adds L<Devel::Declare> magic to several functions. It also allows you to
easily create or use parsers on your own exports. See
L<Exporter::Declare::Magic> for more details.
You can also provide import arguments to L<Devel::Declare::Magic>
# Arguments to -magic must be in an arrayref, not a hashref.
use Exporter::Declare -magic => [ '-default', '!export', -prefix => 'magic_' ];
=head1 INTERNAL API
Exporter/Declare.pm does not have much logic to speak of. Rather
Exporter::Declare is sugar on top of class meta data stored in
L<Exporter::Declare::Meta> objects. Arguments are parsed via
L<Exporter::Declare::Specs>, and also turned into objects. Even exports are
blessed references to the exported item itself, and handle the injection on
their own (See L<Exporter::Declare::Export>).
=head1 META CLASS
All exporters have a meta class, the only way to get the meta object is to call
the exporter_meta() method on the class/object that is an exporter. Any class
that uses Exporter::Declare gets this method, and a meta-object.
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE
$fatpacked{"Exporter/Declare/Export.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE_EXPORT';
package Exporter::Declare::Export;
use strict;
use warnings;
use Carp qw/croak carp/;
use Scalar::Util qw/reftype/;
our %OBJECT_DATA;
sub required_specs {qw/ exported_by /}
sub new {
my $class = shift;
my ( $item, %specs ) = @_;
my $self = bless( $item, $class );
for my $prop ( $self->required_specs ) {
croak "You must specify $prop when calling $class\->new()"
unless $specs{$prop};
}
$OBJECT_DATA{$self} = \%specs;
return $self;
}
sub _data {
my $self = shift;
($OBJECT_DATA{$self}) = @_ if @_;
$OBJECT_DATA{$self};
}
sub exported_by {
shift->_data->{ exported_by };
}
sub inject {
my $self = shift;
my ( $class, $name, @args ) = @_;
carp(
"Ignoring arguments importing ("
. reftype($self)
. ")$name into $class: "
. join( ', ', @args )
) if (@args);
croak "You must provide a class and name to inject()"
unless $class && $name;
no strict 'refs';
no warnings 'once';
*{"$class\::$name"} = $self;
}
sub DESTROY {
my $self = shift;
delete $OBJECT_DATA{$self};
}
1;
=head1 NAME
Exporter::Declare::Export - Base class for all export objects.
=head1 DESCRIPTION
All exports are refs, and all are blessed. This class tracks some per-export
information via an inside-out objects system. All things an export may need to
do, such as inject itself into a package are handled here. This allows some
complicated, or ugly logic to be abstracted out of the exporter and metadata
classes.
=head1 METHODS
=over
=item $class->new( $ref, exported_by => $package, %data )
Create a new export from $ref. You must specify the name of the class doing the
exporting.
=item $export->inject( $package, $name, @args )
This will inject the export into $package under $name. @args are ignored in
most cases. See L<Exporter::Declare::Export::Generator> for an example where
they are used.
=item $package = $export->exported_by()
Returns the name of the package from which this export was originally exported.
=item @params = $export->required_specs()
Documented for subclassing purposes. This should always return a list of
required parameters at construction time.
=item $export->DESTROY()
Documented for subclassing purposes. This takes care of cleanup related to
storing data in an inside-out objects system.
=back
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE_EXPORT
$fatpacked{"Exporter/Declare/Export/Alias.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE_EXPORT_ALIAS';
package Exporter::Declare::Export::Alias;
use strict;
use warnings;
use base 'Exporter::Declare::Export';
1;
=head1 NAME
Exporter::Declare::Export::Alias - Export class for aliases.
=head1 DESCRIPTION
Export class for aliases. Currently does not expand upon
L<Exporter::Declare::Export> in any way.
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE_EXPORT_ALIAS
$fatpacked{"Exporter/Declare/Export/Generator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE_EXPORT_GENERATOR';
package Exporter::Declare::Export::Generator;
use strict;
use warnings;
use base 'Exporter::Declare::Export::Sub';
use Exporter::Declare::Export::Variable;
use Carp qw/croak/;
sub required_specs {
my $self = shift;
return(
$self->SUPER::required_specs(),
qw/ type /,
);
}
sub type { shift->_data->{ type }}
sub new {
my $class = shift;
croak "Generators must be coderefs, not " . ref($_[0])
unless ref( $_[0] ) eq 'CODE';
$class->SUPER::new( @_ );
}
sub generate {
my $self = shift;
my ( $import_class, @args ) = @_;
my $ref = $self->( $self->exported_by, $import_class, @args );
return Exporter::Declare::Export::Sub->new(
$ref,
%{ $self->_data },
) if $self->type eq 'sub';
return Exporter::Declare::Export::Variable->new(
$ref,
%{ $self->_data },
) if $self->type eq 'variable';
return $self->type->new(
$ref,
%{ $self->_data },
);
}
sub inject {
my $self = shift;
my ( $class, $name, @args ) = @_;
$self->generate( $class, @args )->inject( $class, $name );
}
1;
=head1 NAME
Exporter::Declare::Export::Generator - Export class for exports that should be
generated when imported.
=head1 DESCRIPTION
Export class for exports that should be generated when imported.
=head1 OVERRIDEN METHODS
=over 4
=item $class->new( $ref, $ref, exported_by => $package, type => $type, %data )
You must specify the type as 'sub' or 'variable'.
=item $export->inject( $package, $name, @args )
Calls generate() with @args to create a generated export. The new export is
then injected.
=back
=head1 ADDITIONAL METHODS
=over 4
=item $new = $export->generate( $import_class, @args )
Generates a new export object.
=item $type = $export->type()
Returns the type of object to be generated (sub or variable)
=back
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE_EXPORT_GENERATOR
$fatpacked{"Exporter/Declare/Export/Sub.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE_EXPORT_SUB';
package Exporter::Declare::Export::Sub;
use strict;
use warnings;
use base 'Exporter::Declare::Export';
1;
=head1 NAME
Exporter::Declare::Export::Sub - Export class for subs which are exported.
=head1 DESCRIPTION
Currently does not do anything L<Exporter::Declare::Export> does not.
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE_EXPORT_SUB
$fatpacked{"Exporter/Declare/Export/Variable.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE_EXPORT_VARIABLE';
package Exporter::Declare::Export::Variable;
use strict;
use warnings;
use base 'Exporter::Declare::Export';
1;
=head1 NAME
Exporter::Declare::Export::Variable - Export class for variables which are
exported.
=head1 DESCRIPTION
Export class for variables which are exported. Currently does not expand upon
L<Exporter::Declare::Export> in any way.
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE_EXPORT_VARIABLE
$fatpacked{"Exporter/Declare/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE_META';
package Exporter::Declare::Meta;
use strict;
use warnings;
use Scalar::Util qw/blessed reftype/;
use Carp qw/croak/;
use aliased 'Exporter::Declare::Export::Sub';
use aliased 'Exporter::Declare::Export::Variable';
use aliased 'Exporter::Declare::Export::Alias';
use Meta::Builder;
accessor 'export_meta';
hash_metric exports => (
add => sub {
my $self = shift;
my ( $data, $metric, $action, $item, $ref ) = @_;
croak "Exports must be instances of 'Exporter::Declare::Export'"
unless blessed($ref) && $ref->isa('Exporter::Declare::Export');
my ( $type, $name ) = ( $item =~ m/^([\&\%\@\$])?(.*)$/ );
$type ||= '&';
my $fullname = "$type$name";
$self->default_hash_add( $data, $metric, $action, $fullname, $ref );
push @{$self->export_tags->{all}} => $fullname;
},
get => sub {
my $self = shift;
my ( $data, $metric, $action, $item ) = @_;
croak "exports_get() does not accept a tag as an argument"
if $item =~ m/^[:-]/;
my ( $type, $name ) = ( $item =~ m/^([\&\%\@\$])?(.*)$/ );
$type ||= '&';
my $fullname = "$type$name";
return $self->default_hash_get( $data, $metric, $action, $fullname )
|| croak $self->package . " does not export '$fullname'";
},
merge => sub {
my $self = shift;
my ( $data, $metric, $action, $merge ) = @_;
my $newmerge = {};
for my $item ( keys %$merge ) {
my $value = $merge->{$item};
next if $value->isa(Alias);
next if $data->{$item};
$newmerge->{$item} = $value;
}
$self->default_hash_merge( $data, $metric, $action, $newmerge );
}
);
hash_metric options => (
add => sub {
my $self = shift;
my ( $data, $metric, $action, $item ) = @_;
croak "'$item' is already a tag, you can't also make it an option."
if $self->export_tags_has($item);
croak "'$item' is already an argument, you can't also make it an option."
if $self->arguments_has($item);
$self->default_hash_add( $data, $metric, $action, $item, 1 );
},
);
hash_metric arguments => (
add => sub {
my $self = shift;
my ( $data, $metric, $action, $item ) = @_;
croak "'$item' is already a tag, you can't also make it an argument."
if $self->export_tags_has($item);
croak "'$item' is already an option, you can't also make it an argument."
if $self->options_has($item);
$self->default_hash_add( $data, $metric, $action, $item, 1 );
},
merge => sub {
my $self = shift;
my ( $data, $metric, $action, $merge ) = @_;
my $newmerge = {%$merge};
delete $newmerge->{suffix};
delete $newmerge->{prefix};
$self->default_hash_merge( $data, $metric, $action, $newmerge );
}
);
lists_metric export_tags => (
push => sub {
my $self = shift;
my ( $data, $metric, $action, $item, @args ) = @_;
croak "'$item' is a reserved tag, you cannot override it."
if $item eq 'all';
croak "'$item' is already an option, you can't also make it a tag."
if $self->options_has($item);
croak "'$item' is already an argument, you can't also make it a tag."
if $self->arguments_has($item);
$self->default_list_push( $data, $metric, $action, $item, @args );
},
merge => sub {
my $self = shift;
my ( $data, $metric, $action, $merge ) = @_;
my $newmerge = {};
my %aliases = (
map {
my ($name) = (m/^&?(.*)$/);
( $name => 1, "&$name" => 1 )
} @{$merge->{alias}}
);
for my $item ( keys %$merge ) {
my $values = $merge->{$item};
$newmerge->{$item} = [grep { !$aliases{$_} } @$values];
}
$self->default_list_merge( $data, $metric, $action, $newmerge );
}
);
sub new {
my $class = shift;
my $self = $class->SUPER::new(
@_,
export_tags => {all => [], default => [], alias => []},
arguments => {prefix => 1, suffix => 1},
);
$self->add_alias;
return $self;
}
sub new_from_exporter {
my $class = shift;
my ($exporter) = @_;
my $self = $class->new($exporter);
my %seen;
my ($exports) = $self->get_ref_from_package('@EXPORT');
my ($export_oks) = $self->get_ref_from_package('@EXPORT_OK');
my ($tags) = $self->get_ref_from_package('%EXPORT_TAGS');
$self->exports_add(@$_) for map {
my ( $ref, $name ) = $self->get_ref_from_package($_);
if ( $name =~ m/^\&/ ) {
Sub->new( $ref, exported_by => $exporter );
}
else {
Variable->new( $ref, exported_by => $exporter );
}
[$name, $ref];
} grep { !$seen{$_}++ } @$exports, @$export_oks;
$self->export_tags_push( 'default', @$exports )
if @$exports;
$self->export_tags_push( $_, $tags->{$_} ) for keys %$tags;
return $self;
}
sub add_alias {
my $self = shift;
my $package = $self->package;
my ($alias) = ( $package =~ m/([^:]+)$/ );
$self->exports_add( $alias, Alias->new( sub { $package }, exported_by => $package ) );
$self->export_tags_push( 'alias', $alias );
}
sub is_tag {
my $self = shift;
my ($name) = @_;
return exists $self->export_tags->{$name} ? 1 : 0;
}
sub is_argument {
my $self = shift;
my ($name) = @_;
return exists $self->arguments->{$name} ? 1 : 0;
}
sub is_option {
my $self = shift;
my ($name) = @_;
return exists $self->options->{$name} ? 1 : 0;
}
sub get_ref_from_package {
my $self = shift;
my ($item) = @_;
use Carp qw/confess/;
confess unless $item;
my ( $type, $name ) = ( $item =~ m/^([\&\@\%\$]?)(.*)$/ );
$type ||= '&';
my $fullname = "$type$name";
my $ref = $self->package . '::' . $name;
no strict 'refs';
return ( \&{$ref}, $fullname ) if !$type || $type eq '&';
return ( \${$ref}, $fullname ) if $type eq '$';
return ( \@{$ref}, $fullname ) if $type eq '@';
return ( \%{$ref}, $fullname ) if $type eq '%';
croak "'$item' cannot be exported";
}
sub reexport {
my $self = shift;
my ($exporter) = @_;
my $meta =
$exporter->can('export_meta')
? $exporter->export_meta()
: __PACKAGE__->new_from_exporter($exporter);
$self->merge($meta);
}
1;
=head1 NAME
Exporter::Declare::Meta - The mata object which stoes meta-data for all
exporters.
=head1 DESCRIPTION
All classes that use Exporter::Declare have an associated Meta object. Meta
objects track available exports, tags, and options.
=head1 METHODS
=over 4
=item $class->new( $package )
Created a meta object for the specified package. Also injects the export_meta()
sub into the package namespace that returns the generated meta object.
=item $class->new_from_exporter( $package )
Create a meta object for a package that already uses Exporter.pm. This will not
turn the class into an Exporter::Declare package, but it will create a meta
object and export_meta() method on it. This si primarily used for reexport
purposes.
=item $package = $meta->package()
Get the name of the package with which the meta object is associated.
=item $meta->add_alias()
Usually called at construction to add a package alias function to the exports.
=item $meta->add_export( $name, $ref )
Add an export, name should be the item name with sigil (assumed to be sub if
there is no sigil). $ref should be a ref blessed as an
L<Exporter::Declare::Export> subclass.
=item $meta->get_export( $name )
Retrieve the L<Exporter::Declare::Export> object by name. Name should be the
item name with sigil, assumed to be sub when sigil is missing.
=item $meta->export_tags_push( $name, @items )
Add @items to the specified tag. Tag will be created if it does not already
exist. $name should be the tag name B<WITHOUT> -/: prefix.
=item $bool = $meta->is_tag( $name )
Check if a tag with the given name exists. $name should be the tag name
B<WITHOUT> -/: prefix.
=item @list = $meta->get_tag( $name )
Get the list of items associated with the specified tag. $name should be the
tag name B<WITHOUT> -/: prefix.
=item $meta->add_options( @names )
Add import options by name. These will be boolean options that take no
arguments.
=item $meta->add_arguments( @names )
Add import options that slurp in the next argument as a value.
=item $bool = $meta->is_option( $name )
Check if the specifed name is an option.
=item $bool = $meta->is_argument( $name )
Check if the specifed name is an option that takes an argument.
=item $meta->add_parser( $name, sub { ... })
Add a parser sub that should be associated with exports via L<Devel::Declare>
=item $meta->get_parser( $name )
Get a parser by name.
=item $ref = $meta->get_ref_from_package( $item )
Returns a reference to a specific package variable or sub.
=item $meta->reexport( $package )
Re-export the exports in the provided package. Package may be an
L<Exporter::Declare> based package or an L<Exporter> based package.
=item $meta->merge( $meta2 )
Merge-in the exports and tags of the second meta object.
=back
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE_META
$fatpacked{"Exporter/Declare/Specs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_DECLARE_SPECS';
package Exporter::Declare::Specs;
use strict;
use warnings;
use Carp qw/croak/;
our @CARP_NOT = qw/Exporter::Declare/;
sub new {
my $class = shift;
my ( $package, @args ) = @_;
my $self = bless( [$package,{},{},[]], $class );
@args = (':default') unless @args;
$self->_process( "import list", @args );
return $self;
}
sub package { shift->[0] }
sub config { shift->[1] }
sub exports { shift->[2] }
sub excludes { shift->[3] }
sub export {
my $self = shift;
my ( $dest ) = @_;
for my $item ( keys %{ $self->exports }) {
my ( $export, $conf, $args ) = @{ $self->exports->{$item} };
my ( $sigil, $name ) = ( $item =~ m/^([\&\%\$\@])(.*)$/ );
$name = $conf->{as} || join(
'',
$conf->{prefix} || $self->config->{prefix} || '',
$name,
$conf->{suffix} || $self->config->{suffix} || '',
);
$export->inject( $dest, $name, @$args );
}
}
sub add_export {
my $self = shift;
my ( $name, $value, $config ) = @_;
my $type = ref $value eq 'CODE' ? 'Sub' : 'Variable';
"Exporter::Declare::Export::$type"->new( $value, exported_by => scalar caller() );
$self->exports->{$name} = [
$value,
$config || {},
[],
];
}
sub arguments {
my $self = shift;
my $meta = $self->package->export_meta;
return grep { $meta->is_argument($_) } keys %{$self->config};
}
sub options {
my $self = shift;
my $meta = $self->package->export_meta;
return grep { $meta->is_option($_) } keys %{$self->config};
}
sub tags {
my $self = shift;
my $meta = $self->package->export_meta;
return grep { $meta->is_tag($_) } keys %{$self->config};
}
sub _make_info {
my $self = shift;
my $config = $self->config;
return { map { $_, $config->{$_} } @_ };
}
sub argument_info {
my $self = shift;
return $self->_make_info($self->arguments);
}
sub option_info {
my $self = shift;
return $self->_make_info($self->options);
}
sub tag_info {
my $self = shift;
my $all_tags = $self->package->export_meta->export_tags;
return { map { $_, $all_tags->{$_} } $self->tags };
}
sub _process {
my $self = shift;
my ( $tag, @args ) = @_;
my $argnum = 0;
while ( my $item = shift( @args )) {
croak "not sure what to do with $item ($tag argument: $argnum)"
if ref $item;
$argnum++;
if ( $item =~ m/^(!?)[:-](.*)$/ ) {
my ( $neg, $param ) = ( $1, $2 );
if ( $self->package->export_meta->arguments_has( $param )) {
$self->config->{$param} = shift( @args );
$argnum++;
next;
}
else {
$self->config->{$param} = ref( $args[0] ) ? $args[0] : !$neg;
}
}
if ( $item =~ m/^!(.*)$/ ) {
$self->_exclude_item( $1 )
}
elsif ( my $type = ref( $args[0] )) {
my $arg = shift( @args );
$argnum++;
if ( $type eq 'ARRAY' ) {
$self->_include_item( $item, undef, $arg );
}
elsif ( $type eq 'HASH' ) {
$self->_include_item( $item, $arg, undef );
}
else {
croak "Not sure what to do with $item => $arg ($tag arguments: "
. ($argnum - 1) . " and $argnum)";
}
}
else {
$self->_include_item( $item )
}
}
delete $self->exports->{$_} for @{ $self->excludes };
}
sub _item_name { my $in = shift; $in =~ m/^[\&\$\%\@]/ ? $in : "\&$in" }
sub _exclude_item {
my $self = shift;
my ( $item ) = @_;
if ( $item =~ m/^[:-](.*)$/ ) {
$self->_exclude_item( $_ )
for $self->_export_tags_get( $1 );
return;
}
push @{ $self->excludes } => _item_name($item);
}
sub _include_item {
my $self = shift;
my ( $item, $conf, $args ) = @_;
$conf ||= {};
$args ||= [];
use Carp qw/confess/;
confess $item if $item =~ m/^&?aaa_/;
push @$args => @{ delete $conf->{'-args'} }
if defined $conf->{'-args'};
for my $key ( keys %$conf ) {
next if $key =~ m/^[:-]/;
push @$args => ( $key, delete $conf->{$key} );
}
if ( $item =~ m/^[:-](.*)$/ ) {
my $name = $1;
return if $self->package->export_meta->options_has( $name );
for my $tagitem ( $self->_export_tags_get( $name ) ) {
my ( $negate, $name ) = ( $tagitem =~ m/^(!)?(.*)$/ );
if ( $negate ) {
$self->_exclude_item( $name );
}
else {
$self->_include_item( $tagitem, $conf, $args );
}
}
return;
}
$item = _item_name($item);
my $existing = $self->exports->{ $item };
unless ( $existing ) {
$existing = [ $self->_get_item( $item ), {}, []];
$self->exports->{ $item } = $existing;
}
push @{ $existing->[2] } => @$args;
for my $param ( keys %$conf ) {
my ( $name ) = ( $param =~ m/^[-:](.*)$/ );
$existing->[1]->{$name} = $conf->{$param};
}
}
sub _get_item {
my $self = shift;
my ( $name ) = @_;
$self->package->export_meta->exports_get( $name );
}
sub _export_tags_get {
my $self = shift;
my ( $name ) = @_;
$self->package->export_meta->export_tags_get( $name );
}
1;
=head1 NAME
Exporter::Declare::Specs - Import argument parser for Exporter::Declare
=head1 DESCRIPTION
Import arguments cna get complicated. All arguments are assumed to be exports
unless they have a - or : prefix. The prefix may denote a tag, a boolean
option, or an option that takes the next argument as a value. In addition
almost all these can be negated with the ! prefix.
This class takes care of parsing the import arguments and generating data
structures that can be used to find what the exporter needs to know.
=head1 METHODS
=over 4
=item $class->new( $package, @args )
Create a new instance and parse @args.
=item $specs->package()
Get the name of the package that should do the exporting.
=item $hashref = $specs->config()
Get the configuration hash, All specified options and tags are the keys. The
value will be true/false/undef for tags/boolean options. For options that take
arguments the value will be that argument. When a config hash is provided to a
tag it will be the value.
=item @names = $specs->arguments()
=item @names = $specs->options()
=item @names = $specs->tags()
Get the argument, option, or tag names that were specified for the import.
=item $hashref = $specs->argument_info()
Get the arguments that were specified for the import. The key is the name of the
argument and the value is what the user supplied during import.
=item $hashref = $specs->option_info()
Get the options that were specified for the import. The key is the name of the user
supplied option and the value will evaluate to true.
=item $hashref = $specs->tag_info()
Get the values associated with the tags used during import. The key is the name of the tag
and the value is an array ref containing the values given to export_tag() for the associated
name.
=item $hashref = $specs->exports()
Get the exports hash. The keys are names of the exports. Values are an array
containing the export, item specific config hash, and arguments array. This is
generally not intended for direct consumption.
=item $arrayref = $specs->excludes()
Get the arrayref containing the names of all excluded exports.
=item $specs->export( $package )
Do the actual exporting. All exports will be injected into $package.
=item $specs->add_export( $name, $value )
=item $specs->add_export( $name, $value, \%config )
Add an export. Name is required, including sigil. Value is required, if it is a
sub it will be blessed as a ::Sub, otherwise blessed as a ::Variable.
$specs->add_export( '&foo' => sub { return 'foo' });
=back
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Exporter-Declare is free software; Standard perl licence.
Exporter-Declare is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the license for more details.
EXPORTER_DECLARE_SPECS
$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
package JSON::PP;
# JSON-2.0
use 5.005;
use strict;
use base qw(Exporter);
use overload ();
use Carp ();
use B ();
#use Devel::Peek;
$JSON::PP::VERSION = '2.27203';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
# instead of hash-access, i tried index-access for speed.
# but this method is not faster than what i expected. so it will be changed.
use constant P_ASCII => 0;
use constant P_LATIN1 => 1;
use constant P_UTF8 => 2;
use constant P_INDENT => 3;
use constant P_CANONICAL => 4;
use constant P_SPACE_BEFORE => 5;
use constant P_SPACE_AFTER => 6;
use constant P_ALLOW_NONREF => 7;
use constant P_SHRINK => 8;
use constant P_ALLOW_BLESSED => 9;
use constant P_CONVERT_BLESSED => 10;
use constant P_RELAXED => 11;
use constant P_LOOSE => 12;
use constant P_ALLOW_BIGNUM => 13;
use constant P_ALLOW_BAREKEY => 14;
use constant P_ALLOW_SINGLEQUOTE => 15;
use constant P_ESCAPE_SLASH => 16;
use constant P_AS_NONBLESSED => 17;
use constant P_ALLOW_UNKNOWN => 18;
use constant OLD_PERL => $] < 5.008 ? 1 : 0;
BEGIN {
my @xs_compati_bit_properties = qw(
latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
allow_blessed convert_blessed relaxed allow_unknown
);
my @pp_bit_properties = qw(
allow_singlequote allow_bignum loose
allow_barekey escape_slash as_nonblessed
);
# Perl version check, Unicode handling is enable?
# Helper module sets @JSON::PP::_properties.
if ($] < 5.008 ) {
my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
eval qq| require $helper |;
if ($@) { Carp::croak $@; }
}
for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
my $flag_name = 'P_' . uc($name);
eval qq/
sub $name {
my \$enable = defined \$_[1] ? \$_[1] : 1;
if (\$enable) {
\$_[0]->{PROPS}->[$flag_name] = 1;
}
else {
\$_[0]->{PROPS}->[$flag_name] = 0;
}
\$_[0];
}
sub get_$name {
\$_[0]->{PROPS}->[$flag_name] ? 1 : '';
}
/;
}
}
# Functions
my %encode_allow_method
= map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
allow_blessed convert_blessed indent indent_length allow_bignum
as_nonblessed
/;
my %decode_allow_method
= map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
allow_barekey max_size relaxed/;
my $JSON; # cache
sub encode_json ($) { # encode
($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
}
sub decode_json { # decode
($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
}
# Obsoleted
sub to_json($) {
Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
}
sub from_json($) {
Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
}
# Methods
sub new {
my $class = shift;
my $self = {
max_depth => 512,
max_size => 0,
indent => 0,
FLAGS => 0,
fallback => sub { encode_error('Invalid value. JSON can only reference.') },
indent_length => 3,
};
bless $self, $class;
}
sub encode {
return $_[0]->PP_encode_json($_[1]);
}
sub decode {
return $_[0]->PP_decode_json($_[1], 0x00000000);
}
sub decode_prefix {
return $_[0]->PP_decode_json($_[1], 0x00000001);
}
# accessor
# pretty printing
sub pretty {
my ($self, $v) = @_;
my $enable = defined $v ? $v : 1;
if ($enable) { # indent_length(3) for JSON::XS compatibility
$self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
}
else {
$self->indent(0)->space_before(0)->space_after(0);
}
$self;
}
# etc
sub max_depth {
my $max = defined $_[1] ? $_[1] : 0x80000000;
$_[0]->{max_depth} = $max;
$_[0];
}
sub get_max_depth { $_[0]->{max_depth}; }
sub max_size {
my $max = defined $_[1] ? $_[1] : 0;
$_[0]->{max_size} = $max;
$_[0];
}
sub get_max_size { $_[0]->{max_size}; }
sub filter_json_object {
$_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub filter_json_single_key_object {
if (@_ > 1) {
$_[0]->{cb_sk_object}->{$_[1]} = $_[2];
}
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
$_[0];
}
sub indent_length {
if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
Carp::carp "The acceptable range of indent_length() is 0 to 15.";
}
else {
$_[0]->{indent_length} = $_[1];
}
$_[0];
}
sub get_indent_length {
$_[0]->{indent_length};
}
sub sort_by {
$_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
$_[0];
}
sub allow_bigint {
Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
}
###############################
###
### Perl => JSON
###
{ # Convert
my $max_depth;
my $indent;
my $ascii;
my $latin1;
my $utf8;
my $space_before;
my $space_after;
my $canonical;
my $allow_blessed;
my $convert_blessed;
my $indent_length;
my $escape_slash;
my $bignum;
my $as_nonblessed;
my $depth;
my $indent_count;
my $keysort;
sub PP_encode_json {
my $self = shift;
my $obj = shift;
$indent_count = 0;
$depth = 0;
my $idx = $self->{PROPS};
($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
$convert_blessed, $escape_slash, $bignum, $as_nonblessed)
= @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
$keysort = $canonical ? sub { $a cmp $b } : undef;
if ($self->{sort_by}) {
$keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
: $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
: sub { $a cmp $b };
}
encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
my $str = $self->object_to_json($obj);
$str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
unless ($ascii or $latin1 or $utf8) {
utf8::upgrade($str);
}
if ($idx->[ P_SHRINK ]) {
utf8::downgrade($str, 1);
}
return $str;
}
sub object_to_json {
my ($self, $obj) = @_;
my $type = ref($obj);
if($type eq 'HASH'){
return $self->hash_to_json($obj);
}
elsif($type eq 'ARRAY'){
return $self->array_to_json($obj);
}
elsif ($type) { # blessed object?
if (blessed($obj)) {
return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
if ( $convert_blessed and $obj->can('TO_JSON') ) {
my $result = $obj->TO_JSON();
if ( defined $result and ref( $result ) ) {
if ( refaddr( $obj ) eq refaddr( $result ) ) {
encode_error( sprintf(
"%s::TO_JSON method returned same object as was passed instead of a new one",
ref $obj
) );
}
}
return $self->object_to_json( $result );
}
return "$obj" if ( $bignum and _is_bignum($obj) );
return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
encode_error( sprintf("encountered object '%s', but neither allow_blessed "
. "nor convert_blessed settings are enabled", $obj)
) unless ($allow_blessed);
return 'null';
}
else {
return $self->value_to_json($obj);
}
}
else{
return $self->value_to_json($obj);
}
}
sub hash_to_json {
my ($self, $obj) = @_;
my @res;
encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
if (++$depth > $max_depth);
my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
for my $k ( _sort( $obj ) ) {
if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
push @res, string_to_json( $self, $k )
. $del
. ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
}
--$depth;
$self->_down_indent() if ($indent);
return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}';
}
sub array_to_json {
my ($self, $obj) = @_;
my @res;
encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
if (++$depth > $max_depth);
my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
for my $v (@$obj){
push @res, $self->object_to_json($v) || $self->value_to_json($v);
}
--$depth;
$self->_down_indent() if ($indent);
return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
}
sub value_to_json {
my ($self, $value) = @_;
return 'null' if(!defined $value);
my $b_obj = B::svref_2object(\$value); # for round trip problem
my $flags = $b_obj->FLAGS;
return $value # as is
if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
my $type = ref($value);
if(!$type){
return string_to_json($self, $value);
}
elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
return $$value == 1 ? 'true' : 'false';
}
elsif ($type) {
if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
return $self->value_to_json("$value");
}
if ($type eq 'SCALAR' and defined $$value) {
return $$value eq '1' ? 'true'
: $$value eq '0' ? 'false'
: $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
: encode_error("cannot encode reference to scalar");
}
if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
return 'null';
}
else {
if ( $type eq 'SCALAR' or $type eq 'REF' ) {
encode_error("cannot encode reference to scalar");
}
else {
encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
}
}
}
else {
return $self->{fallback}->($value)
if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
return 'null';
}
}
my %esc = (
"\n" => '\n',
"\r" => '\r',
"\t" => '\t',
"\f" => '\f',
"\b" => '\b',
"\"" => '\"',
"\\" => '\\\\',
"\'" => '\\\'',
);
sub string_to_json {
my ($self, $arg) = @_;
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/\//\\\//g if ($escape_slash);
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
if ($ascii) {
$arg = JSON_PP_encode_ascii($arg);
}
if ($latin1) {
$arg = JSON_PP_encode_latin1($arg);
}
if ($utf8) {
utf8::encode($arg);
}
return '"' . $arg . '"';
}
sub blessed_to_json {
my $reftype = reftype($_[1]) || '';
if ($reftype eq 'HASH') {
return $_[0]->hash_to_json($_[1]);
}
elsif ($reftype eq 'ARRAY') {
return $_[0]->array_to_json($_[1]);
}
else {
return 'null';
}
}
sub encode_error {
my $error = shift;
Carp::croak "$error";
}
sub _sort {
defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
}
sub _up_indent {
my $self = shift;
my $space = ' ' x $indent_length;
my ($pre,$post) = ('','');
$post = "\n" . $space x $indent_count;
$indent_count++;
$pre = "\n" . $space x $indent_count;
return ($pre,$post);
}
sub _down_indent { $indent_count--; }
sub PP_encode_box {
{
depth => $depth,
indent_count => $indent_count,
};
}
} # Convert
sub _encode_ascii {
join('',
map {
$_ <= 127 ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
} unpack('U*', $_[0])
);
}
sub _encode_latin1 {
join('',
map {
$_ <= 255 ?
chr($_) :
$_ <= 65535 ?
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
} unpack('U*', $_[0])
);
}
sub _encode_surrogates { # from perlunicode
my $uni = $_[0] - 0x10000;
return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
}
sub _is_bignum {
$_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
}
#
# JSON => Perl
#
my $max_intsize;
BEGIN {
my $checkint = 1111;
for my $d (5..64) {
$checkint .= 1;
my $int = eval qq| $checkint |;
if ($int =~ /[eE]/) {
$max_intsize = $d - 1;
last;
}
}
}
{ # PARSE
my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
b => "\x8",
t => "\x9",
n => "\xA",
f => "\xC",
r => "\xD",
'\\' => '\\',
'"' => '"',
'/' => '/',
);
my $text; # json data
my $at; # offset
my $ch; # 1chracter
my $len; # text length (changed according to UTF8 or NON UTF8)
# INTERNAL
my $depth; # nest counter
my $encoding; # json text encoding
my $is_valid_utf8; # temp variable
my $utf8_len; # utf8 byte length
# FLAGS
my $utf8; # must be utf8
my $max_depth; # max nest nubmer of objects and arrays
my $max_size;
my $relaxed;
my $cb_object;
my $cb_sk_object;
my $F_HOOK;
my $allow_bigint; # using Math::BigInt
my $singlequote; # loosely quoting
my $loose; #
my $allow_barekey; # bareKey
# $opt flag
# 0x00000001 .... decode_prefix
# 0x10000000 .... incr_parse
sub PP_decode_json {
my ($self, $opt); # $opt is an effective flag during this decode_json.
($self, $text, $opt) = @_;
($at, $ch, $depth) = (0, '', 0);
if ( !defined $text or ref $text ) {
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
my $idx = $self->{PROPS};
($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
= @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
if ( $utf8 ) {
utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
}
else {
utf8::upgrade( $text );
}
$len = length $text;
($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
= @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
if ($max_size > 1) {
use bytes;
my $bytes = length $text;
decode_error(
sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
, $bytes, $max_size), 1
) if ($bytes > $max_size);
}
# Currently no effect
# should use regexp
my @octets = unpack('C4', $text);
$encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
: (!$octets[0] and $octets[1]) ? 'UTF-16BE'
: (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
: ( $octets[2] ) ? 'UTF-16LE'
: (!$octets[2] ) ? 'UTF-32LE'
: 'unknown';
white(); # remove head white space
my $valid_start = defined $ch; # Is there a first character for JSON structure?
my $result = value();
return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
decode_error(
'JSON text must be an object or array (but found number, string, true, false or null,'
. ' use allow_nonref to allow this)', 1);
}
Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
white(); # remove tail white space
if ( $ch ) {
return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
decode_error("garbage after JSON object");
}
( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
}
sub next_chr {
return $ch = undef if($at >= $len);
$ch = substr($text, $at++, 1);
}
sub value {
white();
return if(!defined $ch);
return object() if($ch eq '{');
return array() if($ch eq '[');
return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
return number() if($ch =~ /[0-9]/ or $ch eq '-');
return word();
}
sub string {
my ($i, $s, $t, $u);
my $utf16;
my $is_utf8;
($is_valid_utf8, $utf8_len) = ('', 0);
$s = ''; # basically UTF8 flag on
if($ch eq '"' or ($singlequote and $ch eq "'")){
my $boundChar = $ch;
OUTER: while( defined(next_chr()) ){
if($ch eq $boundChar){
next_chr();
if ($utf16) {
decode_error("missing low surrogate character in surrogate pair");
}
utf8::decode($s) if($is_utf8);
return $s;
}
elsif($ch eq '\\'){
next_chr();
if(exists $escapes{$ch}){
$s .= $escapes{$ch};
}
elsif($ch eq 'u'){ # UNICODE handling
my $u = '';
for(1..4){
$ch = next_chr();
last OUTER if($ch !~ /[0-9a-fA-F]/);
$u .= $ch;
}
# U+D800 - U+DBFF
if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
$utf16 = $u;
}
# U+DC00 - U+DFFF
elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
unless (defined $utf16) {
decode_error("missing high surrogate character in surrogate pair");
}
$is_utf8 = 1;
$s .= JSON_PP_decode_surrogates($utf16, $u) || next;
$utf16 = undef;
}
else {
if (defined $utf16) {
decode_error("surrogate pair expected");
}
if ( ( my $hex = hex( $u ) ) > 127 ) {
$is_utf8 = 1;
$s .= JSON_PP_decode_unicode($u) || next;
}
else {
$s .= chr $hex;
}
}
}
else{
unless ($loose) {
$at -= 2;
decode_error('illegal backslash escape sequence in string');
}
$s .= $ch;
}
}
else{
if ( ord $ch > 127 ) {
if ( $utf8 ) {
unless( $ch = is_valid_utf8($ch) ) {
$at -= 1;
decode_error("malformed UTF-8 character in JSON string");
}
else {
$at += $utf8_len - 1;
}
}
else {
utf8::encode( $ch );
}
$is_utf8 = 1;
}
if (!$loose) {
if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
$at--;
decode_error('invalid character encountered while parsing JSON string');
}
}
$s .= $ch;
}
}
}
decode_error("unexpected end of string while parsing JSON string");
}
sub white {
while( defined $ch ){
if($ch le ' '){
next_chr();
}
elsif($ch eq '/'){
next_chr();
if(defined $ch and $ch eq '/'){
1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
}
elsif(defined $ch and $ch eq '*'){
next_chr();
while(1){
if(defined $ch){
if($ch eq '*'){
if(defined(next_chr()) and $ch eq '/'){
next_chr();
last;
}
}
else{
next_chr();
}
}
else{
decode_error("Unterminated comment");
}
}
next;
}
else{
$at--;
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
}
else{
if ($relaxed and $ch eq '#') { # correctly?
pos($text) = $at;
$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
$at = pos($text);
next_chr;
next;
}
last;
}
}
}
sub array {
my $a = $_[0] || []; # you can use this code to use another array ref object.
decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
if (++$depth > $max_depth);
next_chr();
white();
if(defined $ch and $ch eq ']'){
--$depth;
next_chr();
return $a;
}
else {
while(defined($ch)){
push @$a, value();
white();
if (!defined $ch) {
last;
}
if($ch eq ']'){
--$depth;
next_chr();
return $a;
}
if($ch ne ','){
last;
}
next_chr();
white();
if ($relaxed and $ch eq ']') {
--$depth;
next_chr();
return $a;
}
}
}
decode_error(", or ] expected while parsing array");
}
sub object {
my $o = $_[0] || {}; # you can use this code to use another hash ref object.
my $k;
decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
if (++$depth > $max_depth);
next_chr();
white();
if(defined $ch and $ch eq '}'){
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
else {
while (defined $ch) {
$k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
white();
if(!defined $ch or $ch ne ':'){
$at--;
decode_error("':' expected");
}
next_chr();
$o->{$k} = value();
white();
last if (!defined $ch);
if($ch eq '}'){
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
if($ch ne ','){
last;
}
next_chr();
white();
if ($relaxed and $ch eq '}') {
--$depth;
next_chr();
if ($F_HOOK) {
return _json_object_hook($o);
}
return $o;
}
}
}
$at--;
decode_error(", or } expected while parsing object/hash");
}
sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
my $key;
while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
$key .= $ch;
next_chr();
}
return $key;
}
sub word {
my $word = substr($text,$at-1,4);
if($word eq 'true'){
$at += 3;
next_chr;
return $JSON::PP::true;
}
elsif($word eq 'null'){
$at += 3;
next_chr;
return undef;
}
elsif($word eq 'fals'){
$at += 3;
if(substr($text,$at,1) eq 'e'){
$at++;
next_chr;
return $JSON::PP::false;
}
}
$at--; # for decode_error report
decode_error("'null' expected") if ($word =~ /^n/);
decode_error("'true' expected") if ($word =~ /^t/);
decode_error("'false' expected") if ($word =~ /^f/);
decode_error("malformed JSON string, neither array, object, number, string or atom");
}
sub number {
my $n = '';
my $v;
# According to RFC4627, hex or oct digts are invalid.
if($ch eq '0'){
my $peek = substr($text,$at,1);
my $hex = $peek =~ /[xX]/; # 0 or 1
if($hex){
decode_error("malformed number (leading zero must not be followed by another digit)");
($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
}
else{ # oct
($n) = ( substr($text, $at) =~ /^([0-7]+)/);
if (defined $n and length $n > 1) {
decode_error("malformed number (leading zero must not be followed by another digit)");
}
}
if(defined $n and length($n)){
if (!$hex and length($n) == 1) {
decode_error("malformed number (leading zero must not be followed by another digit)");
}
$at += length($n) + $hex;
next_chr;
return $hex ? hex($n) : oct($n);
}
}
if($ch eq '-'){
$n = '-';
next_chr;
if (!defined $ch or $ch !~ /\d/) {
decode_error("malformed number (no digits after initial minus)");
}
}
while(defined $ch and $ch =~ /\d/){
$n .= $ch;
next_chr;
}
if(defined $ch and $ch eq '.'){
$n .= '.';
next_chr;
if (!defined $ch or $ch !~ /\d/) {
decode_error("malformed number (no digits after decimal point)");
}
else {
$n .= $ch;
}
while(defined(next_chr) and $ch =~ /\d/){
$n .= $ch;
}
}
if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
$n .= $ch;
next_chr;
if(defined($ch) and ($ch eq '+' or $ch eq '-')){
$n .= $ch;
next_chr;
if (!defined $ch or $ch =~ /\D/) {
decode_error("malformed number (no digits after exp sign)");
}
$n .= $ch;
}
elsif(defined($ch) and $ch =~ /\d/){
$n .= $ch;
}
else {
decode_error("malformed number (no digits after exp sign)");
}
while(defined(next_chr) and $ch =~ /\d/){
$n .= $ch;
}
}
$v .= $n;
if ($v !~ /[.eE]/ and length $v > $max_intsize) {
if ($allow_bigint) { # from Adam Sussman
require Math::BigInt;
return Math::BigInt->new($v);
}
else {
return "$v";
}
}
elsif ($allow_bigint) {
require Math::BigFloat;
return Math::BigFloat->new($v);
}
return 0+$v;
}
sub is_valid_utf8 {
$utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
: $_[0] =~ /[\xC2-\xDF]/ ? 2
: $_[0] =~ /[\xE0-\xEF]/ ? 3
: $_[0] =~ /[\xF0-\xF4]/ ? 4
: 0
;
return unless $utf8_len;
my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
return ( $is_valid_utf8 =~ /^(?:
[\x00-\x7F]
|[\xC2-\xDF][\x80-\xBF]
|[\xE0][\xA0-\xBF][\x80-\xBF]
|[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
|[\xED][\x80-\x9F][\x80-\xBF]
|[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
)$/x ) ? $is_valid_utf8 : '';
}
sub decode_error {
my $error = shift;
my $no_rep = shift;
my $str = defined $text ? substr($text, $at) : '';
my $mess = '';
my $type = $] >= 5.008 ? 'U*'
: $] < 5.006 ? 'C*'
: utf8::is_utf8( $str ) ? 'U*' # 5.6
: 'C*'
;
for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
$mess .= $c == 0x07 ? '\a'
: $c == 0x09 ? '\t'
: $c == 0x0a ? '\n'
: $c == 0x0d ? '\r'
: $c == 0x0c ? '\f'
: $c < 0x20 ? sprintf('\x{%x}', $c)
: $c == 0x5c ? '\\\\'
: $c < 0x80 ? chr($c)
: sprintf('\x{%x}', $c)
;
if ( length $mess >= 20 ) {
$mess .= '...';
last;
}
}
unless ( length $mess ) {
$mess = '(end of string)';
}
Carp::croak (
$no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
);
}
sub _json_object_hook {
my $o = $_[0];
my @ks = keys %{$o};
if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
if (@val == 1) {
return $val[0];
}
}
my @val = $cb_object->($o) if ($cb_object);
if (@val == 0 or @val > 1) {
return $o;
}
else {
return $val[0];
}
}
sub PP_decode_box {
{
text => $text,
at => $at,
ch => $ch,
len => $len,
depth => $depth,
encoding => $encoding,
is_valid_utf8 => $is_valid_utf8,
};
}
} # PARSE
sub _decode_surrogates { # from perlunicode
my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
my $un = pack('U*', $uni);
utf8::encode( $un );
return $un;
}
sub _decode_unicode {
my $un = pack('U', hex shift);
utf8::encode( $un );
return $un;
}
#
# Setup for various Perl versions (the code from JSON::PP58)
#
BEGIN {
unless ( defined &utf8::is_utf8 ) {
require Encode;
*utf8::is_utf8 = *Encode::is_utf8;
}
if ( $] >= 5.008 ) {
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
*JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
*JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
}
if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
package JSON::PP;
require subs;
subs->import('join');
eval q|
sub join {
return '' if (@_ < 2);
my $j = shift;
my $str = shift;
for (@_) { $str .= $j . $_; }
return $str;
}
|;
}
sub JSON::PP::incr_parse {
local $Carp::CarpLevel = 1;
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
}
sub JSON::PP::incr_skip {
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
}
sub JSON::PP::incr_reset {
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
}
eval q{
sub JSON::PP::incr_text : lvalue {
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
}
$_[0]->{_incr_parser}->{incr_text};
}
} if ( $] >= 5.006 );
} # Setup for various Perl versions (the code from JSON::PP58)
###############################
# Utilities
#
BEGIN {
eval 'require Scalar::Util';
unless($@){
*JSON::PP::blessed = \&Scalar::Util::blessed;
*JSON::PP::reftype = \&Scalar::Util::reftype;
*JSON::PP::refaddr = \&Scalar::Util::refaddr;
}
else{ # This code is from Sclar::Util.
# warn $@;
eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
*JSON::PP::blessed = sub {
local($@, $SIG{__DIE__}, $SIG{__WARN__});
ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
};
my %tmap = qw(
B::NULL SCALAR
B::HV HASH
B::AV ARRAY
B::CV CODE
B::IO IO
B::GV GLOB
B::REGEXP REGEXP
);
*JSON::PP::reftype = sub {
my $r = shift;
return undef unless length(ref($r));
my $t = ref(B::svref_2object($r));
return
exists $tmap{$t} ? $tmap{$t}
: length(ref($$r)) ? 'REF'
: 'SCALAR';
};
*JSON::PP::refaddr = sub {
return undef unless length(ref($_[0]));
my $addr;
if(defined(my $pkg = blessed($_[0]))) {
$addr .= bless $_[0], 'Scalar::Util::Fake';
bless $_[0], $pkg;
}
else {
$addr .= $_[0]
}
$addr =~ /0x(\w+)/;
local $^W;
#no warnings 'portable';
hex($1);
}
}
}
# shamely copied and modified from JSON::XS code.
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
sub true { $JSON::PP::true }
sub false { $JSON::PP::false }
sub null { undef; }
###############################
package JSON::PP::Boolean;
use overload (
"0+" => sub { ${$_[0]} },
"++" => sub { $_[0] = ${$_[0]} + 1 },
"--" => sub { $_[0] = ${$_[0]} - 1 },
fallback => 1,
);
###############################
package JSON::PP::IncrParser;
use strict;
use constant INCR_M_WS => 0; # initial whitespace skipping
use constant INCR_M_STR => 1; # inside string
use constant INCR_M_BS => 2; # inside backslash
use constant INCR_M_JSON => 3; # outside anything, count nesting
use constant INCR_M_C0 => 4;
use constant INCR_M_C1 => 5;
$JSON::PP::IncrParser::VERSION = '1.01';
my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
sub new {
my ( $class ) = @_;
bless {
incr_nest => 0,
incr_text => undef,
incr_parsing => 0,
incr_p => 0,
}, $class;
}
sub incr_parse {
my ( $self, $coder, $text ) = @_;
$self->{incr_text} = '' unless ( defined $self->{incr_text} );
if ( defined $text ) {
if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
utf8::upgrade( $self->{incr_text} ) ;
utf8::decode( $self->{incr_text} ) ;
}
$self->{incr_text} .= $text;
}
my $max_size = $coder->get_max_size;
if ( defined wantarray ) {
$self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
if ( wantarray ) {
my @ret;
$self->{incr_parsing} = 1;
do {
push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
$self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
}
} until ( length $self->{incr_text} >= $self->{incr_p} );
$self->{incr_parsing} = 0;
return @ret;
}
else { # in scalar context
$self->{incr_parsing} = 1;
my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
$self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
}
}
}
sub _incr_parse {
my ( $self, $coder, $text, $skip ) = @_;
my $p = $self->{incr_p};
my $restore = $p;
my @obj;
my $len = length $text;
if ( $self->{incr_mode} == INCR_M_WS ) {
while ( $len > $p ) {
my $s = substr( $text, $p, 1 );
$p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
$self->{incr_mode} = INCR_M_JSON;
last;
}
}
while ( $len > $p ) {
my $s = substr( $text, $p++, 1 );
if ( $s eq '"' ) {
if (substr( $text, $p - 2, 1 ) eq '\\' ) {
next;
}
if ( $self->{incr_mode} != INCR_M_STR ) {
$self->{incr_mode} = INCR_M_STR;
}
else {
$self->{incr_mode} = INCR_M_JSON;
unless ( $self->{incr_nest} ) {
last;
}
}
}
if ( $self->{incr_mode} == INCR_M_JSON ) {
if ( $s eq '[' or $s eq '{' ) {
if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
}
}
elsif ( $s eq ']' or $s eq '}' ) {
last if ( --$self->{incr_nest} <= 0 );
}
elsif ( $s eq '#' ) {
while ( $len > $p ) {
last if substr( $text, $p++, 1 ) eq "\n";
}
}
}
}
$self->{incr_p} = $p;
return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
local $Carp::CarpLevel = 2;
$self->{incr_p} = $restore;
$self->{incr_c} = $p;
my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
$self->{incr_text} = substr( $self->{incr_text}, $p );
$self->{incr_p} = 0;
return $obj || '';
}
sub incr_text {
if ( $_[0]->{incr_parsing} ) {
Carp::croak("incr_text can not be called when the incremental parser already started parsing");
}
$_[0]->{incr_text};
}
sub incr_skip {
my $self = shift;
$self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
$self->{incr_p} = 0;
}
sub incr_reset {
my $self = shift;
$self->{incr_text} = undef;
$self->{incr_p} = 0;
$self->{incr_mode} = 0;
$self->{incr_nest} = 0;
$self->{incr_parsing} = 0;
}
###############################
1;
__END__
=pod
=head1 NAME
JSON::PP - JSON::XS compatible pure-Perl module.
=head1 SYNOPSIS
use JSON::PP;
# exported functions, they croak on error
# and expect/generate UTF-8
$utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
$perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
# OO-interface
$coder = JSON::PP->new->ascii->pretty->allow_nonref;
$json_text = $json->encode( $perl_scalar );
$perl_scalar = $json->decode( $json_text );
$pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing
# Note that JSON version 2.0 and above will automatically use
# JSON::XS or JSON::PP, so you should be able to just:
use JSON;
=head1 VERSION
2.27202
L<JSON::XS> 2.27 (~2.30) compatible.
=head1 NOTE
JSON::PP had been inculded in JSON distribution (CPAN module).
It was a perl core module in Perl 5.14.
=head1 DESCRIPTION
This module is L<JSON::XS> compatible pure Perl module.
(Perl 5.8 or later is recommended)
JSON::XS is the fastest and most proper JSON module on CPAN.
It is written by Marc Lehmann in C, so must be compiled and
installed in the used environment.
JSON::PP is a pure-Perl module and has compatibility to JSON::XS.
=head2 FEATURES
=over
=item * correct unicode handling
This module knows how to handle Unicode (depending on Perl version).
See to L<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
=item * round-trip integrity
When you serialise a perl data structure using only data types supported
by JSON and Perl, the deserialised data structure is identical on the Perl
level. (e.g. the string "2.0" doesn't suddenly become "2" just because
it looks like a number). There I<are> minor exceptions to this, read the
MAPPING section below to learn about those.
=item * strict checking of JSON correctness
There is no guessing, no generating of illegal JSON texts by default,
and only JSON is accepted as input by default (the latter is a security feature).
But when some options are set, loose chcking features are available.
=back
=head1 FUNCTIONAL INTERFACE
Some documents are copied and modified from L<JSON::XS/FUNCTIONAL INTERFACE>.
=head2 encode_json
$json_text = encode_json $perl_scalar
Converts the given Perl data structure to a UTF-8 encoded, binary string.
This function call is functionally identical to:
$json_text = JSON::PP->new->utf8->encode($perl_scalar)
=head2 decode_json
$perl_scalar = decode_json $json_text
The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
to parse that as an UTF-8 encoded JSON text, returning the resulting
reference.
This function call is functionally identical to:
$perl_scalar = JSON::PP->new->utf8->decode($json_text)
=head2 JSON::PP::is_bool
$is_boolean = JSON::PP::is_bool($scalar)
Returns true if the passed scalar represents either JSON::PP::true or
JSON::PP::false, two constants that act like C<1> and C<0> respectively
and are also used to represent JSON C<true> and C<false> in Perl strings.
=head2 JSON::PP::true
Returns JSON true value which is blessed object.
It C<isa> JSON::PP::Boolean object.
=head2 JSON::PP::false
Returns JSON false value which is blessed object.
It C<isa> JSON::PP::Boolean object.
=head2 JSON::PP::null
Returns C<undef>.
See L<MAPPING>, below, for more information on how JSON values are mapped to
Perl.
=head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER
This section supposes that your perl vresion is 5.8 or later.
If you know a JSON text from an outer world - a network, a file content, and so on,
is encoded in UTF-8, you should use C<decode_json> or C<JSON> module object
with C<utf8> enable. And the decoded result will contain UNICODE characters.
# from network
my $json = JSON::PP->new->utf8;
my $json_text = CGI->new->param( 'json_data' );
my $perl_scalar = $json->decode( $json_text );
# from file content
local $/;
open( my $fh, '<', 'json.data' );
$json_text = <$fh>;
$perl_scalar = decode_json( $json_text );
If an outer data is not encoded in UTF-8, firstly you should C<decode> it.
use Encode;
local $/;
open( my $fh, '<', 'json.data' );
my $encoding = 'cp932';
my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE
# or you can write the below code.
#
# open( my $fh, "<:encoding($encoding)", 'json.data' );
# $unicode_json_text = <$fh>;
In this case, C<$unicode_json_text> is of course UNICODE string.
So you B<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
Instead of them, you use C<JSON> module object with C<utf8> disable.
$perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
Or C<encode 'utf8'> and C<decode_json>:
$perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) );
# this way is not efficient.
And now, you want to convert your C<$perl_scalar> into JSON data and
send it to an outer world - a network or a file content, and so on.
Your data usually contains UNICODE strings and you want the converted data to be encoded
in UTF-8, you should use C<encode_json> or C<JSON> module object with C<utf8> enable.
print encode_json( $perl_scalar ); # to a network? file? or display?
# or
print $json->utf8->encode( $perl_scalar );
If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings
for some reason, then its characters are regarded as B<latin1> for perl
(because it does not concern with your $encoding).
You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
Instead of them, you use C<JSON> module object with C<utf8> disable.
Note that the resulted text is a UNICODE string but no problem to print it.
# $perl_scalar contains $encoding encoded string values
$unicode_json_text = $json->utf8(0)->encode( $perl_scalar );
# $unicode_json_text consists of characters less than 0x100
print $unicode_json_text;
Or C<decode $encoding> all string values and C<encode_json>:
$perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } );
# ... do it to each string values, then encode_json
$json_text = encode_json( $perl_scalar );
This method is a proper way but probably not efficient.
See to L<Encode>, L<perluniintro>.
=head1 METHODS
Basically, check to L<JSON> or L<JSON::XS>.
=head2 new
$json = JSON::PP->new
Rturns a new JSON::PP object that can be used to de/encode JSON
strings.
All boolean flags described below are by default I<disabled>.
The mutators for flags all return the JSON object again and thus calls can
be chained:
my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
=> {"a": [1, 2]}
=head2 ascii
$json = $json->ascii([$enable])
$enabled = $json->get_ascii
If $enable is true (or missing), then the encode method will not generate characters outside
the code range 0..127. Any Unicode characters outside that range will be escaped using either
a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627.
(See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>).
In Perl 5.005, there is no character having high value (more than 255).
See to L<UNICODE HANDLING ON PERLS>.
If $enable is false, then the encode method will not escape Unicode characters unless
required by the JSON syntax or other flags. This results in a faster and more compact format.
JSON::PP->new->ascii(1)->encode([chr 0x10401])
=> ["\ud801\udc01"]
=head2 latin1
$json = $json->latin1([$enable])
$enabled = $json->get_latin1
If $enable is true (or missing), then the encode method will encode the resulting JSON
text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255.
If $enable is false, then the encode method will not escape Unicode characters
unless required by the JSON syntax or other flags.
JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
=> ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
See to L<UNICODE HANDLING ON PERLS>.
=head2 utf8
$json = $json->utf8([$enable])
$enabled = $json->get_utf8
If $enable is true (or missing), then the encode method will encode the JSON result
into UTF-8, as required by many protocols, while the decode method expects to be handled
an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any
characters outside the range 0..255, they are thus useful for bytewise/binary I/O.
(In Perl 5.005, any character outside the range 0..255 does not exist.
See to L<UNICODE HANDLING ON PERLS>.)
In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32
encoding families, as described in RFC4627.
If $enable is false, then the encode method will return the JSON string as a (non-encoded)
Unicode string, while decode expects thus a Unicode string. Any decoding or encoding
(e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module.
Example, output UTF-16BE-encoded JSON:
use Encode;
$jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
Example, decode UTF-32LE-encoded JSON:
use Encode;
$object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
=head2 pretty
$json = $json->pretty([$enable])
This enables (or disables) all of the C<indent>, C<space_before> and
C<space_after> flags in one call to generate the most readable
(or most compact) form possible.
Equivalent to:
$json->indent->space_before->space_after
=head2 indent
$json = $json->indent([$enable])
$enabled = $json->get_indent
The default indent space length is three.
You can use C<indent_length> to change the length.
=head2 space_before
$json = $json->space_before([$enable])
$enabled = $json->get_space_before
If C<$enable> is true (or missing), then the C<encode> method will add an extra
optional space before the C<:> separating keys from values in JSON objects.
If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.
This setting has no effect when decoding JSON texts.
Example, space_before enabled, space_after and indent disabled:
{"key" :"value"}
=head2 space_after
$json = $json->space_after([$enable])
$enabled = $json->get_space_after
If C<$enable> is true (or missing), then the C<encode> method will add an extra
optional space after the C<:> separating keys from values in JSON objects
and extra whitespace after the C<,> separating key-value pairs and array
members.
If C<$enable> is false, then the C<encode> method will not add any extra
space at those places.
This setting has no effect when decoding JSON texts.
Example, space_before and indent disabled, space_after enabled:
{"key": "value"}
=head2 relaxed
$json = $json->relaxed([$enable])
$enabled = $json->get_relaxed
If C<$enable> is true (or missing), then C<decode> will accept some
extensions to normal JSON syntax (see below). C<encode> will not be
affected in anyway. I<Be aware that this option makes you accept invalid
JSON texts as if they were valid!>. I suggest only to use this option to
parse application-specific files written by humans (configuration files,
resource files etc.)
If C<$enable> is false (the default), then C<decode> will only accept
valid JSON texts.
Currently accepted extensions are:
=over 4
=item * list items can have an end-comma
JSON I<separates> array elements and key-value pairs with commas. This
can be annoying if you write JSON texts manually and want to be able to
quickly append elements, so this extension accepts comma at the end of
such items not just between them:
[
1,
2, <- this comma not normally allowed
]
{
"k1": "v1",
"k2": "v2", <- this comma not normally allowed
}
=item * shell-style '#'-comments
Whenever JSON allows whitespace, shell-style comments are additionally
allowed. They are terminated by the first carriage-return or line-feed
character, after which more white-space and comments are allowed.
[
1, # this comment not allowed in JSON
# neither this one...
]
=back
=head2 canonical
$json = $json->canonical([$enable])
$enabled = $json->get_canonical
If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
by sorting their keys. This is adding a comparatively high overhead.
If C<$enable> is false, then the C<encode> method will output key-value
pairs in the order Perl stores them (which will likely change between runs
of the same script).
This option is useful if you want the same data structure to be encoded as
the same JSON text (given the same overall settings). If it is disabled,
the same hash might be encoded differently even if contains the same data,
as key-value pairs have no inherent ordering in Perl.
This setting has no effect when decoding JSON texts.
If you want your own sorting routine, you can give a code referece
or a subroutine name to C<sort_by>. See to C<JSON::PP OWN METHODS>.
=head2 allow_nonref
$json = $json->allow_nonref([$enable])
$enabled = $json->get_allow_nonref
If C<$enable> is true (or missing), then the C<encode> method can convert a
non-reference into its corresponding string, number or null JSON value,
which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
values instead of croaking.
If C<$enable> is false, then the C<encode> method will croak if it isn't
passed an arrayref or hashref, as JSON texts must either be an object
or array. Likewise, C<decode> will croak if given something that is not a
JSON object or array.
JSON::PP->new->allow_nonref->encode ("Hello, World!")
=> "Hello, World!"
=head2 allow_unknown
$json = $json->allow_unknown ([$enable])
$enabled = $json->get_allow_unknown
If $enable is true (or missing), then "encode" will *not* throw an
exception when it encounters values it cannot represent in JSON (for
example, filehandles) but instead will encode a JSON "null" value.
Note that blessed objects are not included here and are handled
separately by c<allow_nonref>.
If $enable is false (the default), then "encode" will throw an
exception when it encounters anything it cannot encode as JSON.
This option does not affect "decode" in any way, and it is
recommended to leave it off unless you know your communications
partner.
=head2 allow_blessed
$json = $json->allow_blessed([$enable])
$enabled = $json->get_allow_blessed
If C<$enable> is true (or missing), then the C<encode> method will not
barf when it encounters a blessed reference. Instead, the value of the
B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
disabled or no C<TO_JSON> method found) or a representation of the
object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
encoded. Has no effect on C<decode>.
If C<$enable> is false (the default), then C<encode> will throw an
exception when it encounters a blessed object.
=head2 convert_blessed
$json = $json->convert_blessed([$enable])
$enabled = $json->get_convert_blessed
If C<$enable> is true (or missing), then C<encode>, upon encountering a
blessed object, will check for the availability of the C<TO_JSON> method
on the object's class. If found, it will be called in scalar context
and the resulting scalar will be encoded instead of the object. If no
C<TO_JSON> method is found, the value of C<allow_blessed> will decide what
to do.
The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
returns other blessed objects, those will be handled in the same
way. C<TO_JSON> must take care of not causing an endless recursion cycle
(== crash) in this case. The name of C<TO_JSON> was chosen because other
methods called by the Perl core (== not by the user of the object) are
usually in upper case letters and to avoid collisions with the C<to_json>
function or method.
This setting does not yet influence C<decode> in any way.
If C<$enable> is false, then the C<allow_blessed> setting will decide what
to do when a blessed object is found.
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])
When C<$coderef> is specified, it will be called from C<decode> each
time it decodes a JSON object. The only argument passed to the coderef
is a reference to the newly-created hash. If the code references returns
a single scalar (which need not be a reference), this value
(i.e. a copy of that scalar to avoid aliasing) is inserted into the
deserialised data structure. If it returns an empty list
(NOTE: I<not> C<undef>, which is a valid scalar), the original deserialised
hash will be inserted. This setting can slow down decoding considerably.
When C<$coderef> is omitted or undefined, any existing callback will
be removed and C<decode> will not change the deserialised hash in any
way.
Example, convert all JSON objects into the integer 5:
my $js = JSON::PP->new->filter_json_object (sub { 5 });
# returns [5]
$js->decode ('[{}]'); # the given subroutine takes a hash reference.
# throw an exception because allow_nonref is not enabled
# so a lone 5 is not allowed.
$js->decode ('{"a":1, "b":2}');
=head2 filter_json_single_key_object
$json = $json->filter_json_single_key_object($key [=> $coderef])
Works remotely similar to C<filter_json_object>, but is only called for
JSON objects having a single key named C<$key>.
This C<$coderef> is called before the one specified via
C<filter_json_object>, if any. It gets passed the single value in the JSON
object. If it returns a single value, it will be inserted into the data
structure. If it returns nothing (not even C<undef> but the empty list),
the callback from C<filter_json_object> will be called next, as if no
single-key callback were specified.
If C<$coderef> is omitted or undefined, the corresponding callback will be
disabled. There can only ever be one callback for a given key.
As this callback gets called less often then the C<filter_json_object>
one, decoding speed will not usually suffer as much. Therefore, single-key
objects make excellent targets to serialise Perl objects into, especially
as single-key JSON objects are as close to the type-tagged value concept
as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not
support this in any way, so you need to make sure your data never looks
like a serialised Perl hash.
Typical names for the single object key are C<__class_whatever__>, or
C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even
things like C<__class_md5sum(classname)__>, to reduce the risk of clashing
with real hashes.
Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
into the corresponding C<< $WIDGET{<id>} >> object:
# return whatever is in $WIDGET{5}:
JSON::PP
->new
->filter_json_single_key_object (__widget__ => sub {
$WIDGET{ $_[0] }
})
->decode ('{"__widget__": 5')
# this can be used with a TO_JSON method in some "widget" class
# for serialisation to json:
sub WidgetBase::TO_JSON {
my ($self) = @_;
unless ($self->{id}) {
$self->{id} = ..get..some..id..;
$WIDGET{$self->{id}} = $self;
}
{ __widget__ => $self->{id} }
}
=head2 shrink
$json = $json->shrink([$enable])
$enabled = $json->get_shrink
In JSON::XS, this flag resizes strings generated by either
C<encode> or C<decode> to their minimum size possible.
It will also try to downgrade any strings to octet-form if possible.
In JSON::PP, it is noop about resizing strings but tries
C<utf8::downgrade> to the returned string by C<encode>.
See to L<utf8>.
See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
=head2 max_depth
$json = $json->max_depth([$maximum_nesting_depth])
$max_depth = $json->get_max_depth
Sets the maximum nesting level (default C<512>) accepted while encoding
or decoding. If a higher nesting level is detected in JSON text or a Perl
data structure, then the encoder and decoder will stop and croak at that
point.
Nesting level is defined by number of hash- or arrayrefs that the encoder
needs to traverse to reach a given point or the number of C<{> or C<[>
characters without their matching closing parenthesis crossed to reach a
given character in a string.
If no argument is given, the highest possible setting will be used, which
is rarely useful.
See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
When a large value (100 or more) was set and it de/encodes a deep nested object/text,
it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase.
=head2 max_size
$json = $json->max_size([$maximum_string_size])
$max_size = $json->get_max_size
Set the maximum length a JSON text may have (in bytes) where decoding is
being attempted. The default is C<0>, meaning no limit. When C<decode>
is called on a string that is longer then this many bytes, it will not
attempt to decode the string but throw an exception. This setting has no
effect on C<encode> (yet).
If no argument is given, the limit check will be deactivated (same as when
C<0> is specified).
See L<JSON::XS/SSECURITY CONSIDERATIONS> for more info on why this is useful.
=head2 encode
$json_text = $json->encode($perl_scalar)
Converts the given Perl data structure (a simple scalar or a reference
to a hash or array) to its JSON representation. Simple scalars will be
converted into JSON string or number sequences, while references to arrays
become JSON arrays and references to hashes become JSON objects. Undefined
Perl values (e.g. C<undef>) become JSON C<null> values.
References to the integers C<0> and C<1> are converted into C<true> and C<false>.
=head2 decode
$perl_scalar = $json->decode($json_text)
The opposite of C<encode>: expects a JSON text and tries to parse it,
returning the resulting simple scalar or reference. Croaks on error.
JSON numbers and strings become simple Perl scalars. JSON arrays become
Perl arrayrefs and JSON objects become Perl hashrefs. C<true> becomes
C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
C<null> becomes C<undef>.
=head2 decode_prefix
($perl_scalar, $characters) = $json->decode_prefix($json_text)
This works like the C<decode> method, but instead of raising an exception
when there is trailing garbage after the first JSON object, it will
silently stop parsing there and return the number of characters consumed
so far.
JSON->new->decode_prefix ("[1] the tail")
=> ([], 3)
=head1 INCREMENTAL PARSING
Most of this section are copied and modified from L<JSON::XS/INCREMENTAL PARSING>.
In some cases, there is the need for incremental parsing of JSON texts.
This module does allow you to parse a JSON stream incrementally.
It does so by accumulating text until it has a full JSON object, which
it then can decode. This process is similar to using C<decode_prefix>
to see if a full JSON object is available, but is much more efficient
(and can be implemented with a minimum of method calls).
This module will only attempt to parse the JSON text once it is sure it
has enough text to get a decisive result, using a very simple but
truly incremental parser. This means that it sometimes won't stop as
early as the full parser, for example, it doesn't detect parenthese
mismatches. The only thing it guarantees is that it starts decoding as
soon as a syntactically valid JSON text has been seen. This means you need
to set resource limits (e.g. C<max_size>) to ensure the parser will stop
parsing in the presence if syntax errors.
The following methods implement this incremental parser.
=head2 incr_parse
$json->incr_parse( [$string] ) # void context
$obj_or_undef = $json->incr_parse( [$string] ) # scalar context
@obj_or_empty = $json->incr_parse( [$string] ) # list context
This is the central parsing function. It can both append new text and
extract objects from the stream accumulated so far (both of these
functions are optional).
If C<$string> is given, then this string is appended to the already
existing JSON fragment stored in the C<$json> object.
After that, if the function is called in void context, it will simply
return without doing anything further. This can be used to add more text
in as many chunks as you want.
If the method is called in scalar context, then it will try to extract
exactly I<one> JSON object. If that is successful, it will return this
object, otherwise it will return C<undef>. If there is a parse error,
this method will croak just as C<decode> would do (one can then use
C<incr_skip> to skip the errornous part). This is the most common way of
using the method.
And finally, in list context, it will try to extract as many objects
from the stream as it can find and return them, or the empty list
otherwise. For this to work, there must be no separators between the JSON
objects or arrays, instead they must be concatenated back-to-back. If
an error occurs, an exception will be raised as in the scalar context
case. Note that in this case, any previously-parsed JSON texts will be
lost.
Example: Parse some JSON arrays/objects in a given string and return them.
my @objs = JSON->new->incr_parse ("[5][7][1,2]");
=head2 incr_text
$lvalue_string = $json->incr_text
This method returns the currently stored JSON fragment as an lvalue, that
is, you can manipulate it. This I<only> works when a preceding call to
C<incr_parse> in I<scalar context> successfully returned an object. Under
all other circumstances you must not call this function (I mean it.
although in simple tests it might actually work, it I<will> fail under
real world conditions). As a special exception, you can also call this
method before having parsed anything.
This function is useful in two cases: a) finding the trailing text after a
JSON object or b) parsing multiple JSON objects separated by non-JSON text
(such as commas).
$json->incr_text =~ s/\s*,\s*//;
In Perl 5.005, C<lvalue> attribute is not available.
You must write codes like the below:
$string = $json->incr_text;
$string =~ s/\s*,\s*//;
$json->incr_text( $string );
=head2 incr_skip
$json->incr_skip
This will reset the state of the incremental parser and will remove the
parsed text from the input buffer. This is useful after C<incr_parse>
died, in which case the input buffer and incremental parser state is left
unchanged, to skip the text parsed so far and to reset the parse state.
=head2 incr_reset
$json->incr_reset
This completely resets the incremental parser, that is, after this call,
it will be as if the parser had never parsed anything.
This is useful if you want ot repeatedly parse JSON objects and want to
ignore any trailing data, which means you have to reset the parser after
each successful decode.
See to L<JSON::XS/INCREMENTAL PARSING> for examples.
=head1 JSON::PP OWN METHODS
=head2 allow_singlequote
$json = $json->allow_singlequote([$enable])
If C<$enable> is true (or missing), then C<decode> will accept
JSON strings quoted by single quotations that are invalid JSON
format.
$json->allow_singlequote->decode({"foo":'bar'});
$json->allow_singlequote->decode({'foo':"bar"});
$json->allow_singlequote->decode({'foo':'bar'});
As same as the C<relaxed> option, this option may be used to parse
application-specific files written by humans.
=head2 allow_barekey
$json = $json->allow_barekey([$enable])
If C<$enable> is true (or missing), then C<decode> will accept
bare keys of JSON object that are invalid JSON format.
As same as the C<relaxed> option, this option may be used to parse
application-specific files written by humans.
$json->allow_barekey->decode('{foo:"bar"}');
=head2 allow_bignum
$json = $json->allow_bignum([$enable])
If C<$enable> is true (or missing), then C<decode> will convert
the big integer Perl cannot handle as integer into a L<Math::BigInt>
object and convert a floating number (any) into a L<Math::BigFloat>.
On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
objects into JSON numbers with C<allow_blessed> enable.
$json->allow_nonref->allow_blessed->allow_bignum;
$bigfloat = $json->decode('2.000000000000000000000000001');
print $json->encode($bigfloat);
# => 2.000000000000000000000000001
See to L<JSON::XS/MAPPING> aboout the normal conversion of JSON number.
=head2 loose
$json = $json->loose([$enable])
The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings
and the module doesn't allow to C<decode> to these (except for \x2f).
If C<$enable> is true (or missing), then C<decode> will accept these
unescaped strings.
$json->loose->decode(qq|["abc
def"]|);
See L<JSON::XS/SSECURITY CONSIDERATIONS>.
=head2 escape_slash
$json = $json->escape_slash([$enable])
According to JSON Grammar, I<slash> (U+002F) is escaped. But default
JSON::PP (as same as JSON::XS) encodes strings without escaping slash.
If C<$enable> is true (or missing), then C<encode> will escape slashes.
=head2 indent_length
$json = $json->indent_length($length)
JSON::XS indent space length is 3 and cannot be changed.
JSON::PP set the indent space length with the given $length.
The default is 3. The acceptable range is 0 to 15.
=head2 sort_by
$json = $json->sort_by($function_name)
$json = $json->sort_by($subroutine_ref)
If $function_name or $subroutine_ref are set, its sort routine are used
in encoding JSON objects.
$js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj);
# is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
$js = $pc->sort_by('own_sort')->encode($obj);
# is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|);
sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b }
As the sorting routine runs in the JSON::PP scope, the given
subroutine name and the special variables C<$a>, C<$b> will begin
'JSON::PP::'.
If $integer is set, then the effect is same as C<canonical> on.
=head1 INTERNAL
For developers.
=over
=item PP_encode_box
Returns
{
depth => $depth,
indent_count => $indent_count,
}
=item PP_decode_box
Returns
{
text => $text,
at => $at,
ch => $ch,
len => $len,
depth => $depth,
encoding => $encoding,
is_valid_utf8 => $is_valid_utf8,
};
=back
=head1 MAPPING
This section is copied from JSON::XS and modified to C<JSON::PP>.
JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
See to L<JSON::XS/MAPPING>.
=head2 JSON -> PERL
=over 4
=item object
A JSON object becomes a reference to a hash in Perl. No ordering of object
keys is preserved (JSON does not preserver object key ordering itself).
=item array
A JSON array becomes a reference to an array in Perl.
=item string
A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON
are represented by the same codepoints in the Perl string, so no manual
decoding is necessary.
=item number
A JSON number becomes either an integer, numeric (floating point) or
string scalar in perl, depending on its range and any fractional parts. On
the Perl level, there is no difference between those as Perl handles all
the conversion details, but an integer may take slightly less memory and
might represent more values exactly than floating point numbers.
If the number consists of digits only, C<JSON> will try to represent
it as an integer value. If that fails, it will try to represent it as
a numeric (floating point) value if that is possible without loss of
precision. Otherwise it will preserve the number as a string value (in
which case you lose roundtripping ability, as the JSON number will be
re-encoded toa JSON string).
Numbers containing a fractional or exponential part will always be
represented as numeric (floating point) values, possibly at a loss of
precision (in which case you might lose perfect roundtripping ability, but
the JSON number will still be re-encoded as a JSON number).
Note that precision is not accuracy - binary floating point values cannot
represent most decimal fractions exactly, and when converting from and to
floating point, C<JSON> only guarantees precision up to but not including
the leats significant bit.
When C<allow_bignum> is enable, the big integers
and the numeric can be optionally converted into L<Math::BigInt> and
L<Math::BigFloat> objects.
=item true, false
These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
respectively. They are overloaded to act almost exactly like the numbers
C<1> and C<0>. You can check wether a scalar is a JSON boolean by using
the C<JSON::is_bool> function.
print JSON::PP::true . "\n";
=> true
print JSON::PP::true + 1;
=> 1
ok(JSON::true eq '1');
ok(JSON::true == 1);
C<JSON> will install these missing overloading features to the backend modules.
=item null
A JSON null atom becomes C<undef> in Perl.
C<JSON::PP::null> returns C<unddef>.
=back
=head2 PERL -> JSON
The mapping from Perl to JSON is slightly more difficult, as Perl is a
truly typeless language, so we can only guess which JSON type is meant by
a Perl value.
=over 4
=item hash references
Perl hash references become JSON objects. As there is no inherent ordering
in hash keys (or JSON objects), they will usually be encoded in a
pseudo-random order that can change between runs of the same program but
stays generally the same within a single run of a program. C<JSON>
optionally sort the hash keys (determined by the I<canonical> flag), so
the same datastructure will serialise to the same JSON text (given same
settings and version of JSON::XS), but this incurs a runtime overhead
and is only rarely useful, e.g. when you want to compare some JSON text
against another for equality.
=item array references
Perl array references become JSON arrays.
=item other references
Other unblessed references are generally not allowed and will cause an
exception to be thrown, except for references to the integers C<0> and
C<1>, which get turned into C<false> and C<true> atoms in JSON. You can
also use C<JSON::false> and C<JSON::true> to improve readability.
to_json [\0,JSON::PP::true] # yields [false,true]
=item JSON::PP::true, JSON::PP::false, JSON::PP::null
These special values become JSON true and JSON false values,
respectively. You can also use C<\1> and C<\0> directly if you want.
JSON::PP::null returns C<undef>.
=item blessed objects
Blessed objects are not directly representable in JSON. See the
C<allow_blessed> and C<convert_blessed> methods on various options on
how to deal with this: basically, you can choose between throwing an
exception, encoding the reference as if it weren't blessed, or provide
your own serialiser method.
See to L<convert_blessed>.
=item simple scalars
Simple Perl scalars (any scalar that is not a reference) are the most
difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as
JSON C<null> values, scalars that have last been used in a string context
before encoding as JSON strings, and anything else as number value:
# dump as number
encode_json [2] # yields [2]
encode_json [-3.0e17] # yields [-3e+17]
my $value = 5; encode_json [$value] # yields [5]
# used as string, so dump as string
print $value;
encode_json [$value] # yields ["5"]
# undef becomes null
encode_json [undef] # yields [null]
You can force the type to be a string by stringifying it:
my $x = 3.1; # some variable containing a number
"$x"; # stringified
$x .= ""; # another, more awkward way to stringify
print $x; # perl does it for you, too, quite often
You can force the type to be a number by numifying it:
my $x = "3"; # some variable containing a string
$x += 0; # numify it, ensuring it will be dumped as a number
$x *= 1; # same thing, the choise is yours.
You can not currently force the type in other, less obscure, ways.
Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
can differ to other languages). Also, your perl interpreter might expose
extensions to the floating point numbers of your platform, such as
infinities or NaN's - these cannot be represented in JSON, and it is an
error to pass those in.
=item Big Number
When C<allow_bignum> is enable,
C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
objects into JSON numbers.
=back
=head1 UNICODE HANDLING ON PERLS
If you do not know about Unicode on Perl well,
please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
=head2 Perl 5.8 and later
Perl can handle Unicode and the JSON::PP de/encode methods also work properly.
$json->allow_nonref->encode(chr hex 3042);
$json->allow_nonref->encode(chr hex 12345);
Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively.
$json->allow_nonref->decode('"\u3042"');
$json->allow_nonref->decode('"\ud808\udf45"');
Returns UTF-8 encoded strings with UTF8 flag, regarded as C<U+3042> and C<U+12345>.
Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
so JSON::PP wraps the C<join> with a subroutine. Thus JSON::PP works slow in the versions.
=head2 Perl 5.6
Perl can handle Unicode and the JSON::PP de/encode methods also work.
=head2 Perl 5.005
Perl 5.005 is a byte sementics world -- all strings are sequences of bytes.
That means the unicode handling is not available.
In encoding,
$json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354.
$json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565.
Returns C<B> and C<E>, as C<chr> takes a value more than 255, it treats
as C<$value % 256>, so the above codes are equivalent to :
$json->allow_nonref->encode(chr 66);
$json->allow_nonref->encode(chr 69);
In decoding,
$json->decode('"\u00e3\u0081\u0082"');
The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded
japanese character (C<HIRAGANA LETTER A>).
And if it is represented in Unicode code point, C<U+3042>.
Next,
$json->decode('"\u3042"');
We ordinary expect the returned value is a Unicode character C<U+3042>.
But here is 5.005 world. This is C<0xE3 0x81 0x82>.
$json->decode('"\ud808\udf45"');
This is not a character C<U+12345> but bytes - C<0xf0 0x92 0x8d 0x85>.
=head1 TODO
=over
=item speed
=item memory saving
=back
=head1 SEE ALSO
Most of the document are copied and modified from JSON::XS doc.
L<JSON::XS>
RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
=head1 AUTHOR
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007-2013 by Makamaka Hannyaharamitu
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
JSON_PP
$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN';
=head1 NAME
JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
=head1 SYNOPSIS
# do not "use" yourself
=head1 DESCRIPTION
This module exists only to provide overload resolution for Storable and similar modules. See
L<JSON::PP> for more info about this class.
=cut
use JSON::PP ();
use strict;
1;
=head1 AUTHOR
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
=cut
JSON_PP_BOOLEAN
$fatpacked{"Log/Contextual.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL';
package Log::Contextual;
$Log::Contextual::VERSION = '0.006002';
# ABSTRACT: Simple logging interface with a contextual log
use strict;
use warnings;
my @levels = qw(debug trace warn info error fatal);
use Exporter::Declare;
use Exporter::Declare::Export::Generator;
use Data::Dumper::Concise;
use Scalar::Util 'blessed';
use B qw(svref_2object);
sub stash_name {
my ($coderef) = @_;
ref $coderef or return;
my $cv = B::svref_2object($coderef);
$cv->isa('B::CV') or return;
# bail out if GV is undefined
$cv->GV->isa('B::SPECIAL') and return;
return $cv->GV->STASH->NAME;
}
my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels));
my @log = ((map "log_$_", @levels), (map "logS_$_", @levels));
sub _maybe_export {
my ($spec, $target, $name, $new_code) = @_;
if (my $code = $target->can($name)) {
# this will warn
$spec->add_export("&$name", $new_code)
unless (stash_name($code) eq __PACKAGE__);
} else {
$spec->add_export("&$name", $new_code)
}
}
eval {
require Log::Log4perl;
die if $Log::Log4perl::VERSION < 1.29;
Log::Log4perl->wrapper_register(__PACKAGE__)
};
# ____ is because tags must have at least one export and we don't want to
# export anything but the levels selected
sub ____ { }
exports('____', @dlog, @log, qw( set_logger with_logger ));
export_tag dlog => ('____');
export_tag log => ('____');
import_arguments qw(logger package_logger default_logger);
sub router {
our $Router_Instance ||= do {
require Log::Contextual::Router;
Log::Contextual::Router->new
}
}
sub default_import {
my ($class) = shift;
die 'Log::Contextual does not have a default import list';
()
}
sub arg_logger { $_[1] }
sub arg_levels { $_[1] || [qw(debug trace warn info error fatal)] }
sub arg_package_logger { $_[1] }
sub arg_default_logger { $_[1] }
sub before_import {
my ($class, $importer, $spec) = @_;
my $router = $class->router;
my $exports = $spec->exports;
my %router_args = (
exporter => $class,
target => $importer,
arguments => $spec->argument_info
);
my @tags = $class->default_import($spec)
if $spec->config->{default};
for (@tags) {
die "only tags are supported for defaults at this time"
unless $_ =~ /^:(.*)$/;
$spec->config->{$1} = 1;
}
$router->before_import(%router_args);
if ($exports->{'&set_logger'}) {
die ref($router) . " does not support set_logger()"
unless $router->does('Log::Contextual::Role::Router::SetLogger');
_maybe_export($spec, $importer, 'set_logger',
sub { $router->set_logger(@_) },
);
}
if ($exports->{'&with_logger'}) {
die ref($router) . " does not support with_logger()"
unless $router->does('Log::Contextual::Role::Router::WithLogger');
_maybe_export($spec, $importer, 'with_logger',
sub { $router->with_logger(@_) },
);
}
my @levels = @{$class->arg_levels($spec->config->{levels})};
for my $level (@levels) {
if ($spec->config->{log} || $exports->{"&log_$level"}) {
_maybe_export(
$spec,
$importer,
"log_$level",
sub (&@) {
my ($code, @args) = @_;
$router->handle_log_request(
exporter => $class,
caller_package => scalar(caller),
caller_level => 1,
message_level => $level,
message_sub => $code,
message_args => \@args,
);
return @args;
},
);
}
if ($spec->config->{log} || $exports->{"&logS_$level"}) {
_maybe_export(
$spec,
$importer,
"logS_$level",
sub (&@) {
my ($code, @args) = @_;
$router->handle_log_request(
exporter => $class,
caller_package => scalar(caller),
caller_level => 1,
message_level => $level,
message_sub => $code,
message_args => \@args,
);
return $args[0];
},
);
}
if ($spec->config->{dlog} || $exports->{"&Dlog_$level"}) {
_maybe_export(
$spec,
$importer,
"Dlog_$level",
sub (&@) {
my ($code, @args) = @_;
my $wrapped = sub {
local $_ = (@_ ? Data::Dumper::Concise::Dumper @_ : '()');
&$code;
};
$router->handle_log_request(
exporter => $class,
caller_package => scalar(caller),
caller_level => 1,
message_level => $level,
message_sub => $wrapped,
message_args => \@args,
);
return @args;
},
);
}
if ($spec->config->{dlog} || $exports->{"&DlogS_$level"}) {
_maybe_export(
$spec,
$importer,
"DlogS_$level",
sub (&$) {
my ($code, $ref) = @_;
my $wrapped = sub {
local $_ = Data::Dumper::Concise::Dumper($_[0]);
&$code;
};
$router->handle_log_request(
exporter => $class,
caller_package => scalar(caller),
caller_level => 1,
message_level => $level,
message_sub => $wrapped,
message_args => [$ref],
);
return $ref;
});
}
}
}
sub after_import {
my ($class, $importer, $spec) = @_;
my %router_args = (
exporter => $class,
target => $importer,
arguments => $spec->argument_info
);
$class->router->after_import(%router_args);
}
for (qw(set with)) {
no strict 'refs';
my $sub = "${_}_logger";
*{"Log::Contextual::$sub"} = sub {
die "$sub is no longer a direct sub in Log::Contextual. "
. 'Note that this feature was never tested nor documented. '
. "Please fix your code to import $sub instead of trying to use it directly"
}
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual - Simple logging interface with a contextual log
=head1 VERSION
version 0.006002
=head1 SYNOPSIS
use Log::Contextual qw( :log :dlog set_logger with_logger );
use Log::Contextual::SimpleLogger;
use Log::Log4perl ':easy';
Log::Log4perl->easy_init($DEBUG);
my $logger = Log::Log4perl->get_logger;
set_logger $logger;
log_debug { 'program started' };
sub foo {
my $minilogger = Log::Contextual::SimpleLogger->new({
levels => [qw( trace debug )]
});
my @args = @_;
with_logger $minilogger => sub {
log_trace { 'foo entered' };
my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @args;
# ...
log_trace { 'foo left' };
};
}
foo();
Beginning with version 1.008 L<Log::Dispatchouli> also works out of the box
with C<Log::Contextual>:
use Log::Contextual qw( :log :dlog set_logger );
use Log::Dispatchouli;
my $ld = Log::Dispatchouli->new({
ident => 'slrtbrfst',
to_stderr => 1,
debug => 1,
});
set_logger $ld;
log_debug { 'program started' };
=head1 DESCRIPTION
Major benefits:
=over 2
=item * Efficient
The logging functions take blocks, so if a log level is disabled, the
block will not run:
# the following won't run if debug is off
log_debug { "the new count in the database is " . $rs->count };
Similarly, the C<D> prefixed methods only C<Dumper> the input if the level is
enabled.
=item * Handy
The logging functions return their arguments, so you can stick them in
the middle of expressions:
for (log_debug { "downloading:\n" . join qq(\n), @_ } @urls) { ... }
=item * Generic
C<Log::Contextual> is an interface for all major loggers. If you log through
C<Log::Contextual> you will be able to swap underlying loggers later.
=item * Powerful
C<Log::Contextual> chooses which logger to use based on L<< user defined C<CodeRef>s|/LOGGER CODEREF >>.
Normally you don't need to know this, but you can take advantage of it when you
need to later
=item * Scalable
If you just want to add logging to your extremely basic application, start with
L<Log::Contextual::SimpleLogger> and then as your needs grow you can switch to
L<Log::Dispatchouli> or L<Log::Dispatch> or L<Log::Log4perl> or whatever else.
=back
This module is a simple interface to extensible logging. It exists to
abstract your logging interface so that logging is as painless as possible,
while still allowing you to switch from one logger to another.
It is bundled with a really basic logger, L<Log::Contextual::SimpleLogger>,
but in general you should use a real logger instead of that. For something
more serious but not overly complicated, try L<Log::Dispatchouli> (see
L</SYNOPSIS> for example.)
=head1 A WORK IN PROGRESS
This module is certainly not complete, but we will not break the interface
lightly, so I would say it's safe to use in production code. The main result
from that at this point is that doing:
use Log::Contextual;
will die as we do not yet know what the defaults should be. If it turns out
that nearly everyone uses the C<:log> tag and C<:dlog> is really rare, we'll
probably make C<:log> the default. But only time and usage will tell.
=head1 IMPORT OPTIONS
See L</SETTING DEFAULT IMPORT OPTIONS> for information on setting these project
wide.
=head2 -logger
When you import this module you may use C<-logger> as a shortcut for
L</set_logger>, for example:
use Log::Contextual::SimpleLogger;
use Log::Contextual qw( :dlog ),
-logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )] });
sometimes you might want to have the logger handy for other stuff, in which
case you might try something like the following:
my $var_log;
BEGIN { $var_log = VarLogger->new }
use Log::Contextual qw( :dlog ), -logger => $var_log;
=head2 -levels
The C<-levels> import option allows you to define exactly which levels your
logger supports. So the default,
C<< [qw(debug trace warn info error fatal)] >>, works great for
L<Log::Log4perl>, but it doesn't support the levels for L<Log::Dispatch>. But
supporting those levels is as easy as doing
use Log::Contextual
-levels => [qw( debug info notice warning error critical alert emergency )];
=head2 -package_logger
The C<-package_logger> import option is similar to the C<-logger> import option
except C<-package_logger> sets the logger for the current package.
Unlike L</-default_logger>, C<-package_logger> cannot be overridden with
L</set_logger>.
package My::Package;
use Log::Contextual::SimpleLogger;
use Log::Contextual qw( :log ),
-package_logger => Log::Contextual::WarnLogger->new({
env_prefix => 'MY_PACKAGE'
});
If you are interested in using this package for a module you are putting on
CPAN we recommend L<Log::Contextual::WarnLogger> for your package logger.
=head2 -default_logger
The C<-default_logger> import option is similar to the C<-logger> import option
except C<-default_logger> sets the B<default> logger for the current package.
Basically it sets the logger to be used if C<set_logger> is never called; so
package My::Package;
use Log::Contextual::SimpleLogger;
use Log::Contextual qw( :log ),
-default_logger => Log::Contextual::WarnLogger->new({
env_prefix => 'MY_PACKAGE'
});
=head1 SETTING DEFAULT IMPORT OPTIONS
Eventually you will get tired of writing the following in every single one of
your packages:
use Log::Log4perl;
use Log::Log4perl ':easy';
BEGIN { Log::Log4perl->easy_init($DEBUG) }
use Log::Contextual -logger => Log::Log4perl->get_logger;
You can set any of the import options for your whole project if you define your
own C<Log::Contextual> subclass as follows:
package MyApp::Log::Contextual;
use base 'Log::Contextual';
use Log::Log4perl ':easy';
Log::Log4perl->easy_init($DEBUG)
sub arg_default_logger { $_[1] || Log::Log4perl->get_logger }
sub arg_levels { [qw(debug trace warn info error fatal custom_level)] }
sub default_import { ':log' }
# or maybe instead of default_logger
sub arg_package_logger { $_[1] }
# and almost definitely not this, which is only here for completeness
sub arg_logger { $_[1] }
Note the C<< $_[1] || >> in C<arg_default_logger>. All of these methods are
passed the values passed in from the arguments to the subclass, so you can
either throw them away, honor them, die on usage, or whatever. To be clear,
if you define your subclass, and someone uses it as follows:
use MyApp::Log::Contextual -default_logger => $foo,
-levels => [qw(bar baz biff)];
Your C<arg_default_logger> method will get C<$foo> and your C<arg_levels>
will get C<[qw(bar baz biff)]>;
Additionally, the C<default_import> method is what happens if a user tries to
use your subclass with no arguments. The default just dies, but if you'd like
to change the default to import a tag merely return the tags you'd like to
import. So the following will all work:
sub default_import { ':log' }
sub default_import { ':dlog' }
sub default_import { qw(:dlog :log ) }
See L<Log::Contextual::Easy::Default> for an example of a subclass of
C<Log::Contextual> that makes use of default import options.
=head1 FUNCTIONS
=head2 set_logger
my $logger = WarnLogger->new;
set_logger $logger;
Arguments: L</LOGGER CODEREF>
C<set_logger> will just set the current logger to whatever you pass it. It
expects a C<CodeRef>, but if you pass it something else it will wrap it in a
C<CodeRef> for you. C<set_logger> is really meant only to be called from a
top-level script. To avoid foot-shooting the function will warn if you call it
more than once.
=head2 with_logger
my $logger = WarnLogger->new;
with_logger $logger => sub {
if (1 == 0) {
log_fatal { 'Non Logical Universe Detected' };
} else {
log_info { 'All is good' };
}
};
Arguments: L</LOGGER CODEREF>, C<CodeRef $to_execute>
C<with_logger> sets the logger for the scope of the C<CodeRef> C<$to_execute>.
As with L</set_logger>, C<with_logger> will wrap C<$returning_logger> with a
C<CodeRef> if needed.
=head2 log_$level
Import Tag: C<:log>
Arguments: C<CodeRef $returning_message, @args>
C<log_$level> functions all work the same except that a different method
is called on the underlying C<$logger> object. The basic pattern is:
sub log_$level (&@) {
if ($logger->is_$level) {
$logger->$level(shift->(@_));
}
@_
}
Note that the function returns it's arguments. This can be used in a number of
ways, but often it's convenient just for partial inspection of passthrough data
my @friends = log_trace {
'friends list being generated, data from first friend: ' .
Dumper($_[0]->TO_JSON)
} generate_friend_list();
If you want complete inspection of passthrough data, take a look at the
L</Dlog_$level> functions.
Which functions are exported depends on what was passed to L</-levels>. The
default (no C<-levels> option passed) would export:
=over 2
=item log_trace
=item log_debug
=item log_info
=item log_warn
=item log_error
=item log_fatal
=back
=head2 logS_$level
Import Tag: C<:log>
Arguments: C<CodeRef $returning_message, Item $arg>
This is really just a special case of the L</log_$level> functions. It forces
scalar context when that is what you need. Other than that it works exactly
same:
my $friend = logS_trace {
'I only have one friend: ' . Dumper($_[0]->TO_JSON)
} friend();
See also: L</DlogS_$level>.
=head2 Dlog_$level
Import Tag: C<:dlog>
Arguments: C<CodeRef $returning_message, @args>
All of the following six functions work the same as their L</log_$level>
brethren, except they return what is passed into them and put the stringified
(with L<Data::Dumper::Concise>) version of their args into C<$_>. This means
you can do cool things like the following:
my @nicks = Dlog_debug { "names: $_" } map $_->value, $frew->names->all;
and the output might look something like:
names: "fREW"
"fRIOUX"
"fROOH"
"fRUE"
"fiSMBoC"
Which functions are exported depends on what was passed to L</-levels>. The
default (no C<-levels> option passed) would export:
=over 2
=item Dlog_trace
=item Dlog_debug
=item Dlog_info
=item Dlog_warn
=item Dlog_error
=item Dlog_fatal
=back
=head2 DlogS_$level
Import Tag: C<:dlog>
Arguments: C<CodeRef $returning_message, Item $arg>
Like L</logS_$level>, these functions are a special case of L</Dlog_$level>.
They only take a single scalar after the C<$returning_message> instead of
slurping up (and also setting C<wantarray>) all the C<@args>
my $pals_rs = DlogS_debug { "pals resultset: $_" }
$schema->resultset('Pals')->search({ perlers => 1 });
=head1 LOGGER CODEREF
Anywhere a logger object can be passed, a coderef is accepted. This is so
that the user can use different logger objects based on runtime information.
The logger coderef is passed the package of the caller the caller level the
coderef needs to use if it wants more caller information. The latter is in
a hashref to allow for more options in the future.
Here is a basic example of a logger that exploits C<caller> to reproduce the
output of C<warn> with a logger:
my @caller_info;
my $var_log = Log::Contextual::SimpleLogger->new({
levels => [qw(trace debug info warn error fatal)],
coderef => sub { chomp($_[0]); warn "$_[0] at $caller_info[1] line $caller_info[2].\n" }
});
my $warn_faker = sub {
my ($package, $args) = @_;
@caller_info = caller($args->{caller_level});
$var_log
};
set_logger($warn_faker);
log_debug { 'test' };
The following is an example that uses the information passed to the logger
coderef. It sets the global logger to C<$l3>, the logger for the C<A1>
package to C<$l1>, except the C<lol> method in C<A1> which uses the C<$l2>
logger and lastly the logger for the C<A2> package to C<$l2>.
Note that it increases the caller level as it dispatches based on where
the caller of the log function, not the log function itself.
my $complex_dispatcher = do {
my $l1 = ...;
my $l2 = ...;
my $l3 = ...;
my %registry = (
-logger => $l3,
A1 => {
-logger => $l1,
lol => $l2,
},
A2 => { -logger => $l2 },
);
sub {
my ( $package, $info ) = @_;
my $logger = $registry{'-logger'};
if (my $r = $registry{$package}) {
$logger = $r->{'-logger'} if $r->{'-logger'};
my (undef, undef, undef, $sub) = caller($info->{caller_level} + 1);
$sub =~ s/^\Q$package\E:://g;
$logger = $r->{$sub} if $r->{$sub};
}
return $logger;
}
};
set_logger $complex_dispatcher;
=head1 LOGGER INTERFACE
Because this module is ultimately pretty looking glue (glittery?) with the
awesome benefit of the Contextual part, users will often want to make their
favorite logger work with it. The following are the methods that should be
implemented in the logger:
is_trace
is_debug
is_info
is_warn
is_error
is_fatal
trace
debug
info
warn
error
fatal
The first six merely need to return true if that level is enabled. The latter
six take the results of whatever the user returned from their coderef and log
them. For a basic example see L<Log::Contextual::SimpleLogger>.
=head1 LOG ROUTING
In between the loggers and the log functions is a log router that is responsible for
finding a logger to handle the log event and passing the log information to the
logger. This relationship is described in the documentation for C<Log::Contextual::Role::Router>.
C<Log::Contextual> and packages that extend it will by default share a router singleton that
implements the with_logger() and set_logger() functions and also respects the -logger,
-package_logger, and -default_logger import options with their associated default value
functions. The router singleton is available as the return value of the router() function. Users
of Log::Contextual may overload router() to return instances of custom log routers that
could for example work with loggers that use a different interface.
=head1 CONTRIBUTORS
triddle - Tyler Riddle <t.riddle@shadowcat.co.uk>
voj - Jakob Voß <voss@gbv.de>
=head1 DESIGNER
mst - Matt S. Trout <mst@shadowcat.co.uk>
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL
$fatpacked{"Log/Contextual/Easy/Default.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_EASY_DEFAULT';
package Log::Contextual::Easy::Default;
$Log::Contextual::Easy::Default::VERSION = '0.006002';
# ABSTRACT: Import all logging methods with WarnLogger as default
use strict;
use warnings;
use base 'Log::Contextual';
sub arg_default_logger {
if ($_[1]) {
return $_[1];
} else {
require Log::Contextual::WarnLogger;
my $package = uc(caller(3));
$package =~ s/::/_/g;
return Log::Contextual::WarnLogger->new({env_prefix => $package});
}
}
sub default_import { qw(:dlog :log ) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::Easy::Default - Import all logging methods with WarnLogger as default
=head1 VERSION
version 0.006002
=head1 SYNOPSIS
In your module:
package My::Module;
use Log::Contextual::Easy::Default;
log_debug { "your message" };
Dlog_trace { $_ } @vars;
In your program:
use My::Module;
# enable warnings
$ENV{MY_MODULE_UPTO}="TRACE";
# or use a specific logger with set_logger / with_logger
=head1 DESCRIPTION
By default, this module enables a L<Log::Contextual::WarnLogger>
with C<env_prefix> based on the module's name that uses
Log::Contextual::Easy. The logging levels are set to C<trace> C<debug>,
C<info>, C<warn>, C<error>, and C<fatal> (in this order) and all
logging functions (L<log_...|Log::Contextual/"log_$level">,
L<logS_...|Log::Contextual/"logS_$level">,
L<Dlog_...|Log::Contextual/"Dlog_$level">, and
L<Dlog...|Log::Contextual/"DlogS_$level">) are exported.
For what C<::Default> implies, see L<Log::Contextual/-default_logger>.
=head1 SEE ALSO
=over 4
=item L<Log::Contextual::Easy::Package>
=back
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_EASY_DEFAULT
$fatpacked{"Log/Contextual/Easy/Package.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_EASY_PACKAGE';
package Log::Contextual::Easy::Package;
$Log::Contextual::Easy::Package::VERSION = '0.006002';
# ABSTRACT: Import all logging methods with WarnLogger as default package logger
use strict;
use warnings;
use base 'Log::Contextual';
sub arg_package_logger {
if ($_[1]) {
return $_[1];
} else {
require Log::Contextual::WarnLogger;
my $package = uc(caller(3));
$package =~ s/::/_/g;
return Log::Contextual::WarnLogger->new({env_prefix => $package});
}
}
sub default_import { qw(:dlog :log ) }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::Easy::Package - Import all logging methods with WarnLogger as default package logger
=head1 VERSION
version 0.006002
=head1 SYNOPSIS
In your module:
package My::Module;
use Log::Contextual::Easy::Package;
log_debug { "your message" };
Dlog_trace { $_ } @vars;
In your program:
use My::Module;
# enable warnings
$ENV{MY_MODULE_UPTO}="TRACE";
# or use a specific logger with set_logger / with_logger
=head1 DESCRIPTION
By default, this module enables a L<Log::Contextual::WarnLogger>
with C<env_prefix> based on the module's name that uses
Log::Contextual::Easy. The logging levels are set to C<trace> C<debug>,
C<info>, C<warn>, C<error>, and C<fatal> (in this order) and all
logging functions (L<log_...|Log::Contextual/"log_$level">,
L<logS_...|Log::Contextual/"logS_$level">,
L<Dlog_...|Log::Contextual/"Dlog_$level">, and
L<Dlog...|Log::Contextual/"DlogS_$level">) are exported.
For what C<::Package> implies, see L<Log::Contextual/-package_logger>.
=head1 SEE ALSO
=over 4
=item L<Log::Contextual::Easy::Default>
=back
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_EASY_PACKAGE
$fatpacked{"Log/Contextual/Role/Router.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROLE_ROUTER';
package Log::Contextual::Role::Router;
$Log::Contextual::Role::Router::VERSION = '0.006002';
# ABSTRACT: Abstract interface between loggers and logging code blocks
use Moo::Role;
requires 'before_import';
requires 'after_import';
requires 'handle_log_request';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::Role::Router - Abstract interface between loggers and logging code blocks
=head1 VERSION
version 0.006002
=head1 SYNOPSIS
package MyApp::Log::Router;
use Moo;
use Log::Contextual::SimpleLogger;
with 'Log::Contextual::Role::Router';
has logger => (is => 'lazy');
sub _build_logger {
return Log::Contextual::SimpleLogger->new({ levels_upto => 'debug' });
}
sub before_import {
my ($self, %export_info) = @_;
my $exporter = $export_info{exporter};
my $target = $export_info{target};
print STDERR "Package '$target' will import from '$exporter'\n";
}
sub after_import {
my ($self, %export_info) = @_;
my $exporter = $export_info{exporter};
my $target = $export_info{target};
print STDERR "Package '$target' has imported from '$exporter'\n";
}
sub handle_log_request {
my ($self, %message_info) = @_;
my $log_code_block = $message_info{message_sub};
my $args = $message_info{message_args};
my $log_level_name = $message_info{message_level};
my $logger = $self->logger;
my $is_active = $logger->can("is_${log_level_name}");
return unless defined $is_active && $logger->$is_active;
my $log_message = $log_code_block->(@$args);
$logger->$log_level_name($log_message);
}
package MyApp::Log::Contextual;
use Moo;
use MyApp::Log::Router;
extends 'Log::Contextual';
#This example router is a singleton
sub router {
our $Router ||= MyApp::Log::Router->new
}
package main;
use strict;
use warnings;
use MyApp::Log::Contextual qw(:log);
log_info { "Hello there" };
=head1 DESCRIPTION
Log::Contextual has three parts
=over 4
=item Export manager and logging method generator
These tasks are handled by the C<Log::Contextual> package.
=item Logger selection and invocation
The logging functions generated and exported by Log::Contextual call a method
on an instance of a log router object which is responsible for invoking any loggers
that should get an opportunity to receive the log message. The C<Log::Contextual::Router>
class implements the set_logger() and with_logger() functions as well as uses the
arg_ prefixed functions to configure itself and provide the standard C<Log::Contextual>
logger selection API.
=item Log message formatting and output
The logger objects themselves accept or reject a log message at a certain log
level with a guard method per level. If the logger is going to accept the
log message the router is then responsible for executing the log message code
block and passing the generated message to the logging object's log method.
=back
=head1 METHODS
=over 4
=item before_import($self, %import_info)
=item after_import($self, %import_info)
These two required methods are called with identical arguments at two different places
during the import process. The before_import() method is invoked prior to the logging
subroutines being exported into the target package and after_import() is called when the
export is completed but before control returns to the package that imported the API.
The arguments are passed as a hash with the following keys:
=over 4
=item exporter
This is the name of the package that has been imported. It can also be 'Log::Contextual' itself. In
the case of the synopsis the value for exporter would be 'MyApp::Log::Contextual'.
=item target
This is the package name that is importing the logging API. In the case of the synopsis the
value would be 'main'.
=item arguments
This is a hash reference containing the configuration values that were provided for the import.
The key is the name of the configuration item that was specified without the leading hyphen ('-').
For instance if the logging API is imported as follows
use Log::Contextual qw( :log ), -logger => Custom::Logger->new({ levels => [qw( debug )] });
then $import_info{arguments}->{logger} would contain that instance of Custom::Logger.
=back
=item handle_log_request($self, %message_info)
This method is called by C<Log::Contextual> when a log event happens. The arguments are passed
as a hash with the following keys
=over 4
=item exporter
This is the name of the package that created the logging methods used to generate the log event.
=item caller_package
This is the name of the package that the log event has happened inside of.
=item caller_level
This is an integer that contains the value to pass to caller() that will provide
information about the location the log event was created at.
=item log_level
This is the name of the log level associated with the log event.
=item message_sub
This is the message generating code block associated with the log event passed as a subref. If
the logger accepts the log request the router should execute the subref to create
the log message and then pass the message as a string to the logger.
=item message_args
This is an array reference that contains the arguments given to the message generating code block.
When invoking the message generator it will almost certainly be expecting these argument values
as well.
=back
=back
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_ROLE_ROUTER
$fatpacked{"Log/Contextual/Role/Router/SetLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROLE_ROUTER_SETLOGGER';
package Log::Contextual::Role::Router::SetLogger;
$Log::Contextual::Role::Router::SetLogger::VERSION = '0.006002';
use Moo::Role;
requires 'set_logger';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::Role::Router::SetLogger
=head1 VERSION
version 0.006002
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_ROLE_ROUTER_SETLOGGER
$fatpacked{"Log/Contextual/Role/Router/WithLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROLE_ROUTER_WITHLOGGER';
package Log::Contextual::Role::Router::WithLogger;
$Log::Contextual::Role::Router::WithLogger::VERSION = '0.006002';
use Moo::Role;
requires 'with_logger';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::Role::Router::WithLogger
=head1 VERSION
version 0.006002
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_ROLE_ROUTER_WITHLOGGER
$fatpacked{"Log/Contextual/Router.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_ROUTER';
package Log::Contextual::Router;
$Log::Contextual::Router::VERSION = '0.006002';
use Moo;
use Scalar::Util 'blessed';
with 'Log::Contextual::Role::Router',
'Log::Contextual::Role::Router::SetLogger',
'Log::Contextual::Role::Router::WithLogger';
eval {
require Log::Log4perl;
die if $Log::Log4perl::VERSION < 1.29;
Log::Log4perl->wrapper_register(__PACKAGE__)
};
has _default_logger => (
is => 'ro',
default => sub { {} },
init_arg => undef,
);
has _package_logger => (
is => 'ro',
default => sub { {} },
init_arg => undef,
);
has _get_logger => (
is => 'ro',
default => sub { {} },
init_arg => undef,
);
sub before_import { }
sub after_import {
my ($self, %import_info) = @_;
my $exporter = $import_info{exporter};
my $target = $import_info{target};
my $config = $import_info{arguments};
if (my $l = $exporter->arg_logger($config->{logger})) {
$self->set_logger($l);
}
if (my $l = $exporter->arg_package_logger($config->{package_logger})) {
$self->_set_package_logger_for($target, $l);
}
if (my $l = $exporter->arg_default_logger($config->{default_logger})) {
$self->_set_default_logger_for($target, $l);
}
}
sub with_logger {
my $logger = $_[1];
if (ref $logger ne 'CODE') {
die 'logger was not a CodeRef or a logger object. Please try again.'
unless blessed($logger);
$logger = do {
my $l = $logger;
sub { $l }
}
}
local $_[0]->_get_logger->{l} = $logger;
$_[2]->();
}
sub set_logger {
my $logger = $_[1];
if (ref $logger ne 'CODE') {
die 'logger was not a CodeRef or a logger object. Please try again.'
unless blessed($logger);
$logger = do {
my $l = $logger;
sub { $l }
}
}
warn 'set_logger (or -logger) called more than once! This is a bad idea!'
if $_[0]->_get_logger->{l};
$_[0]->_get_logger->{l} = $logger;
}
sub _set_default_logger_for {
my $logger = $_[2];
if (ref $logger ne 'CODE') {
die 'logger was not a CodeRef or a logger object. Please try again.'
unless blessed($logger);
$logger = do {
my $l = $logger;
sub { $l }
}
}
$_[0]->_default_logger->{$_[1]} = $logger
}
sub _set_package_logger_for {
my $logger = $_[2];
if (ref $logger ne 'CODE') {
die 'logger was not a CodeRef or a logger object. Please try again.'
unless blessed($logger);
$logger = do {
my $l = $logger;
sub { $l }
}
}
$_[0]->_package_logger->{$_[1]} = $logger
}
sub get_loggers {
my ($self, %info) = @_;
my $package = $info{caller_package};
my $log_level = $info{message_level};
my $logger =
( $_[0]->_package_logger->{$package}
|| $_[0]->_get_logger->{l}
|| $_[0]->_default_logger->{$package}
|| die
q( no logger set! you can't try to log something without a logger! ));
$info{caller_level}++;
$logger = $logger->($package, \%info);
return $logger if $logger ->${\"is_${log_level}"};
return ();
}
sub handle_log_request {
my ($self, %message_info) = @_;
my $generator = $message_info{message_sub};
my $args = $message_info{message_args};
my $log_level = $message_info{message_level};
$message_info{caller_level}++;
foreach my $logger ($self->get_loggers(%message_info)) {
$logger->$log_level($generator->(@$args));
}
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::Router
=head1 VERSION
version 0.006002
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_ROUTER
$fatpacked{"Log/Contextual/SimpleLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_SIMPLELOGGER';
package Log::Contextual::SimpleLogger;
$Log::Contextual::SimpleLogger::VERSION = '0.006002';
# ABSTRACT: Super simple logger made for playing with Log::Contextual
use strict;
use warnings;
{
for my $name (qw( trace debug info warn error fatal )) {
no strict 'refs';
*{$name} = sub {
my $self = shift;
$self->_log($name, @_)
if ($self->{$name});
};
*{"is_$name"} = sub {
my $self = shift;
return $self->{$name};
};
}
}
sub new {
my ($class, $args) = @_;
my $self = bless {}, $class;
$self->{$_} = 1 for @{$args->{levels}};
$self->{coderef} = $args->{coderef} || sub { print STDERR @_ };
if (my $upto = $args->{levels_upto}) {
my @levels = (qw( trace debug info warn error fatal ));
my $i = 0;
for (@levels) {
last if $upto eq $_;
$i++
}
for ($i .. $#levels) {
$self->{$levels[$_]} = 1
}
}
return $self;
}
sub _log {
my $self = shift;
my $level = shift;
my $message = join("\n", @_);
$message .= "\n" unless $message =~ /\n$/;
$self->{coderef}->(sprintf("[%s] %s", $level, $message));
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::SimpleLogger - Super simple logger made for playing with Log::Contextual
=head1 VERSION
version 0.006002
=head1 SYNOPSIS
use Log::Contextual::SimpleLogger;
use Log::Contextual qw( :log ),
-logger => Log::Contextual::SimpleLogger->new({ levels => [qw( debug )]});
log_info { 'program started' }; # no-op because info is not in levels
sub foo {
log_debug { 'entered foo' };
...
}
=head1 DESCRIPTION
This module is a simple logger made mostly for demonstration and initial
experimentation with L<Log::Contextual>. We recommend you use a real logger
instead. For something more serious but not overly complicated, take a look at
L<Log::Dispatchouli>.
=head1 METHODS
=head2 new
Arguments: C<< Dict[
levels => Optional[ArrayRef[Str]],
levels_upto => Level,
coderef => Optional[CodeRef],
] $conf >>
my $l = Log::Contextual::SimpleLogger->new({
levels => [qw( info warn )],
coderef => sub { print @_ }, # the default prints to STDERR
});
or
my $l = Log::Contextual::SimpleLogger->new({
levels_upto => 'debug',
coderef => sub { print @_ }, # the default prints to STDERR
});
Creates a new SimpleLogger object with the passed levels enabled and optionally
a C<CodeRef> may be passed to modify how the logs are output/stored.
C<levels_upto> enables all the levels upto and including the level passed.
Levels may contain:
trace
debug
info
warn
error
fatal
=head2 $level
Arguments: C<@anything>
All of the following six methods work the same. The basic pattern is:
sub $level {
my $self = shift;
print STDERR "[$level] " . join qq{\n}, @_;
if $self->is_$level;
}
=head3 trace
$l->trace( 'entered method foo with args ' join q{,}, @args );
=head3 debug
$l->debug( 'entered method foo' );
=head3 info
$l->info( 'started process foo' );
=head3 warn
$l->warn( 'possible misconfiguration at line 10' );
=head3 error
$l->error( 'non-numeric user input!' );
=head3 fatal
$l->fatal( '1 is never equal to 0!' );
=head2 is_$level
All of the following six functions just return true if their respective
level is enabled.
=head3 is_trace
say 'tracing' if $l->is_trace;
=head3 is_debug
say 'debuging' if $l->is_debug;
=head3 is_info
say q{info'ing} if $l->is_info;
=head3 is_warn
say 'warning' if $l->is_warn;
=head3 is_error
say 'erroring' if $l->is_error;
=head3 is_fatal
say q{fatal'ing} if $l->is_fatal;
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_SIMPLELOGGER
$fatpacked{"Log/Contextual/TeeLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_TEELOGGER';
package Log::Contextual::TeeLogger;
$Log::Contextual::TeeLogger::VERSION = '0.006002';
# ABSTRACT: Output to more than one logger
use strict;
use warnings;
{
for my $name (qw( trace debug info warn error fatal )) {
no strict 'refs';
*{$name} = sub {
my $self = shift;
foreach my $logger (@{$self->{loggers}}) {
$logger->$name(@_);
}
};
my $is_name = "is_${name}";
*{$is_name} = sub {
my $self = shift;
foreach my $logger (@{$self->{loggers}}) {
return 1 if $logger->$is_name(@_);
}
return 0;
};
}
}
sub new {
my ($class, $args) = @_;
my $self = bless {}, $class;
ref($self->{loggers} = $args->{loggers}) eq 'ARRAY'
or die "No loggers passed to tee logger";
return $self;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::TeeLogger - Output to more than one logger
=head1 VERSION
version 0.006002
=head1 SYNOPSIS
use Log::Contextual::SimpleLogger;
use Log::Contextual::TeeLogger;
use Log::Contextual qw( :log ),
-logger => Log::Contextual::TeeLogger->new({ loggers => [
Log::Contextual::SimpleLogger->new({ levels => [ 'debug' ] }),
Log::Contextual::SimpleLogger->new({
levels => [ 'info' ],
coderef => sub { print @_ },
}),
]});
## docs below here not yet edited
log_info { 'program started' }; # no-op because info is not in levels
sub foo {
log_debug { 'entered foo' };
...
}
=head1 DESCRIPTION
This module is a simple logger made mostly for demonstration and initial
experimentation with L<Log::Contextual>. We recommend you use a real logger
instead. For something more serious but not overly complicated, take a look at
L<Log::Dispatchouli>.
=head1 METHODS
=head2 new
Arguments: C<< Dict[ levels => ArrayRef[Str], coderef => Optional[CodeRef] ] $conf >>
my $l = Log::Contextual::SimpleLogger->new({
levels => [qw( info warn )],
coderef => sub { print @_ }, # the default prints to STDERR
});
Creates a new SimpleLogger object with the passed levels enabled and optionally
a C<CodeRef> may be passed to modify how the logs are output/stored.
Levels may contain:
trace
debug
info
warn
error
fatal
=head2 $level
Arguments: C<@anything>
All of the following six methods work the same. The basic pattern is:
sub $level {
my $self = shift;
print STDERR "[$level] " . join qq{\n}, @_;
if $self->is_$level;
}
=head3 trace
$l->trace( 'entered method foo with args ' join q{,}, @args );
=head3 debug
$l->debug( 'entered method foo' );
=head3 info
$l->info( 'started process foo' );
=head3 warn
$l->warn( 'possible misconfiguration at line 10' );
=head3 error
$l->error( 'non-numeric user input!' );
=head3 fatal
$l->fatal( '1 is never equal to 0!' );
=head2 is_$level
All of the following six functions just return true if their respective
level is enabled.
=head3 is_trace
say 'tracing' if $l->is_trace;
=head3 is_debug
say 'debuging' if $l->is_debug;
=head3 is_info
say q{info'ing} if $l->is_info;
=head3 is_warn
say 'warning' if $l->is_warn;
=head3 is_error
say 'erroring' if $l->is_error;
=head3 is_fatal
say q{fatal'ing} if $l->is_fatal;
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_TEELOGGER
$fatpacked{"Log/Contextual/WarnLogger.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOG_CONTEXTUAL_WARNLOGGER';
package Log::Contextual::WarnLogger;
$Log::Contextual::WarnLogger::VERSION = '0.006002';
# ABSTRACT: logger for libraries using Log::Contextual
use strict;
use warnings;
use Carp 'croak';
my @default_levels = qw( trace debug info warn error fatal );
# generate subs to handle the default levels
# anything else will have to be handled by AUTOLOAD at runtime
{
for my $level (@default_levels) {
no strict 'refs';
my $is_name = "is_$level";
*{$level} = sub {
my $self = shift;
$self->_log($level, @_)
if $self->$is_name;
};
*{$is_name} = sub {
my $self = shift;
return 1 if $ENV{$self->{env_prefix} . '_' . uc $level};
my $upto = $ENV{$self->{env_prefix} . '_UPTO'};
return unless $upto;
$upto = lc $upto;
return $self->{level_num}{$level} >= $self->{level_num}{$upto};
};
}
}
our $AUTOLOAD;
sub AUTOLOAD {
my $self = $_[0];
(my $name = our $AUTOLOAD) =~ s/.*:://;
return if $name eq 'DESTROY';
# extract the log level from the sub name
my ($is, $level) = $name =~ m/^(is_)?(.+)$/;
my $is_name = "is_$level";
no strict 'refs';
*{$level} = sub {
my $self = shift;
$self->_log($level, @_)
if $self->$is_name;
};
*{$is_name} = sub {
my $self = shift;
my $prefix_field = $self->{env_prefix} . '_' . uc $level;
return 1 if $ENV{$prefix_field};
# don't log if the variable specifically says not to
return 0 if defined $ENV{$prefix_field} and not $ENV{$prefix_field};
my $upto_field = $self->{env_prefix} . '_UPTO';
my $upto = $ENV{$upto_field};
if ($upto) {
$upto = lc $upto;
croak "Unrecognized log level '$upto' in \$ENV{$upto_field}"
if not defined $self->{level_num}{$upto};
return $self->{level_num}{$level} >= $self->{level_num}{$upto};
}
# if we don't recognize this level and nothing says otherwise, log!
return 1 if not $self->{custom_levels};
};
goto &$AUTOLOAD;
}
sub new {
my ($class, $args) = @_;
my $levels = $args->{levels};
croak 'invalid levels specification: must be non-empty arrayref'
if defined $levels and (ref $levels ne 'ARRAY' or !@$levels);
my $custom_levels = defined $levels;
$levels ||= [@default_levels];
my %level_num;
@level_num{@$levels} = (0 .. $#{$levels});
my $self = bless {
levels => $levels,
level_num => \%level_num,
custom_levels => $custom_levels,
}, $class;
$self->{env_prefix} = $args->{env_prefix}
or die 'no env_prefix passed to Log::Contextual::WarnLogger->new';
return $self;
}
sub _log {
my $self = shift;
my $level = shift;
my $message = join("\n", @_);
$message .= "\n" unless $message =~ /\n$/;
warn "[$level] $message";
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Log::Contextual::WarnLogger - logger for libraries using Log::Contextual
=head1 VERSION
version 0.006002
=head1 SYNOPSIS
package My::Package;
use Log::Contextual::WarnLogger;
use Log::Contextual qw( :log ),
-default_logger => Log::Contextual::WarnLogger->new({
env_prefix => 'MY_PACKAGE',
levels => [ qw(debug info notice warning error critical alert emergency) ],
});
# warns '[info] program started' if $ENV{MY_PACKAGE_TRACE} is set
log_info { 'program started' }; # no-op because info is not in levels
sub foo {
# warns '[debug] entered foo' if $ENV{MY_PACKAGE_DEBUG} is set
log_debug { 'entered foo' };
...
}
=head1 DESCRIPTION
This module is a simple logger made for libraries using L<Log::Contextual>. We
recommend the use of this logger as your default logger as it is simple and
useful for most users, yet users can use L<Log::Contextual/set_logger> to override
your choice of logger in their own code thanks to the way L<Log::Contextual>
works.
=head1 METHODS
=head2 new
Arguments: C<< Dict[ env_prefix => Str, levels => List ] $conf >>
my $l = Log::Contextual::WarnLogger->new({ env_prefix => 'BAR' });
or:
my $l = Log::Contextual::WarnLogger->new({
env_prefix => 'BAR',
levels => [ 'level1', 'level2' ],
});
Creates a new logger object where C<env_prefix> defines what the prefix is for
the environment variables that will be checked for the log levels.
The log levels may be customized, but if not defined, these are used:
=over 4
=item trace
=item debug
=item info
=item warn
=item error
=item fatal
=back
For example, if C<env_prefix> is set to C<FREWS_PACKAGE> the following environment
variables will be used:
FREWS_PACKAGE_UPTO
FREWS_PACKAGE_TRACE
FREWS_PACKAGE_DEBUG
FREWS_PACKAGE_INFO
FREWS_PACKAGE_WARN
FREWS_PACKAGE_ERROR
FREWS_PACKAGE_FATAL
Note that C<UPTO> is a convenience variable. If you set
C<< FOO_UPTO=TRACE >> it will enable all log levels. Similarly, if you
set it to C<FATAL> only fatal will be enabled.
=head2 $level
Arguments: C<@anything>
All of the following six methods work the same. The basic pattern is:
sub $level {
my $self = shift;
warn "[$level] " . join qq{\n}, @_;
if $self->is_$level;
}
=head3 trace
$l->trace( 'entered method foo with args ' join q{,}, @args );
=head3 debug
$l->debug( 'entered method foo' );
=head3 info
$l->info( 'started process foo' );
=head3 warn
$l->warn( 'possible misconfiguration at line 10' );
=head3 error
$l->error( 'non-numeric user input!' );
=head3 fatal
$l->fatal( '1 is never equal to 0!' );
If different levels are specified, appropriate functions named for your custom
levels work as you expect.
=head2 is_$level
All of the following six functions just return true if their respective
environment variable is enabled.
=head3 is_trace
say 'tracing' if $l->is_trace;
=head3 is_debug
say 'debuging' if $l->is_debug;
=head3 is_info
say q{info'ing} if $l->is_info;
=head3 is_warn
say 'warning' if $l->is_warn;
=head3 is_error
say 'erroring' if $l->is_error;
=head3 is_fatal
say q{fatal'ing} if $l->is_fatal;
If different levels are specified, appropriate is_$level functions work as you
would expect.
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
LOG_CONTEXTUAL_WARNLOGGER
$fatpacked{"MRO/Compat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MRO_COMPAT';
package MRO::Compat;
use strict;
use warnings;
require 5.006_000;
# Keep this < 1.00, so people can tell the fake
# mro.pm from the real one
our $VERSION = '0.12';
BEGIN {
# Alias our private functions over to
# the mro:: namespace and load
# Class::C3 if Perl < 5.9.5
if($] < 5.009_005) {
$mro::VERSION # to fool Module::Install when generating META.yml
= $VERSION;
$INC{'mro.pm'} = __FILE__;
*mro::import = \&__import;
*mro::get_linear_isa = \&__get_linear_isa;
*mro::set_mro = \&__set_mro;
*mro::get_mro = \&__get_mro;
*mro::get_isarev = \&__get_isarev;
*mro::is_universal = \&__is_universal;
*mro::method_changed_in = \&__method_changed_in;
*mro::invalidate_all_method_caches
= \&__invalidate_all_method_caches;
require Class::C3;
if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
*mro::get_pkg_gen = \&__get_pkg_gen_c3xs;
}
else {
*mro::get_pkg_gen = \&__get_pkg_gen_pp;
}
}
# Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
else {
require mro;
no warnings 'redefine';
*Class::C3::initialize = sub { 1 };
*Class::C3::reinitialize = sub { 1 };
*Class::C3::uninitialize = sub { 1 };
}
}
=head1 NAME
MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
=head1 SYNOPSIS
package PPP; use base qw/Exporter/;
package X; use base qw/PPP/;
package Y; use base qw/PPP/;
package Z; use base qw/PPP/;
package FooClass; use base qw/X Y Z/;
package main;
use MRO::Compat;
my $linear = mro::get_linear_isa('FooClass');
print join(q{, }, @$linear);
# Prints: FooClass, X, PPP, Exporter, Y, Z
=head1 DESCRIPTION
The "mro" namespace provides several utilities for dealing
with method resolution order and method caching in general
in Perl 5.9.5 and higher.
This module provides those interfaces for
earlier versions of Perl (back to 5.6.0 anyways).
It is a harmless no-op to use this module on 5.9.5+. That
is to say, code which properly uses L<MRO::Compat> will work
unmodified on both older Perls and 5.9.5+.
If you're writing a piece of software that would like to use
the parts of 5.9.5+'s mro:: interfaces that are supported
here, and you want compatibility with older Perls, this
is the module for you.
Some parts of this code will work better and/or faster with
L<Class::C3::XS> installed (which is an optional prereq
of L<Class::C3>, which is in turn a prereq of this
package), but it's not a requirement.
This module never exports any functions. All calls must
be fully qualified with the C<mro::> prefix.
The interface documentation here serves only as a quick
reference of what the function basically does, and what
differences between L<MRO::Compat> and 5.9.5+ one should
look out for. The main docs in 5.9.5's L<mro> are the real
interface docs, and contain a lot of other useful information.
=head1 Functions
=head2 mro::get_linear_isa($classname[, $type])
Returns an arrayref which is the linearized "ISA" of the given class.
Uses whichever MRO is currently in effect for that class by default,
or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
The linearized ISA of a class is a single ordered list of all of the
classes that would be visited in the process of resolving a method
on the given class, starting with itself. It does not include any
duplicate entries.
Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
part of the MRO of a class, even though all classes implicitly inherit
methods from C<UNIVERSAL> and its parents.
=cut
sub __get_linear_isa_dfs {
no strict 'refs';
my $classname = shift;
my @lin = ($classname);
my %stored;
foreach my $parent (@{"$classname\::ISA"}) {
my $plin = __get_linear_isa_dfs($parent);
foreach (@$plin) {
next if exists $stored{$_};
push(@lin, $_);
$stored{$_} = 1;
}
}
return \@lin;
}
sub __get_linear_isa {
my ($classname, $type) = @_;
die "mro::get_mro requires a classname" if !defined $classname;
$type ||= __get_mro($classname);
if($type eq 'dfs') {
return __get_linear_isa_dfs($classname);
}
elsif($type eq 'c3') {
return [Class::C3::calculateMRO($classname)];
}
die "type argument must be 'dfs' or 'c3'";
}
=head2 mro::import
This allows the C<use mro 'dfs'> and
C<use mro 'c3'> syntaxes, providing you
L<use MRO::Compat> first. Please see the
L</USING C3> section for additional details.
=cut
sub __import {
if($_[1]) {
goto &Class::C3::import if $_[1] eq 'c3';
__set_mro(scalar(caller), $_[1]);
}
}
=head2 mro::set_mro($classname, $type)
Sets the mro of C<$classname> to one of the types
C<dfs> or C<c3>. Please see the L</USING C3>
section for additional details.
=cut
sub __set_mro {
my ($classname, $type) = @_;
if(!defined $classname || !$type) {
die q{Usage: mro::set_mro($classname, $type)};
}
if($type eq 'c3') {
eval "package $classname; use Class::C3";
die $@ if $@;
}
elsif($type eq 'dfs') {
# In the dfs case, check whether we need to undo C3
if(defined $Class::C3::MRO{$classname}) {
Class::C3::_remove_method_dispatch_table($classname);
}
delete $Class::C3::MRO{$classname};
}
else {
die qq{Invalid mro type "$type"};
}
return;
}
=head2 mro::get_mro($classname)
Returns the MRO of the given class (either C<c3> or C<dfs>).
It considers any Class::C3-using class to have C3 MRO
even before L<Class::C3::initialize()> is called.
=cut
sub __get_mro {
my $classname = shift;
die "mro::get_mro requires a classname" if !defined $classname;
return 'c3' if exists $Class::C3::MRO{$classname};
return 'dfs';
}
=head2 mro::get_isarev($classname)
Returns an arrayref of classes who are subclasses of the
given classname. In other words, classes in whose @ISA
hierarchy we appear, no matter how indirectly.
This is much slower on pre-5.9.5 Perls with MRO::Compat
than it is on 5.9.5+, as it has to search the entire
package namespace.
=cut
sub __get_all_pkgs_with_isas {
no strict 'refs';
no warnings 'recursion';
my @retval;
my $search = shift;
my $pfx;
my $isa;
if(defined $search) {
$isa = \@{"$search\::ISA"};
$pfx = "$search\::";
}
else {
$search = 'main';
$isa = \@main::ISA;
$pfx = '';
}
push(@retval, $search) if scalar(@$isa);
foreach my $cand (keys %{"$search\::"}) {
if($cand =~ s/::$//) {
next if $cand eq $search; # skip self-reference (main?)
push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
}
}
return \@retval;
}
sub __get_isarev_recurse {
no strict 'refs';
my ($class, $all_isas, $level) = @_;
die "Recursive inheritance detected" if $level > 100;
my %retval;
foreach my $cand (@$all_isas) {
my $found_me;
foreach (@{"$cand\::ISA"}) {
if($_ eq $class) {
$found_me = 1;
last;
}
}
if($found_me) {
$retval{$cand} = 1;
map { $retval{$_} = 1 }
@{__get_isarev_recurse($cand, $all_isas, $level+1)};
}
}
return [keys %retval];
}
sub __get_isarev {
my $classname = shift;
die "mro::get_isarev requires a classname" if !defined $classname;
__get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
}
=head2 mro::is_universal($classname)
Returns a boolean status indicating whether or not
the given classname is either C<UNIVERSAL> itself,
or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
Any class for which this function returns true is
"universal" in the sense that all classes potentially
inherit methods from it.
=cut
sub __is_universal {
my $classname = shift;
die "mro::is_universal requires a classname" if !defined $classname;
my $lin = __get_linear_isa('UNIVERSAL');
foreach (@$lin) {
return 1 if $classname eq $_;
}
return 0;
}
=head2 mro::invalidate_all_method_caches
Increments C<PL_sub_generation>, which invalidates method
caching in all packages.
Please note that this is rarely necessary, unless you are
dealing with a situation which is known to confuse Perl's
method caching.
=cut
sub __invalidate_all_method_caches {
# Super secret mystery code :)
@f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
return;
}
=head2 mro::method_changed_in($classname)
Invalidates the method cache of any classes dependent on the
given class. In L<MRO::Compat> on pre-5.9.5 Perls, this is
an alias for C<mro::invalidate_all_method_caches> above, as
pre-5.9.5 Perls have no other way to do this. It will still
enforce the requirement that you pass it a classname, for
compatibility.
Please note that this is rarely necessary, unless you are
dealing with a situation which is known to confuse Perl's
method caching.
=cut
sub __method_changed_in {
my $classname = shift;
die "mro::method_changed_in requires a classname" if !defined $classname;
__invalidate_all_method_caches();
}
=head2 mro::get_pkg_gen($classname)
Returns an integer which is incremented every time a local
method of or the C<@ISA> of the given package changes on
Perl 5.9.5+. On earlier Perls with this L<MRO::Compat> module,
it will probably increment a lot more often than necessary.
=cut
{
my $__pkg_gen = 2;
sub __get_pkg_gen_pp {
my $classname = shift;
die "mro::get_pkg_gen requires a classname" if !defined $classname;
return $__pkg_gen++;
}
}
sub __get_pkg_gen_c3xs {
my $classname = shift;
die "mro::get_pkg_gen requires a classname" if !defined $classname;
return Class::C3::XS::_plsubgen();
}
=head1 USING C3
While this module makes the 5.9.5+ syntaxes
C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
on older Perls, it does so merely by passing off the work
to L<Class::C3>.
It does not remove the need for you to call
C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
C<Class::C3::uninitialize()> at the appropriate times
as documented in the L<Class::C3> docs. These three functions
are always provided by L<MRO::Compat>, either via L<Class::C3>
itself on older Perls, or directly as no-ops on 5.9.5+.
=head1 SEE ALSO
L<Class::C3>
L<mro>
=head1 AUTHOR
Brandon L. Black, E<lt>blblack@gmail.comE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
1;
MRO_COMPAT
$fatpacked{"Meta/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'META_BUILDER';
package Meta::Builder;
use strict;
use warnings;
use Carp qw/croak/;
use Meta::Builder::Util;
use Meta::Builder::Base;
our $VERSION = "0.003";
our @SUGAR = qw/metric action hash_metric lists_metric/;
our @HOOKS = qw/before after/;
our @METHODS = (( map { "add_$_" } @SUGAR ),
( map { "hook_$_" } @HOOKS ));
our @EXPORT = ( @SUGAR, @HOOKS, qw/make_immutable accessor/ );
our @REMOVABLE = ( @EXPORT, @METHODS );
for my $item ( @SUGAR ) {
my $wraps = "add_$item";
inject( __PACKAGE__, $item, sub {
caller->$wraps(@_)
});
}
for my $item ( @HOOKS ) {
my $wraps = "hook_$item";
inject( __PACKAGE__, $item, sub {
caller->$wraps(@_)
});
}
sub import {
my $class = shift;
my $caller = caller;
inject( $caller, $_, $class->can( $_ )) for @EXPORT;
no strict 'refs';
push @{"$caller\::ISA"} => 'Meta::Builder::Base';
}
sub make_immutable {
my $class = shift || caller;
for my $sub ( @REMOVABLE ) {
inject( $class, $sub, sub {
croak "$class has been made immutable, cannot call '$sub'"
}, 1 );
}
}
sub accessor {
my $class = caller;
$class->set_accessor( @_ );
}
1;
__END__
=head1 NAME
Meta::Builder - Tools for creating Meta objects to track custom metrics.
=head1 DESCRIPTION
Meta programming is becomming more and more popular. The popularity of Meta
programming comes from the fact that many problems are made significantly
easier. There are a few specialized Meta tools out there, for instance
L<Class:MOP> which is used by L<Moose> to track class metadata.
Meta::Builder is designed to be a generic tool for writing Meta objects. Unlike
specialized tools, Meta::Builder makes no assumptions about what metrics you
will care about. Meta::Builder also mkaes it simple for others to extend your
meta-object based tools by providing hooks for other packages to add metrics to
your meta object.
If a specialized Meta object tool is available ot meet your needs please use
it. However if you need a simple Meta object to track a couple metrics, use
Meta::Builder.
Meta::Builder is also low-sugar and low-dep. In most cases you will not want a
class that needs a meta object to use your meta-object class directly. Rather
you will usually want to create a sugar class that exports enhanced API
functions that manipulate the meta object.
=head1 SYNOPSIS
My/Meta.pm:
package My::Meta;
use strict;
use warnings;
use Meta::Builder;
# Name the accessor that will be defined in the class that uses the meta object
# It is used to retrieve the classes meta object.
accessor "mymeta";
# Add a metric with two actions
metric mymetric => sub { [] },
pop => sub {
my $self = shift;
my ( $data ) = @_;
pop @$data;
},
push => sub {
my $self = shift;
my ( $data, $metric, $action, @args ) = @_;
push @$data => @args;
};
# Add an additional action to the metric
action mymetric => ( get_ref => sub { shift });
# Add some predefined metric types + actions
hash_metric 'my_hashmetric';
lists_metric 'my_listsmetric';
My.pm:
package My;
use strict;
use warnings;
use My::Meta;
My::Meta->new( __PACKAGE__ );
# My::Meta defines mymeta() as the accessor we use to get our meta object.
# this is the ONLY way to get the meta object for this class.
mymeta()->mymetric_push( "some data" );
mymeta()->my_hashmetric_add( key => 'value' );
mymeta()->my_listsmetric_push( list => qw/valueA valueB/ );
# It works fine as an object/class method as well.
__PACKAGE__->mymeta->do_thing(...);
...;
=head1 USING
When you use Meta::Builder your class is automatically turned into a subclass
of L<Meta::Builder::Base>. In addition several "sugar" functions are exported
into your namespace. To avoid the "sugar" functions you can simply sublass
L<Meta::Builder::Base> directly.
=head1 EXPORTS
=over 4
=item metric( $name, \&generator, %actions )
Wraper around C<caller->add_metric()>. See L<Meta::Builder::Base>.
=item action( $metric, $name, $code )
Wraper around C<caller->add_action()>. See L<Meta::Builder::Base>.
=item hash_metric( $name, %additional_actions )
Wraper around C<caller->add_hash_metric()>. See L<Meta::Builder::Base>.
=item lists_metric( $name, %additional_actions )
Wraper around C<caller->add_lists_metric()>. See L<Meta::Builder::Base>.
=item before( $metric, $action, $code )
Wraper around C<caller->hook_before()>. See L<Meta::Builder::Base>.
=item after( $metric, $action, $code )
Wraper around C<caller->hook_after()>. See L<Meta::Builder::Base>.
=item accessor( $name )
Wraper around C<caller->set_accessor()>. See L<Meta::Builder::Base>.
=item make_immutable()
Overrides all functions/methods that alter the meta objects meta-data. This in
effect prevents anything from adding new metrics, actions, or hooks without
directly editing the metadata.
=back
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Meta-Builder is free software; Standard perl licence.
Meta-Builder is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the license for more details.
META_BUILDER
$fatpacked{"Meta/Builder/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'META_BUILDER_BASE';
package Meta::Builder::Base;
use strict;
use warnings;
use Meta::Builder::Util;
use Carp qw/croak carp/;
sub new {
my $class = shift;
my ( $package, %metrics ) = @_;
my $meta = $class->meta_meta;
my $self = bless( [ $package ], $class );
for my $metric ( keys %{ $meta->{metrics} }) {
my $idx = $meta->{metrics}->{$metric};
$self->[$idx] = $metrics{$metric}
|| $meta->{generators}->[$idx]->();
}
inject(
$package,
($meta->{accessor} || croak "$class does not have an accessor set."),
sub { $self }
);
$self->init( %metrics ) if $self->can( 'init' );
return $self;
}
sub meta_meta {
my $class = shift;
return $class->_meta_meta
if $class->can( '_meta_meta' );
my $meta = { index => 1 };
inject( $class, "_meta_meta", sub { $meta });
return $meta;
}
sub package { shift->[0] }
sub set_accessor {
my $class = shift;
($class->meta_meta->{accessor}) = @_;
}
sub add_hash_metric {
my $class = shift;
my ( $metric, %actions ) = @_;
$class->add_metric(
$metric,
\&gen_hash,
add => \&default_hash_add,
get => \&default_hash_get,
has => \&default_hash_has,
clear => \&default_hash_clear,
pull => \&default_hash_pull,
merge => \&default_hash_merge,
%actions,
);
}
sub add_lists_metric {
my $class = shift;
my ( $metric, %actions ) = @_;
$class->add_metric(
$metric,
\&gen_hash,
push => \&default_list_push,
get => \&default_list_get,
has => \&default_list_has,
clear => \&default_list_clear,
pull => \&default_list_pull,
merge => \&default_list_merge,
%actions,
);
}
sub add_metric {
my $class = shift;
my ( $metric, $generator, %actions ) = @_;
my $meta = $class->meta_meta;
my $index = $meta->{index}++;
croak "Already tracking metric '$metric'"
if $meta->{metrics}->{$metric};
$meta->{metrics}->{$metric} = $index;
$meta->{generators}->[$index] = $generator;
$meta->{indexes}->{$index} = $metric;
inject( $class, $metric, sub { shift->[$index] });
$class->add_action( $metric, %actions );
}
sub add_action {
my $class = shift;
my ( $metric, %actions ) = @_;
$class->_add_action( $metric, $_, $actions{ $_ })
for keys %actions;
}
sub _add_action {
my $class = shift;
my ( $metric, $action, $code ) = @_;
croak "You must specify a metric, an action name, and a coderef"
unless $metric && $action && $code;
my $meta = $class->meta_meta;
my $name = $class->action_method_name( $metric, $action );
inject( $class, $name, sub {
my $self = shift;
my $args = \@_;
$_->( $self, $self->$metric, $metric, $action, @$args )
for @{ $meta->{before}->{$name} || [] };
my @out = $code->( $self, $self->$metric, $metric, $action, @$args );
$_->( $self, $self->$metric, $metric, $action, @$args )
for @{ $meta->{after}->{$name} || [] };
return @out ? (@out > 1 ? @out : $out[0]) : ();
});
}
sub action_method_name {
my $class = shift;
my ( $metric, $action ) = @_;
return "$metric\_$action";
}
sub hook_before {
my $class = shift;
my ( $metric, $action, $code ) = @_;
my $name = $class->action_method_name( $metric, $action );
push @{ $class->meta_meta->{before}->{$name} } => $code;
}
sub hook_after {
my $class = shift;
my ( $metric, $action, $code ) = @_;
my $name = $class->action_method_name( $metric, $action );
push @{ $class->meta_meta->{after}->{$name} } => $code;
}
sub gen_hash { {} }
sub default_hash_add {
my $self = shift;
my ( $data, $metric, $action, $item, @value ) = @_;
my $name = $self->action_method_name( $metric, $action );
croak "$name() called without anything to add"
unless $item;
croak "$name('$item') called without a value to add"
unless @value;
croak "'$item' already added for metric $metric"
if $data->{$item};
($data->{$item}) = @value;
}
sub default_hash_get {
my $self = shift;
my ( $data, $metric, $action, $item ) = @_;
my $name = $self->action_method_name( $metric, $action );
croak "$name() called without anything to get"
unless $item;
# Prevent autovivication
return exists $data->{$item}
? $data->{$item}
: undef;
}
sub default_hash_has {
my $self = shift;
my ( $data, $metric, $action, $item ) = @_;
my $name = $self->action_method_name( $metric, $action );
croak "$name() called without anything to find"
unless $item;
return exists $data->{$item} ? 1 : 0;
}
sub default_hash_clear {
my $self = shift;
my ( $data, $metric, $action, $item ) = @_;
my $name = $self->action_method_name( $metric, $action );
croak "$name() called without anything to clear"
unless $item;
delete $data->{$item};
return 1;
}
sub default_hash_pull {
my $self = shift;
my ( $data, $metric, $action, $item ) = @_;
my $name = $self->action_method_name( $metric, $action );
croak "$name() called without anything to pull"
unless $item;
return delete $data->{$item};
}
sub default_hash_merge {
my $self = shift;
my ( $data, $metric, $action, $merge ) = @_;
for my $key ( keys %$merge ) {
croak "$key is defined for $metric in both meta-objects"
if $data->{$key};
$data->{$key} = $merge->{$key};
}
}
sub default_list_push {
my $self = shift;
my ( $data, $metric, $action, $item, @values ) = @_;
my $name = $self->action_method_name( $metric, $action );
croak "$name() called without an item to which data should be pushed"
unless $item;
croak "$name('$item') called without values to push"
unless @values;
push @{$data->{$item}} => @values;
}
sub default_list_get {
my $data = default_hash_get(@_);
return $data ? @$data : ();
}
sub default_list_has {
default_hash_has( @_ );
}
sub default_list_clear {
default_hash_clear( @_ );
}
sub default_list_pull {
my @out = default_list_get( @_ );
default_list_clear( @_ );
return @out;
}
sub default_list_merge {
my $self = shift;
my ( $data, $metric, $action, $merge ) = @_;
for my $key ( keys %$merge ) {
push @{ $data->{$key} } => @{ $merge->{$key} };
}
}
sub merge {
my $self = shift;
my ( $merge ) = @_;
for my $metric ( keys %{ $self->meta_meta->{ metrics }}) {
my $mergesub = $self->action_method_name( $metric, 'merge' );
unless( $self->can( $mergesub )) {
carp "Cannot merge metric '$metric', define a 'merge' action for it.";
next;
}
$self->$mergesub( $merge->$metric );
}
}
1;
__END__
=head1 NAME
Meta::Builder::Base - Base class for Meta::Builder Meta Objects.
=head1 DESCRIPTION
Base class for all L<Meta::Builder> Meta objects. This is where the methods
used to define new metrics and actions live. This class allows for the creation
of dynamic meta objects.
=head1 SYNOPSIS
My/Meta.pm:
package My::Meta;
use strict;
use warnings;
use base 'Meta::Builder::Base';
# Name the accessor that will be defined in the class that uses the meta object
# It is used to retrieve the classes meta object.
__PACKAGE__->set_accessor( "mymeta" );
# Add a metric with two actions
__PACKAGE__->add_metric(
mymetric => sub { [] },
pop => sub {
my $self = shift;
my ( $data ) = @_;
pop @$data;
},
push => sub {
my $self = shift;
my ( $data, $metric, $action, @args ) = @_;
push @$data => @args;
}
);
# Add an additional action to the metric
__PACKAGE__->add_action( 'mymetric', get_ref => sub { shift });
# Add some predefined metric types + actions
__PACKAGE__->add_hash_metric( 'my_hashmetric' );
__PACKAGE__->add_lists_metric( 'my_listsmetric' );
My.pm:
package My;
use strict;
use warnings;
use My::Meta;
My::Meta->new( __PACKAGE__ );
# My::Meta defines mymeta() as the accessor we use to get our meta object.
# this is the ONLY way to get the meta object for this class.
mymeta()->mymetric_push( "some data" );
mymeta()->my_hashmetric_add( key => 'value' );
mymeta()->my_listsmetric_push( list => qw/valueA valueB/ );
# It works fine as an object/class method as well.
__PACKAGE__->mymeta->do_thing(...);
...;
=head1 PACKAGE METRIC
Whenever you create a new instance of a meta-object you must provide the name
of the package to which the meta-object belongs. The 'package' metric will be
set to this package name, and can be retirved via the 'package' method:
C<$meta->package()>.
=head1 HASH METRICS
Hash metrics are metrics that hold key/value pairs. A hash metric is defined
using either the C<hash_metric()> function, or the C<$meta->add_hash_metric()>
method. The following actions are automatically defined for hash metrics:
=over 4
=item $meta->add_METRIC( $key, $value )
Add a key/value pair to the metric. Will throw an exception if the metric
already has a value for the specified key.
=item $value = $meta->get_METRIC( $key )
Get the value for a specified key.
=item $bool = $meta->has_METRIC( $key )
Check that the metric has the specified key defined.
=item $meta->clear_METRIC( $key )
Clear the specified key/value pair in the metric. (returns nothing)
=item $value = $meta->pull_METRIC( $key )
Get the value for the specified key, then clear the pair form the metric.
=back
=head1 LISTS METRICS
=over 4
=item $meta->push_METRIC( $key, @values )
Push values into the specified list for the given metric.
=item @values = $meta->get_METRIC( $key )
Get the values for a specified key.
=item $bool = $meta->has_METRIC( $key )
Check that the metric has the specified list.
=item $meta->clear_METRIC( $key )
Clear the specified list in the metric. (returns nothing)
=item @values = $meta->pull_METRIC( $key )
Get the values for the specified list in the metric, then clear the list.
=back
=head1 CLASS METHODS
=over 4
=item $meta = $class->new( $package, %metrics )
Create a new instance of the meta-class, and apply it to $package.
=item $metadata = $class->meta_meta()
Get the meta data for the meta-class itself. (The meta-class is build using
meta-data)
=item $new_hashref = $class->gen_hash()
Generate a new empty hashref.
=item $name = $class->action_method_name( $metric, $action )
Generate the name of the method for the given metric and action. Override this
if you do not like the METRIC_ACTION() method names.
=back
=head1 OBJECT METHODS
=over 4
=item $package = $meta->package()
Get the name of the package to which this meta-class applies.
=item $meta->set_accessor( $name )
Set the accessor that is used to retrieve the meta-object from the class to
which it applies.
=item $meta->add_hash_metric( $metric, %actions )
Add a hash metric (see L</"HASH METRICS">).
%actions should contain C<action =<gt> sub {...}> pairs for constructing
actions (See add_action()).
=item $meta->add_lists_metric( $metric, %actions )
Add a lists metric (see L</"LISTS METRICS">)
%actions should contain C<action =<gt> sub {...}> pairs for constructing
actions (See add_action()).
=item $meta->add_metric( $metric, \&generator, %actions )
Add a custom metric. The second argument should be a sub that generates a
default value for the metric.
%actions should contain C<action =<gt> sub {...}> pairs for constructing
actions (See add_action()).
=item $meta->add_action( $metric, $action => sub { ... } )
Add an action for the specified metric. See L</"ACTION AND HOOK METHODS"> for
details on how to write an action coderef.
=item $meta->hook_before( $metric, $action, sub { ... })
Add a hook for the specified metric. See L</"ACTION AND HOOK METHODS"> for
details on how to write a hook coderef.
=item $meta->hook_after( $metric, $action, sub { ... })
Add a hook for the specified metric. See L</"ACTION AND HOOK METHODS"> for
details on how to write a hook coderef.
=back
=head1 ACTION AND HOOK METHODS
sub {
my $self = shift;
my ( $data, $metric, $action, @args ) = @_;
...;
}
Action and hook methods are called when someone calls
C<$meta-<gt>metric_action(...)>. First all before hooks will be called, the the
action itself, and finally the after hooks will be called. All methods in the
chain get the exact same unaltered arguments. Only the main action sub can
return anything.
Arguments are:
=over 4
=item 0: $self
These are methods, so the first argument is the meta object itself.
=item 1: $data
This is the data structure stored for the metric. This is the same as calling
$meta->metric()
=item 2: $metric
Name of the metric
=item 3: $action
Name of the action
=item 4+: @args
Arguments that metric_action() was called with.
=back
=head1 DEFAULT ACTION METHODS
There are the default action methods used by hashmetrics and listsmetrics.
=over 4
=item $meta->default_hash_add( $data, $metric, $action, $item, $value )
=item $value = $meta->default_hash_get( $data, $metric, $action, $item )
=item $bool = $meta->default_hash_has( $data, $metric, $action, $item )
=item $meta->default_hash_clear( $data, $metric, $action, $item )
=item $value = $meta->default_hash_pull( $data, $metric, $action, $item )
=item $meta->default_list_push( $data, $metric, $action, $item, @values )
=item @values = $meta->default_list_get( $data, $metric, $action, $item )
=item $bool = $meta->default_list_has( $data, $metric, $action, $item )
=item $meta->default_list_clear( $data, $metric, $action, $item )
=item @values = $meta->default_list_pull( $data, $metric, $action, $item )
=back
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Meta-Builder is free software; Standard perl licence.
Meta-Builder is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the license for more details.
META_BUILDER_BASE
$fatpacked{"Meta/Builder/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'META_BUILDER_UTIL';
package Meta::Builder::Util;
use strict;
use warnings;
sub import {
my $class = shift;
my $caller = caller;
inject( $caller, "inject", \&inject );
}
sub inject {
my ( $class, $sub, $code, $nowarn ) = @_;
if ( $nowarn ) {
no strict 'refs';
no warnings 'redefine';
*{"$class\::$sub"} = $code;
}
else {
no strict 'refs';
*{"$class\::$sub"} = $code;
}
}
1;
__END__
=head1 NAME
Meta::Builder::Util - Utility functions for Meta::Builder
=head1 EXPORTS
=over 4
=item inject( $class, $name, $code, $redefine )
used to inject a sub into a namespace.
=back
=head1 AUTHORS
Chad Granum L<exodist7@gmail.com>
=head1 COPYRIGHT
Copyright (C) 2010 Chad Granum
Meta-Builder is free software; Standard perl licence.
Meta-Builder is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the license for more details.
META_BUILDER_UTIL
$fatpacked{"Method/Generate/Accessor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_ACCESSOR';
package Method::Generate::Accessor;
use Moo::_strictures;
use Moo::_Utils;
use Moo::Object ();
our @ISA = qw(Moo::Object);
use Sub::Quote qw(quote_sub quoted_from_sub quotify);
use Scalar::Util 'blessed';
use overload ();
use Module::Runtime qw(use_module);
BEGIN {
our $CAN_HAZ_XS =
!$ENV{MOO_XS_DISABLE}
&&
_maybe_load_module('Class::XSAccessor')
&&
(eval { Class::XSAccessor->VERSION('1.07') })
;
our $CAN_HAZ_XS_PRED =
$CAN_HAZ_XS &&
(eval { Class::XSAccessor->VERSION('1.17') })
;
}
my $module_name_only = qr/\A$Module::Runtime::module_name_rx\z/;
sub _die_overwrite
{
my ($pkg, $method, $type) = @_;
die "You cannot overwrite a locally defined method ($method) with "
. ( $type || 'an accessor' );
}
sub generate_method {
my ($self, $into, $name, $spec, $quote_opts) = @_;
$spec->{allow_overwrite}++ if $name =~ s/^\+//;
die "Must have an is" unless my $is = $spec->{is};
if ($is eq 'ro') {
$spec->{reader} = $name unless exists $spec->{reader};
} elsif ($is eq 'rw') {
$spec->{accessor} = $name unless exists $spec->{accessor}
or ( $spec->{reader} and $spec->{writer} );
} elsif ($is eq 'lazy') {
$spec->{reader} = $name unless exists $spec->{reader};
$spec->{lazy} = 1;
$spec->{builder} ||= '_build_'.$name unless exists $spec->{default};
} elsif ($is eq 'rwp') {
$spec->{reader} = $name unless exists $spec->{reader};
$spec->{writer} = "_set_${name}" unless exists $spec->{writer};
} elsif ($is ne 'bare') {
die "Unknown is ${is}";
}
if (exists $spec->{builder}) {
if(ref $spec->{builder}) {
$self->_validate_codulatable('builder', $spec->{builder},
"$into->$name", 'or a method name');
$spec->{builder_sub} = $spec->{builder};
$spec->{builder} = 1;
}
$spec->{builder} = '_build_'.$name if ($spec->{builder}||0) eq 1;
die "Invalid builder for $into->$name - not a valid method name"
if $spec->{builder} !~ $module_name_only;
}
if (($spec->{predicate}||0) eq 1) {
$spec->{predicate} = $name =~ /^_/ ? "_has${name}" : "has_${name}";
}
if (($spec->{clearer}||0) eq 1) {
$spec->{clearer} = $name =~ /^_/ ? "_clear${name}" : "clear_${name}";
}
if (($spec->{trigger}||0) eq 1) {
$spec->{trigger} = quote_sub('shift->_trigger_'.$name.'(@_)');
}
if (($spec->{coerce}||0) eq 1) {
my $isa = $spec->{isa};
if (blessed $isa and $isa->can('coercion')) {
$spec->{coerce} = $isa->coercion;
} elsif (blessed $isa and $isa->can('coerce')) {
$spec->{coerce} = sub { $isa->coerce(@_) };
} else {
die "Invalid coercion for $into->$name - no appropriate type constraint";
}
}
foreach my $setting (qw( isa coerce )) {
next if !exists $spec->{$setting};
$self->_validate_codulatable($setting, $spec->{$setting}, "$into->$name");
}
if (exists $spec->{default}) {
if (ref $spec->{default}) {
$self->_validate_codulatable('default', $spec->{default}, "$into->$name",
'or a non-ref');
}
}
if (exists $spec->{moosify}) {
if (ref $spec->{moosify} ne 'ARRAY') {
$spec->{moosify} = [$spec->{moosify}];
}
foreach my $spec (@{$spec->{moosify}}) {
$self->_validate_codulatable('moosify', $spec, "$into->$name");
}
}
my %methods;
if (my $reader = $spec->{reader}) {
_die_overwrite($into, $reader, 'a reader')
if !$spec->{allow_overwrite} && defined &{"${into}::${reader}"};
if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
$methods{$reader} = $self->_generate_xs(
getters => $into, $reader, $name, $spec
);
} else {
$self->{captures} = {};
$methods{$reader} =
quote_sub "${into}::${reader}"
=> ' die "'.$reader.' is a read-only accessor" if @_ > 1;'."\n"
.$self->_generate_get($name, $spec)
=> delete $self->{captures}
;
}
}
if (my $accessor = $spec->{accessor}) {
_die_overwrite($into, $accessor, 'an accessor')
if !$spec->{allow_overwrite} && defined &{"${into}::${accessor}"};
if (
our $CAN_HAZ_XS
&& $self->is_simple_get($name, $spec)
&& $self->is_simple_set($name, $spec)
) {
$methods{$accessor} = $self->_generate_xs(
accessors => $into, $accessor, $name, $spec
);
} else {
$self->{captures} = {};
$methods{$accessor} =
quote_sub "${into}::${accessor}"
=> $self->_generate_getset($name, $spec)
=> delete $self->{captures}
;
}
}
if (my $writer = $spec->{writer}) {
_die_overwrite($into, $writer, 'a writer')
if !$spec->{allow_overwrite} && defined &{"${into}::${writer}"};
if (
our $CAN_HAZ_XS
&& $self->is_simple_set($name, $spec)
) {
$methods{$writer} = $self->_generate_xs(
setters => $into, $writer, $name, $spec
);
} else {
$self->{captures} = {};
$methods{$writer} =
quote_sub "${into}::${writer}"
=> $self->_generate_set($name, $spec)
=> delete $self->{captures}
;
}
}
if (my $pred = $spec->{predicate}) {
_die_overwrite($into, $pred, 'a predicate')
if !$spec->{allow_overwrite} && defined &{"${into}::${pred}"};
if (our $CAN_HAZ_XS && our $CAN_HAZ_XS_PRED) {
$methods{$pred} = $self->_generate_xs(
exists_predicates => $into, $pred, $name, $spec
);
} else {
$methods{$pred} =
quote_sub "${into}::${pred}" =>
' '.$self->_generate_simple_has('$_[0]', $name, $spec)."\n"
;
}
}
if (my $pred = $spec->{builder_sub}) {
_install_coderef( "${into}::$spec->{builder}" => $spec->{builder_sub} );
}
if (my $cl = $spec->{clearer}) {
_die_overwrite($into, $cl, 'a clearer')
if !$spec->{allow_overwrite} && defined &{"${into}::${cl}"};
$methods{$cl} =
quote_sub "${into}::${cl}" =>
$self->_generate_simple_clear('$_[0]', $name, $spec)."\n"
;
}
if (my $hspec = $spec->{handles}) {
my $asserter = $spec->{asserter} ||= '_assert_'.$name;
my @specs = do {
if (ref($hspec) eq 'ARRAY') {
map [ $_ => $_ ], @$hspec;
} elsif (ref($hspec) eq 'HASH') {
map [ $_ => ref($hspec->{$_}) ? @{$hspec->{$_}} : $hspec->{$_} ],
keys %$hspec;
} elsif (!ref($hspec)) {
map [ $_ => $_ ], use_module('Moo::Role')->methods_provided_by(use_module($hspec))
} else {
die "You gave me a handles of ${hspec} and I have no idea why";
}
};
foreach my $delegation_spec (@specs) {
my ($proxy, $target, @args) = @$delegation_spec;
_die_overwrite($into, $proxy, 'a delegation')
if !$spec->{allow_overwrite} && defined &{"${into}::${proxy}"};
$self->{captures} = {};
$methods{$proxy} =
quote_sub "${into}::${proxy}" =>
$self->_generate_delegation($asserter, $target, \@args),
delete $self->{captures}
;
}
}
if (my $asserter = $spec->{asserter}) {
$self->{captures} = {};
$methods{$asserter} =
quote_sub "${into}::${asserter}" =>
$self->_generate_asserter($name, $spec),
delete $self->{captures};
}
\%methods;
}
sub is_simple_attribute {
my ($self, $name, $spec) = @_;
# clearer doesn't have to be listed because it doesn't
# affect whether defined/exists makes a difference
!grep $spec->{$_},
qw(lazy default builder coerce isa trigger predicate weak_ref);
}
sub is_simple_get {
my ($self, $name, $spec) = @_;
!($spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
}
sub is_simple_set {
my ($self, $name, $spec) = @_;
!grep $spec->{$_}, qw(coerce isa trigger weak_ref);
}
sub has_default {
my ($self, $name, $spec) = @_;
$spec->{builder} or exists $spec->{default} or (($spec->{is}||'') eq 'lazy');
}
sub has_eager_default {
my ($self, $name, $spec) = @_;
(!$spec->{lazy} and (exists $spec->{default} or $spec->{builder}));
}
sub _generate_get {
my ($self, $name, $spec) = @_;
my $simple = $self->_generate_simple_get('$_[0]', $name, $spec);
if ($self->is_simple_get($name, $spec)) {
$simple;
} else {
$self->_generate_use_default(
'$_[0]', $name, $spec,
$self->_generate_simple_has('$_[0]', $name, $spec),
);
}
}
sub generate_simple_has {
my $self = shift;
$self->{captures} = {};
my $code = $self->_generate_simple_has(@_);
($code, delete $self->{captures});
}
sub _generate_simple_has {
my ($self, $me, $name) = @_;
"exists ${me}->{${\quotify $name}}";
}
sub _generate_simple_clear {
my ($self, $me, $name) = @_;
" delete ${me}->{${\quotify $name}}\n"
}
sub generate_get_default {
my $self = shift;
$self->{captures} = {};
my $code = $self->_generate_get_default(@_);
($code, delete $self->{captures});
}
sub generate_use_default {
my $self = shift;
$self->{captures} = {};
my $code = $self->_generate_use_default(@_);
($code, delete $self->{captures});
}
sub _generate_use_default {
my ($self, $me, $name, $spec, $test) = @_;
my $get_value = $self->_generate_get_default($me, $name, $spec);
if ($spec->{coerce}) {
$get_value = $self->_generate_coerce(
$name, $get_value,
$spec->{coerce}
)
}
$test." ? \n"
.$self->_generate_simple_get($me, $name, $spec)."\n:"
.($spec->{isa} ?
" do {\n my \$value = ".$get_value.";\n"
." ".$self->_generate_isa_check($name, '$value', $spec->{isa}).";\n"
." ".$self->_generate_simple_set($me, $name, $spec, '$value')."\n"
." }\n"
: ' ('.$self->_generate_simple_set($me, $name, $spec, $get_value).")\n"
);
}
sub _generate_get_default {
my ($self, $me, $name, $spec) = @_;
if (exists $spec->{default}) {
ref $spec->{default}
? $self->_generate_call_code($name, 'default', $me, $spec->{default})
: quotify $spec->{default};
}
else {
"${me}->${\$spec->{builder}}"
}
}
sub generate_simple_get {
my ($self, @args) = @_;
$self->{captures} = {};
my $code = $self->_generate_simple_get(@args);
($code, delete $self->{captures});
}
sub _generate_simple_get {
my ($self, $me, $name) = @_;
my $name_str = quotify $name;
"${me}->{${name_str}}";
}
sub _generate_set {
my ($self, $name, $spec) = @_;
if ($self->is_simple_set($name, $spec)) {
$self->_generate_simple_set('$_[0]', $name, $spec, '$_[1]');
} else {
my ($coerce, $trigger, $isa_check) = @{$spec}{qw(coerce trigger isa)};
my $value_store = '$_[0]';
my $code;
if ($coerce) {
$value_store = '$value';
$code = "do { my (\$self, \$value) = \@_;\n"
." \$value = "
.$self->_generate_coerce($name, $value_store, $coerce).";\n";
}
else {
$code = "do { my \$self = shift;\n";
}
if ($isa_check) {
$code .=
" ".$self->_generate_isa_check($name, $value_store, $isa_check).";\n";
}
my $simple = $self->_generate_simple_set('$self', $name, $spec, $value_store);
if ($trigger) {
my $fire = $self->_generate_trigger($name, '$self', $value_store, $trigger);
$code .=
" ".$simple.";\n ".$fire.";\n"
." $value_store;\n";
} else {
$code .= " ".$simple.";\n";
}
$code .= " }";
$code;
}
}
sub generate_coerce {
my $self = shift;
$self->{captures} = {};
my $code = $self->_generate_coerce(@_);
($code, delete $self->{captures});
}
sub _attr_desc {
my ($name, $init_arg) = @_;
return quotify($name) if !defined($init_arg) or $init_arg eq $name;
return quotify($name).' (constructor argument: '.quotify($init_arg).')';
}
sub _generate_coerce {
my ($self, $name, $value, $coerce, $init_arg) = @_;
$self->_wrap_attr_exception(
$name,
"coercion",
$init_arg,
$self->_generate_call_code($name, 'coerce', "${value}", $coerce),
1,
);
}
sub generate_trigger {
my $self = shift;
$self->{captures} = {};
my $code = $self->_generate_trigger(@_);
($code, delete $self->{captures});
}
sub _generate_trigger {
my ($self, $name, $obj, $value, $trigger) = @_;
$self->_generate_call_code($name, 'trigger', "${obj}, ${value}", $trigger);
}
sub generate_isa_check {
my ($self, @args) = @_;
$self->{captures} = {};
my $code = $self->_generate_isa_check(@args);
($code, delete $self->{captures});
}
sub _wrap_attr_exception {
my ($self, $name, $step, $arg, $code, $want_return) = @_;
my $prefix = quotify("${step} for "._attr_desc($name, $arg).' failed: ');
"do {\n"
.' local $Method::Generate::Accessor::CurrentAttribute = {'."\n"
.' init_arg => '.quotify($arg).",\n"
.' name => '.quotify($name).",\n"
.' step => '.quotify($step).",\n"
." };\n"
.($want_return ? ' my $_return;'."\n" : '')
.' my $_error;'."\n"
." {\n"
.' my $_old_error = $@;'."\n"
." if (!eval {\n"
.' $@ = $_old_error;'."\n"
.($want_return ? ' $_return ='."\n" : '')
.' '.$code.";\n"
." 1;\n"
." }) {\n"
.' $_error = $@;'."\n"
.' if (!ref $_error) {'."\n"
.' $_error = '.$prefix.'.$_error;'."\n"
." }\n"
." }\n"
.' $@ = $_old_error;'."\n"
." }\n"
.' die $_error if $_error;'."\n"
.($want_return ? ' $_return;'."\n" : '')
."}\n"
}
sub _generate_isa_check {
my ($self, $name, $value, $check, $init_arg) = @_;
$self->_wrap_attr_exception(
$name,
"isa check",
$init_arg,
$self->_generate_call_code($name, 'isa_check', $value, $check)
);
}
sub _generate_call_code {
my ($self, $name, $type, $values, $sub) = @_;
$sub = \&{$sub} if blessed($sub); # coderef if blessed
if (my $quoted = quoted_from_sub($sub)) {
my $local = 1;
if ($values eq '@_' || $values eq '$_[0]') {
$local = 0;
$values = '@_';
}
my $code = $quoted->[1];
if (my $captures = $quoted->[2]) {
my $cap_name = qq{\$${type}_captures_for_}.$self->_sanitize_name($name);
$self->{captures}->{$cap_name} = \$captures;
Sub::Quote::inlinify($code, $values,
Sub::Quote::capture_unroll($cap_name, $captures, 6), $local);
} else {
Sub::Quote::inlinify($code, $values, undef, $local);
}
} else {
my $cap_name = qq{\$${type}_for_}.$self->_sanitize_name($name);
$self->{captures}->{$cap_name} = \$sub;
"${cap_name}->(${values})";
}
}
sub _sanitize_name {
my ($self, $name) = @_;
$name =~ s/([_\W])/sprintf('_%x', ord($1))/ge;
$name;
}
sub generate_populate_set {
my $self = shift;
$self->{captures} = {};
my $code = $self->_generate_populate_set(@_);
($code, delete $self->{captures});
}
sub _generate_populate_set {
my ($self, $me, $name, $spec, $source, $test, $init_arg) = @_;
if ($self->has_eager_default($name, $spec)) {
my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
my $get_default = $self->_generate_get_default(
'$new', $name, $spec
);
my $get_value =
defined($spec->{init_arg})
? "(\n${get_indent} ${test}\n"
."${get_indent} ? ${source}\n${get_indent} : "
.$get_default
."\n${get_indent})"
: $get_default;
if ($spec->{coerce}) {
$get_value = $self->_generate_coerce(
$name, $get_value,
$spec->{coerce}, $init_arg
)
}
($spec->{isa}
? " {\n my \$value = ".$get_value.";\n "
.$self->_generate_isa_check(
$name, '$value', $spec->{isa}, $init_arg
).";\n"
.' '.$self->_generate_simple_set($me, $name, $spec, '$value').";\n"
." }\n"
: ' '.$self->_generate_simple_set($me, $name, $spec, $get_value).";\n"
)
.($spec->{trigger}
? ' '
.$self->_generate_trigger(
$name, $me, $self->_generate_simple_get($me, $name, $spec),
$spec->{trigger}
)." if ${test};\n"
: ''
);
} else {
" if (${test}) {\n"
.($spec->{coerce}
? " $source = "
.$self->_generate_coerce(
$name, $source,
$spec->{coerce}, $init_arg
).";\n"
: ""
)
.($spec->{isa}
? " "
.$self->_generate_isa_check(
$name, $source, $spec->{isa}, $init_arg
).";\n"
: ""
)
." ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
.($spec->{trigger}
? " "
.$self->_generate_trigger(
$name, $me, $self->_generate_simple_get($me, $name, $spec),
$spec->{trigger}
).";\n"
: ""
)
." }\n";
}
}
sub _generate_core_set {
my ($self, $me, $name, $spec, $value) = @_;
my $name_str = quotify $name;
"${me}->{${name_str}} = ${value}";
}
sub _generate_simple_set {
my ($self, $me, $name, $spec, $value) = @_;
my $name_str = quotify $name;
my $simple = $self->_generate_core_set($me, $name, $spec, $value);
if ($spec->{weak_ref}) {
require Scalar::Util;
my $get = $self->_generate_simple_get($me, $name, $spec);
# Perl < 5.8.3 can't weaken refs to readonly vars
# (e.g. string constants). This *can* be solved by:
#
# &Internals::SvREADONLY($foo, 0);
# Scalar::Util::weaken($foo);
# &Internals::SvREADONLY($foo, 1);
#
# but requires Internal functions and is just too damn crazy
# so simply throw a better exception
my $weak_simple = "do { Scalar::Util::weaken(${simple}); no warnings 'void'; $get }";
Moo::_Utils::lt_5_8_3() ? <<"EOC" : $weak_simple;
eval { Scalar::Util::weaken($simple); 1 }
? do { no warnings 'void'; $get }
: do {
if( \$@ =~ /Modification of a read-only value attempted/) {
require Carp;
Carp::croak( sprintf (
'Reference to readonly value in "%s" can not be weakened on Perl < 5.8.3',
$name_str,
) );
} else {
die \$@;
}
}
EOC
} else {
$simple;
}
}
sub _generate_getset {
my ($self, $name, $spec) = @_;
q{(@_ > 1}."\n ? ".$self->_generate_set($name, $spec)
."\n : ".$self->_generate_get($name, $spec)."\n )";
}
sub _generate_asserter {
my ($self, $name, $spec) = @_;
"do {\n"
." my \$val = ".$self->_generate_get($name, $spec).";\n"
." unless (".$self->_generate_simple_has('$_[0]', $name, $spec).") {\n"
.qq! die "Attempted to access '${name}' but it is not set";\n!
." }\n"
." \$val;\n"
."}\n";
}
sub _generate_delegation {
my ($self, $asserter, $target, $args) = @_;
my $arg_string = do {
if (@$args) {
# I could, I reckon, linearise out non-refs here using quotify
# plus something to check for numbers but I'm unsure if it's worth it
$self->{captures}{'@curries'} = $args;
'@curries, @_';
} else {
'@_';
}
};
"shift->${asserter}->${target}(${arg_string});";
}
sub _generate_xs {
my ($self, $type, $into, $name, $slot) = @_;
Class::XSAccessor->import(
class => $into,
$type => { $name => $slot },
replace => 1,
);
$into->can($name);
}
sub default_construction_string { '{}' }
sub _validate_codulatable {
my ($self, $setting, $value, $into, $appended) = @_;
my $invalid = "Invalid $setting '" . overload::StrVal($value)
. "' for $into not a coderef";
$invalid .= " $appended" if $appended;
unless (ref $value and (ref $value eq 'CODE' or blessed($value))) {
die "$invalid or code-convertible object";
}
unless (eval { \&$value }) {
die "$invalid and could not be converted to a coderef: $@";
}
1;
}
1;
METHOD_GENERATE_ACCESSOR
$fatpacked{"Method/Generate/BuildAll.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_BUILDALL';
package Method::Generate::BuildAll;
use Moo::_strictures;
use Moo::Object ();
our @ISA = qw(Moo::Object);
use Sub::Quote qw(quote_sub quotify);
use Moo::_Utils;
sub generate_method {
my ($self, $into) = @_;
quote_sub "${into}::BUILDALL", join '',
$self->_handle_subbuild($into),
qq{ my \$self = shift;\n},
$self->buildall_body_for($into, '$self', '@_'),
qq{ return \$self\n};
}
sub _handle_subbuild {
my ($self, $into) = @_;
' if (ref($_[0]) ne '.quotify($into).') {'."\n".
' return shift->Moo::Object::BUILDALL(@_)'.";\n".
' }'."\n";
}
sub buildall_body_for {
my ($self, $into, $me, $args) = @_;
my @builds =
grep *{_getglob($_)}{CODE},
map "${_}::BUILD",
reverse @{mro::get_linear_isa($into)};
' unless (('.$args.')[0]->{__no_BUILD__}) {'."\n"
.join('', map qq{ ${me}->${_}(${args});\n}, @builds)
." }\n";
}
1;
METHOD_GENERATE_BUILDALL
$fatpacked{"Method/Generate/Constructor.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_CONSTRUCTOR';
package Method::Generate::Constructor;
use Moo::_strictures;
use Sub::Quote qw(quote_sub unquote_sub quotify);
use Sub::Defer;
use Moo::_Utils qw(_getstash _getglob);
use Moo;
sub register_attribute_specs {
my ($self, @new_specs) = @_;
$self->assert_constructor;
my $specs = $self->{attribute_specs}||={};
while (my ($name, $new_spec) = splice @new_specs, 0, 2) {
if ($name =~ s/^\+//) {
die "has '+${name}' given but no ${name} attribute already exists"
unless my $old_spec = $specs->{$name};
foreach my $key (keys %$old_spec) {
if (!exists $new_spec->{$key}) {
$new_spec->{$key} = $old_spec->{$key}
unless $key eq 'handles';
}
elsif ($key eq 'moosify') {
$new_spec->{$key} = [
map { ref $_ eq 'ARRAY' ? @$_ : $_ }
($old_spec->{$key}, $new_spec->{$key})
];
}
}
}
if ($new_spec->{required}
&& !(
$self->accessor_generator->has_default($name, $new_spec)
|| !exists $new_spec->{init_arg}
|| defined $new_spec->{init_arg}
)
) {
die "You cannot have a required attribute (${name})"
. " without a default, builder, or an init_arg";
}
$new_spec->{index} = scalar keys %$specs
unless defined $new_spec->{index};
$specs->{$name} = $new_spec;
}
$self;
}
sub all_attribute_specs {
$_[0]->{attribute_specs}
}
sub accessor_generator {
$_[0]->{accessor_generator}
}
sub construction_string {
my ($self) = @_;
$self->{construction_string}
||= $self->_build_construction_string;
}
sub buildall_generator {
require Method::Generate::BuildAll;
Method::Generate::BuildAll->new;
}
sub _build_construction_string {
my ($self) = @_;
my $builder = $self->{construction_builder};
$builder ? $self->$builder
: 'bless('
.$self->accessor_generator->default_construction_string
.', $class);'
}
sub install_delayed {
my ($self) = @_;
$self->assert_constructor;
my $package = $self->{package};
my (undef, @isa) = @{mro::get_linear_isa($package)};
my $isa = join ',', @isa;
$self->{deferred_constructor} = defer_sub "${package}::new" => sub {
my (undef, @new_isa) = @{mro::get_linear_isa($package)};
if (join(',', @new_isa) ne $isa) {
my ($expected_new) = grep { *{_getglob($_.'::new')}{CODE} } @isa;
my ($found_new) = grep { *{_getglob($_.'::new')}{CODE} } @new_isa;
if (($found_new||'') ne ($expected_new||'')) {
$found_new ||= 'none';
$expected_new ||= 'none';
die "Expected parent constructor of $package expected to be"
. " $expected_new, but found $found_new: changing the inheritance"
. " chain (\@ISA) at runtime is unsupported";
}
}
unquote_sub $self->generate_method(
$package, 'new', $self->{attribute_specs}, { no_install => 1 }
)
};
$self;
}
sub current_constructor {
my ($self, $package) = @_;
return *{_getglob("${package}::new")}{CODE};
}
sub assert_constructor {
my ($self) = @_;
my $package = $self->{package} or return 1;
my $current = $self->current_constructor($package)
or return 1;
my $deferred = $self->{deferred_constructor}
or die "Unknown constructor for $package already exists";
return 1
if $deferred == $current;
my $current_deferred = (Sub::Defer::defer_info($current)||[])->[3];
if ($current_deferred && $current_deferred == $deferred) {
die "Constructor for $package has been inlined and cannot be updated";
}
die "Constructor for $package has been replaced with an unknown sub";
}
sub generate_method {
my ($self, $into, $name, $spec, $quote_opts) = @_;
foreach my $no_init (grep !exists($spec->{$_}{init_arg}), keys %$spec) {
$spec->{$no_init}{init_arg} = $no_init;
}
local $self->{captures} = {};
my $body = ' my $class = shift;'."\n"
.' $class = ref($class) if ref($class);'."\n";
$body .= $self->_handle_subconstructor($into, $name);
my $into_buildargs = $into->can('BUILDARGS');
if ( $into_buildargs && $into_buildargs != \&Moo::Object::BUILDARGS ) {
$body .= $self->_generate_args_via_buildargs;
} else {
$body .= $self->_generate_args;
}
$body .= $self->_check_required($spec);
$body .= ' my $new = '.$self->construction_string.";\n";
$body .= $self->_assign_new($spec);
if ($into->can('BUILD')) {
$body .= $self->buildall_generator->buildall_body_for(
$into, '$new', '$args'
);
}
$body .= ' return $new;'."\n";
if ($into->can('DEMOLISH')) {
require Method::Generate::DemolishAll;
Method::Generate::DemolishAll->new->generate_method($into);
}
quote_sub
"${into}::${name}" => $body,
$self->{captures}, $quote_opts||{}
;
}
sub _handle_subconstructor {
my ($self, $into, $name) = @_;
if (my $gen = $self->{subconstructor_handler}) {
' if ($class ne '.quotify($into).') {'."\n".
$gen.
' }'."\n";
} else {
''
}
}
sub _cap_call {
my ($self, $code, $captures) = @_;
@{$self->{captures}}{keys %$captures} = values %$captures if $captures;
$code;
}
sub _generate_args_via_buildargs {
my ($self) = @_;
q{ my $args = $class->BUILDARGS(@_);}."\n"
.q{ die "BUILDARGS did not return a hashref" unless ref($args) eq 'HASH';}
."\n";
}
# inlined from Moo::Object - update that first.
sub _generate_args {
my ($self) = @_;
return <<'_EOA';
my $args;
if ( scalar @_ == 1 ) {
unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
die "Single parameters to new() must be a HASH ref"
." data => ". $_[0] ."\n";
}
$args = { %{ $_[0] } };
}
elsif ( @_ % 2 ) {
die "The new() method for $class expects a hash reference or a"
. " key/value list. You passed an odd number of arguments\n";
}
else {
$args = {@_};
}
_EOA
}
sub _assign_new {
my ($self, $spec) = @_;
my $ag = $self->accessor_generator;
my %test;
NAME: foreach my $name (sort keys %$spec) {
my $attr_spec = $spec->{$name};
next NAME unless defined($attr_spec->{init_arg})
or $ag->has_eager_default($name, $attr_spec);
$test{$name} = $attr_spec->{init_arg};
}
join '', map {
my $arg_key = quotify($test{$_});
my $test = "exists \$args->{$arg_key}";
my $source = "\$args->{$arg_key}";
my $attr_spec = $spec->{$_};
$self->_cap_call($ag->generate_populate_set(
'$new', $_, $attr_spec, $source, $test, $test{$_},
));
} sort keys %test;
}
sub _check_required {
my ($self, $spec) = @_;
my @required_init =
map $spec->{$_}{init_arg},
grep {
my %s = %{$spec->{$_}}; # ignore required if default or builder set
$s{required} and not($s{builder} or exists $s{default})
} sort keys %$spec;
return '' unless @required_init;
' if (my @missing = grep !exists $args->{$_}, '
.join(', ', map quotify($_), @required_init).') {'."\n"
.q{ die "Missing required arguments: ".join(', ', sort @missing);}."\n"
." }\n";
}
# bootstrap our own constructor
sub new {
my $class = shift;
delete _getstash(__PACKAGE__)->{new};
bless $class->BUILDARGS(@_), $class;
}
Moo->_constructor_maker_for(__PACKAGE__)
->register_attribute_specs(
attribute_specs => {
is => 'ro',
reader => 'all_attribute_specs',
},
accessor_generator => { is => 'ro' },
construction_string => { is => 'lazy' },
construction_builder => { is => 'bare' },
subconstructor_handler => { is => 'ro' },
package => { is => 'bare' },
);
1;
METHOD_GENERATE_CONSTRUCTOR
$fatpacked{"Method/Generate/DemolishAll.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_GENERATE_DEMOLISHALL';
package Method::Generate::DemolishAll;
use Moo::_strictures;
use Moo::Object ();
our @ISA = qw(Moo::Object);
use Sub::Quote qw(quote_sub quotify);
use Moo::_Utils;
sub generate_method {
my ($self, $into) = @_;
quote_sub "${into}::DEMOLISHALL", join '',
$self->_handle_subdemolish($into),
qq{ my \$self = shift;\n},
$self->demolishall_body_for($into, '$self', '@_'),
qq{ return \$self\n};
quote_sub "${into}::DESTROY", join '',
q! my $self = shift;
my $e = do {
local $?;
local $@;
require Devel::GlobalDestruction;
eval {
$self->DEMOLISHALL(Devel::GlobalDestruction::in_global_destruction);
};
$@;
};
# fatal warnings+die in DESTROY = bad times (perl rt#123398)
no warnings FATAL => 'all';
use warnings 'all';
die $e if $e; # rethrow
!;
}
sub demolishall_body_for {
my ($self, $into, $me, $args) = @_;
my @demolishers =
grep *{_getglob($_)}{CODE},
map "${_}::DEMOLISH",
@{mro::get_linear_isa($into)};
join '', map qq{ ${me}->${_}(${args});\n}, @demolishers;
}
sub _handle_subdemolish {
my ($self, $into) = @_;
' if (ref($_[0]) ne '.quotify($into).') {'."\n".
' return shift->Moo::Object::DEMOLISHALL(@_)'.";\n".
' }'."\n";
}
1;
METHOD_GENERATE_DEMOLISHALL
$fatpacked{"Method/Inliner.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'METHOD_INLINER';
package Method::Inliner;
use Moo::_strictures;
use Text::Balanced qw(extract_bracketed);
use Sub::Quote ();
sub slurp { do { local (@ARGV, $/) = $_[0]; <> } }
sub splat {
open my $out, '>', $_[1] or die "can't open $_[1]: $!";
print $out $_[0] or die "couldn't write to $_[1]: $!";
}
sub inlinify {
my $file = $_[0];
my @chunks = split /(^sub.*?^}$)/sm, slurp $file;
warn join "\n--\n", @chunks;
my %code;
foreach my $chunk (@chunks) {
if (my ($name, $body) =
$chunk =~ /^sub (\S+) {\n(.*)\n}$/s
) {
$code{$name} = $body;
}
}
foreach my $chunk (@chunks) {
my ($me) = $chunk =~ /^sub.*{\n my \((\$\w+).*\) = \@_;\n/ or next;
my $meq = quotemeta $me;
#warn $meq, $chunk;
my $copy = $chunk;
my ($fixed, $rest);
while ($copy =~ s/^(.*?)${meq}->(\S+)(?=\()//s) {
my ($front, $name) = ($1, $2);
((my $body), $rest) = extract_bracketed($copy, '()');
warn "spotted ${name} - ${body}";
if ($code{$name}) {
warn "replacing";
s/^\(//, s/\)$// for $body;
$body = "${me}, ".$body;
$fixed .= $front.Sub::Quote::inlinify($code{$name}, $body);
} else {
$fixed .= $front.$me.'->'.$name.$body;
}
#warn $fixed; warn $rest;
$copy = $rest;
}
$fixed .= $rest if $fixed;
warn $fixed if $fixed;
$chunk = $fixed if $fixed;
}
print join '', @chunks;
}
1;
METHOD_INLINER
$fatpacked{"Moo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO';
package Moo;
use Moo::_strictures;
use Moo::_Utils;
our $VERSION = '2.000002';
$VERSION = eval $VERSION;
require Moo::sification;
Moo::sification->import;
our %MAKERS;
sub _install_tracked {
my ($target, $name, $code) = @_;
$MAKERS{$target}{exports}{$name} = $code;
_install_coderef "${target}::${name}" => "Moo::${name}" => $code;
}
sub import {
my $target = caller;
my $class = shift;
_set_loaded(caller);
strict->import;
warnings->import;
if ($INC{'Role/Tiny.pm'} and Role::Tiny->is_role($target)) {
die "Cannot import Moo into a role";
}
$MAKERS{$target} ||= {};
_install_tracked $target => extends => sub {
$class->_set_superclasses($target, @_);
$class->_maybe_reset_handlemoose($target);
return;
};
_install_tracked $target => with => sub {
require Moo::Role;
Moo::Role->apply_roles_to_package($target, @_);
$class->_maybe_reset_handlemoose($target);
};
_install_tracked $target => has => sub {
my $name_proto = shift;
my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto;
if (@_ % 2 != 0) {
require Carp;
Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto)
. " attribute(s): even number of arguments expected, got " . scalar @_)
}
my %spec = @_;
foreach my $name (@name_proto) {
# Note that when multiple attributes specified, each attribute
# needs a separate \%specs hashref
my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
$class->_constructor_maker_for($target)
->register_attribute_specs($name, $spec_ref);
$class->_accessor_maker_for($target)
->generate_method($target, $name, $spec_ref);
$class->_maybe_reset_handlemoose($target);
}
return;
};
foreach my $type (qw(before after around)) {
_install_tracked $target => $type => sub {
require Class::Method::Modifiers;
_install_modifier($target, $type, @_);
return;
};
}
return if $MAKERS{$target}{is_class}; # already exported into this package
my $stash = _getstash($target);
my @not_methods = map { *$_{CODE}||() } grep !ref($_), values %$stash;
@{$MAKERS{$target}{not_methods}={}}{@not_methods} = @not_methods;
$MAKERS{$target}{is_class} = 1;
{
no strict 'refs';
@{"${target}::ISA"} = do {
require Moo::Object; ('Moo::Object');
} unless @{"${target}::ISA"};
}
if ($INC{'Moo/HandleMoose.pm'}) {
Moo::HandleMoose::inject_fake_metaclass_for($target);
}
}
sub unimport {
my $target = caller;
_unimport_coderefs($target, $MAKERS{$target});
}
sub _set_superclasses {
my $class = shift;
my $target = shift;
foreach my $superclass (@_) {
_load_module($superclass);
if ($INC{'Role/Tiny.pm'} && Role::Tiny->is_role($superclass)) {
require Carp;
Carp::croak("Can't extend role '$superclass'");
}
}
# Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA
@{*{_getglob("${target}::ISA")}{ARRAY}} = @_;
if (my $old = delete $Moo::MAKERS{$target}{constructor}) {
$old->assert_constructor;
delete _getstash($target)->{new};
Moo->_constructor_maker_for($target)
->register_attribute_specs(%{$old->all_attribute_specs});
}
elsif (!$target->isa('Moo::Object')) {
Moo->_constructor_maker_for($target);
}
no warnings 'once'; # piss off. -- mst
$Moo::HandleMoose::MOUSE{$target} = [
grep defined, map Mouse::Util::find_meta($_), @_
] if Mouse::Util->can('find_meta');
}
sub _maybe_reset_handlemoose {
my ($class, $target) = @_;
if ($INC{"Moo/HandleMoose.pm"}) {
Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
}
}
sub _accessor_maker_for {
my ($class, $target) = @_;
return unless $MAKERS{$target};
$MAKERS{$target}{accessor} ||= do {
my $maker_class = do {
if (my $m = do {
require Sub::Defer;
if (my $defer_target =
(Sub::Defer::defer_info($target->can('new'))||[])->[0]
) {
my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
$MAKERS{$pkg} && $MAKERS{$pkg}{accessor};
} else {
undef;
}
}) {
ref($m);
} else {
require Method::Generate::Accessor;
'Method::Generate::Accessor'
}
};
$maker_class->new;
}
}
sub _constructor_maker_for {
my ($class, $target) = @_;
return unless $MAKERS{$target};
$MAKERS{$target}{constructor} ||= do {
require Method::Generate::Constructor;
require Sub::Defer;
my %construct_opts = (
package => $target,
accessor_generator => $class->_accessor_maker_for($target),
subconstructor_handler => (
' if ($Moo::MAKERS{$class}) {'."\n"
.' if ($Moo::MAKERS{$class}{constructor}) {'."\n"
.' return $class->'.$target.'::SUPER::new(@_);'."\n"
.' }'."\n"
.' '.$class.'->_constructor_maker_for($class);'."\n"
.' return $class->new(@_)'.";\n"
.' } elsif ($INC{"Moose.pm"} and my $meta = Class::MOP::get_metaclass_by_name($class)) {'."\n"
.' return $meta->new_object('."\n"
.' $class->can("BUILDARGS") ? $class->BUILDARGS(@_)'."\n"
.' : $class->Moo::Object::BUILDARGS(@_)'."\n"
.' );'."\n"
.' }'."\n"
),
);
my $con;
my @isa = @{mro::get_linear_isa($target)};
shift @isa;
if (my ($parent_new) = grep { *{_getglob($_.'::new')}{CODE} } @isa) {
if ($parent_new eq 'Moo::Object') {
# no special constructor needed
}
elsif (my $makers = $MAKERS{$parent_new}) {
$con = $makers->{constructor};
$construct_opts{construction_string} = $con->construction_string
if $con;
}
elsif ($parent_new->can('BUILDALL')) {
$construct_opts{construction_builder} = sub {
my $inv = $target->can('BUILDARGS') ? '' : 'Moo::Object::';
'do {'
.' my $args = $class->'.$inv.'BUILDARGS(@_);'
.' $args->{__no_BUILD__} = 1;'
.' $class->'.$target.'::SUPER::new($args);'
.'}'
};
}
else {
$construct_opts{construction_builder} = sub {
'$class->'.$target.'::SUPER::new('
.($target->can('FOREIGNBUILDARGS') ?
'$class->FOREIGNBUILDARGS(@_)' : '@_')
.')'
};
}
}
($con ? ref($con) : 'Method::Generate::Constructor')
->new(%construct_opts)
->install_delayed
->register_attribute_specs(%{$con?$con->all_attribute_specs:{}})
}
}
sub _concrete_methods_of {
my ($me, $role) = @_;
my $makers = $MAKERS{$role};
# grab role symbol table
my $stash = _getstash($role);
# reverse so our keys become the values (captured coderefs) in case
# they got copied or re-used since
my $not_methods = { reverse %{$makers->{not_methods}||{}} };
+{
# grab all code entries that aren't in the not_methods list
map {
my $code = *{$stash->{$_}}{CODE};
( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code)
} grep !ref($stash->{$_}), keys %$stash
};
}
1;
__END__
=pod
=encoding utf-8
=head1 NAME
Moo - Minimalist Object Orientation (with Moose compatibility)
=head1 SYNOPSIS
package Cat::Food;
use Moo;
use strictures 2;
use namespace::clean;
sub feed_lion {
my $self = shift;
my $amount = shift || 1;
$self->pounds( $self->pounds - $amount );
}
has taste => (
is => 'ro',
);
has brand => (
is => 'ro',
isa => sub {
die "Only SWEET-TREATZ supported!" unless $_[0] eq 'SWEET-TREATZ'
},
);
has pounds => (
is => 'rw',
isa => sub { die "$_[0] is too much cat food!" unless $_[0] < 15 },
);
1;
And elsewhere:
my $full = Cat::Food->new(
taste => 'DELICIOUS.',
brand => 'SWEET-TREATZ',
pounds => 10,
);
$full->feed_lion;
say $full->pounds;
=head1 DESCRIPTION
C<Moo> is an extremely light-weight Object Orientation system. It allows one to
concisely define objects and roles with a convenient syntax that avoids the
details of Perl's object system. C<Moo> contains a subset of L<Moose> and is
optimised for rapid startup.
C<Moo> avoids depending on any XS modules to allow for simple deployments. The
name C<Moo> is based on the idea that it provides almost -- but not quite --
two thirds of L<Moose>.
Unlike L<Mouse> this module does not aim at full compatibility with
L<Moose>'s surface syntax, preferring instead to provide full interoperability
via the metaclass inflation capabilities described in L</MOO AND MOOSE>.
For a full list of the minor differences between L<Moose> and L<Moo>'s surface
syntax, see L</INCOMPATIBILITIES WITH MOOSE>.
=head1 WHY MOO EXISTS
If you want a full object system with a rich Metaprotocol, L<Moose> is
already wonderful.
But if you don't want to use L<Moose>, you may not want "less metaprotocol"
like L<Mouse> offers, but you probalby want "no metaprotocol", which is what
Moo provides. C<Moo> is ideal for some situations where deployment or startup
time precludes using L<Moose> and L<Mouse>:
=over 2
=item a command line or CGI script where fast startup is essential
=item code designed to be deployed as a single file via L<App::FatPacker>
=item a CPAN module that may be used by others in the above situations
=back
C<Moo> maintains transparent compatibility with L<Moose> so if you install and
load L<Moose> you can use Moo clases and roles in L<Moose> code without
modification.
Moo -- Minimal Object Orientation -- aims to make it smooth to upgrade to
L<Moose> when you need more than the minimal features offered by Moo.
=head1 MOO AND MOOSE
If L<Moo> detects L<Moose> being loaded, it will automatically register
metaclasses for your L<Moo> and L<Moo::Role> packages, so you should be able
to use them in L<Moose> code without modification.
L<Moo> will also create L<Moose type constraints|Moose::Manual::Types> for
L<Moo> classes and roles, so that in Moose classes C<< isa => 'MyMooClass' >>
and C<< isa => 'MyMooRole' >> work the same as for L<Moose> classes and roles.
Extending a L<Moose> class or consuming a L<Moose::Role> will also work.
Extending a L<Mouse> class or consuming a L<Mouse::Role> will also work. But
note that we don't provide L<Mouse> metaclasses or metaroles so the other way
around doesn't work. This feature exists for L<Any::Moose> users porting to
L<Moo>; enabling L<Mouse> users to use L<Moo> classes is not a priority for us.
This means that there is no need for anything like L<Any::Moose> for Moo
code - Moo and Moose code should simply interoperate without problem. To
handle L<Mouse> code, you'll likely need an empty Moo role or class consuming
or extending the L<Mouse> stuff since it doesn't register true L<Moose>
metaclasses like L<Moo> does.
If you need to disable the metaclass creation, add:
no Moo::sification;
to your code before Moose is loaded, but bear in mind that this switch is
global and turns the mechanism off entirely so don't put this in library code.
=head1 MOO AND CLASS::XSACCESSOR
If a new enough version of L<Class::XSAccessor> is available, it
will be used to generate simple accessors, readers, and writers for
better performance. Simple accessors are those without lazy defaults,
type checks/coercions, or triggers. Readers and writers generated
by L<Class::XSAccessor> will behave slightly differently: they will
reject attempts to call them with the incorrect number of parameters.
=head1 MOO VERSUS ANY::MOOSE
L<Any::Moose> will load L<Mouse> normally, and L<Moose> in a program using
L<Moose> - which theoretically allows you to get the startup time of L<Mouse>
without disadvantaging L<Moose> users.
Sadly, this doesn't entirely work, since the selection is load order dependent
- L<Moo>'s metaclass inflation system explained above in L</MOO AND MOOSE> is
significantly more reliable.
So if you want to write a CPAN module that loads fast or has only pure perl
dependencies but is also fully usable by L<Moose> users, you should be using
L<Moo>.
For a full explanation, see the article
L<http://shadow.cat/blog/matt-s-trout/moo-versus-any-moose> which explains
the differing strategies in more detail and provides a direct example of
where L<Moo> succeeds and L<Any::Moose> fails.
=head1 IMPORTED METHODS
=head2 new
Foo::Bar->new( attr1 => 3 );
or
Foo::Bar->new({ attr1 => 3 });
=head2 BUILDARGS
sub BUILDARGS {
my ( $class, @args ) = @_;
unshift @args, "attr1" if @args % 2 == 1;
return { @args };
}
Foo::Bar->new( 3 );
The default implementation of this method accepts a hash or hash reference of
named parameters. If it receives a single argument that isn't a hash reference
it throws an error.
You can override this method in your class to handle other types of options
passed to the constructor.
This method should always return a hash reference of named options.
=head2 FOREIGNBUILDARGS
If you are inheriting from a non-Moo class, the arguments passed to the parent
class constructor can be manipulated by defining a C<FOREIGNBUILDARGS> method.
It will receive the same arguments as C<BUILDARGS>, and should return a list
of arguments to pass to the parent class constructor.
=head2 BUILD
Define a C<BUILD> method on your class and the constructor will automatically
call the C<BUILD> method from parent down to child after the object has
been instantiated. Typically this is used for object validation or possibly
logging.
=head2 DEMOLISH
If you have a C<DEMOLISH> method anywhere in your inheritance hierarchy,
a C<DESTROY> method is created on first object construction which will call
C<< $instance->DEMOLISH($in_global_destruction) >> for each C<DEMOLISH>
method from child upwards to parents.
Note that the C<DESTROY> method is created on first construction of an object
of your class in order to not add overhead to classes without C<DEMOLISH>
methods; this may prove slightly surprising if you try and define your own.
=head2 does
if ($foo->does('Some::Role1')) {
...
}
Returns true if the object composes in the passed role.
=head1 IMPORTED SUBROUTINES
=head2 extends
extends 'Parent::Class';
Declares a base class. Multiple superclasses can be passed for multiple
inheritance but please consider using L<roles|Moo::Role> instead. The class
will be loaded but no errors will be triggered if the class can't be found and
there are already subs in the class.
Calling extends more than once will REPLACE your superclasses, not add to
them like 'use base' would.
=head2 with
with 'Some::Role1';
or
with 'Some::Role1', 'Some::Role2';
Composes one or more L<Moo::Role> (or L<Role::Tiny>) roles into the current
class. An error will be raised if these roles cannot be composed because they
have conflicting method definitions. The roles will be loaded using the same
mechansim as C<extends> uses.
=head2 has
has attr => (
is => 'ro',
);
Declares an attribute for the class.
package Foo;
use Moo;
has 'attr' => (
is => 'ro'
);
package Bar;
use Moo;
extends 'Foo';
has '+attr' => (
default => sub { "blah" },
);
Using the C<+> notation, it's possible to override an attribute.
The options for C<has> are as follows:
=over 2
=item * C<is>
B<required>, may be C<ro>, C<lazy>, C<rwp> or C<rw>.
C<ro> stands for "read-only" and generates an accessor that dies if you attempt
to write to it - i.e. a getter only - by defaulting C<reader> to the name of
the attribute.
C<lazy> generates a reader like C<ro>, but also sets C<lazy> to 1 and
C<builder> to C<_build_${attribute_name}> to allow on-demand generated
attributes. This feature was my attempt to fix my incompetence when
originally designing C<lazy_build>, and is also implemented by
L<MooseX::AttributeShortcuts>. There is, however, nothing to stop you
using C<lazy> and C<builder> yourself with C<rwp> or C<rw> - it's just that
this isn't generally a good idea so we don't provide a shortcut for it.
C<rwp> stands for "read-write protected" and generates a reader like C<ro>, but
also sets C<writer> to C<_set_${attribute_name}> for attributes that are
designed to be written from inside of the class, but read-only from outside.
This feature comes from L<MooseX::AttributeShortcuts>.
C<rw> stands for "read-write" and generates a normal getter/setter by
defaulting the C<accessor> to the name of the attribute specified.
=item * C<isa>
Takes a coderef which is used to validate the attribute. Unlike L<Moose>, Moo
does not include a basic type system, so instead of doing C<< isa => 'Num' >>,
one should do
use Scalar::Util qw(looks_like_number);
...
isa => sub {
die "$_[0] is not a number!" unless looks_like_number $_[0]
},
Note that the return value for C<isa> is discarded. Only if the sub dies does
type validation fail.
L<Sub::Quote aware|/SUB QUOTE AWARE>
Since L<Moo> does B<not> run the C<isa> check before C<coerce> if a coercion
subroutine has been supplied, C<isa> checks are not structural to your code
and can, if desired, be omitted on non-debug builds (although if this results
in an uncaught bug causing your program to break, the L<Moo> authors guarantee
nothing except that you get to keep both halves).
If you want L<Moose> compatible or L<MooseX::Types> style named types, look at
L<Type::Tiny>.
To cause your C<isa> entries to be automatically mapped to named
L<Moose::Meta::TypeConstraint> objects (rather than the default behaviour
of creating an anonymous type), set:
$Moo::HandleMoose::TYPE_MAP{$isa_coderef} = sub {
require MooseX::Types::Something;
return MooseX::Types::Something::TypeName();
};
Note that this example is purely illustrative; anything that returns a
L<Moose::Meta::TypeConstraint> object or something similar enough to it to
make L<Moose> happy is fine.
=item * C<coerce>
Takes a coderef which is meant to coerce the attribute. The basic idea is to
do something like the following:
coerce => sub {
$_[0] % 2 ? $_[0] : $_[0] + 1
},
Note that L<Moo> will always execute your coercion: this is to permit
C<isa> entries to be used purely for bug trapping, whereas coercions are
always structural to your code. We do, however, apply any supplied C<isa>
check after the coercion has run to ensure that it returned a valid value.
L<Sub::Quote aware|/SUB QUOTE AWARE>
If the C<isa> option is a blessed object providing a C<coerce> or
C<coercion> method, then the C<coerce> option may be set to just C<1>.
=item * C<handles>
Takes a string
handles => 'RobotRole'
Where C<RobotRole> is a L<role|Moo::Role> that defines an interface which
becomes the list of methods to handle.
Takes a list of methods
handles => [ qw( one two ) ]
Takes a hashref
handles => {
un => 'one',
}
=item * C<trigger>
Takes a coderef which will get called any time the attribute is set. This
includes the constructor, but not default or built values. The coderef will be
invoked against the object with the new value as an argument.
If you set this to just C<1>, it generates a trigger which calls the
C<_trigger_${attr_name}> method on C<$self>. This feature comes from
L<MooseX::AttributeShortcuts>.
Note that Moose also passes the old value, if any; this feature is not yet
supported.
L<Sub::Quote aware|/SUB QUOTE AWARE>
=item * C<default>
Takes a coderef which will get called with $self as its only argument to
populate an attribute if no value for that attribute was supplied to the
constructor. Alternatively, if the attribute is lazy, C<default> executes when
the attribute is first retrieved if no value has yet been provided.
If a simple scalar is provided, it will be inlined as a string. Any non-code
reference (hash, array) will result in an error - for that case instead use
a code reference that returns the desired value.
Note that if your default is fired during new() there is no guarantee that
other attributes have been populated yet so you should not rely on their
existence.
L<Sub::Quote aware|/SUB QUOTE AWARE>
=item * C<predicate>
Takes a method name which will return true if an attribute has a value.
If you set this to just C<1>, the predicate is automatically named
C<has_${attr_name}> if your attribute's name does not start with an
underscore, or C<_has_${attr_name_without_the_underscore}> if it does.
This feature comes from L<MooseX::AttributeShortcuts>.
=item * C<builder>
Takes a method name which will be called to create the attribute - functions
exactly like default except that instead of calling
$default->($self);
Moo will call
$self->$builder;
The following features come from L<MooseX::AttributeShortcuts>:
If you set this to just C<1>, the builder is automatically named
C<_build_${attr_name}>.
If you set this to a coderef or code-convertible object, that variable will be
installed under C<$class::_build_${attr_name}> and the builder set to the same
name.
=item * C<clearer>
Takes a method name which will clear the attribute.
If you set this to just C<1>, the clearer is automatically named
C<clear_${attr_name}> if your attribute's name does not start with an
underscore, or C<_clear_${attr_name_without_the_underscore}> if it does.
This feature comes from L<MooseX::AttributeShortcuts>.
B<NOTE:> If the attribute is C<lazy>, it will be regenerated from C<default> or
C<builder> the next time it is accessed. If it is not lazy, it will be C<undef>.
=item * C<lazy>
B<Boolean>. Set this if you want values for the attribute to be grabbed
lazily. This is usually a good idea if you have a L</builder> which requires
another attribute to be set.
=item * C<required>
B<Boolean>. Set this if the attribute must be passed on object instantiation.
=item * C<reader>
The name of the method that returns the value of the attribute. If you like
Java style methods, you might set this to C<get_foo>
=item * C<writer>
The value of this attribute will be the name of the method to set the value of
the attribute. If you like Java style methods, you might set this to
C<set_foo>.
=item * C<weak_ref>
B<Boolean>. Set this if you want the reference that the attribute contains to
be weakened. Use this when circular references, which cause memory leaks, are
possible.
=item * C<init_arg>
Takes the name of the key to look for at instantiation time of the object. A
common use of this is to make an underscored attribute have a non-underscored
initialization name. C<undef> means that passing the value in on instantiation
is ignored.
=item * C<moosify>
Takes either a coderef or array of coderefs which is meant to transform the
given attributes specifications if necessary when upgrading to a Moose role or
class. You shouldn't need this by default, but is provided as a means of
possible extensibility.
=back
=head2 before
before foo => sub { ... };
See L<< Class::Method::Modifiers/before method(s) => sub { ... }; >> for full
documentation.
=head2 around
around foo => sub { ... };
See L<< Class::Method::Modifiers/around method(s) => sub { ... }; >> for full
documentation.
=head2 after
after foo => sub { ... };
See L<< Class::Method::Modifiers/after method(s) => sub { ... }; >> for full
documentation.
=head1 SUB QUOTE AWARE
L<Sub::Quote/quote_sub> allows us to create coderefs that are "inlineable,"
giving us a handy, XS-free speed boost. Any option that is L<Sub::Quote>
aware can take advantage of this.
To do this, you can write
use Sub::Quote;
use Moo;
use namespace::clean;
has foo => (
is => 'ro',
isa => quote_sub(q{ die "Not <3" unless $_[0] < 3 })
);
which will be inlined as
do {
local @_ = ($_[0]->{foo});
die "Not <3" unless $_[0] < 3;
}
or to avoid localizing @_,
has foo => (
is => 'ro',
isa => quote_sub(q{ my ($val) = @_; die "Not <3" unless $val < 3 })
);
which will be inlined as
do {
my ($val) = ($_[0]->{foo});
die "Not <3" unless $val < 3;
}
See L<Sub::Quote> for more information, including how to pass lexical
captures that will also be compiled into the subroutine.
=head1 CLEANING UP IMPORTS
L<Moo> will not clean up imported subroutines for you; you will have
to do that manually. The recommended way to do this is to declare your
imports first, then C<use Moo>, then C<use namespace::clean>.
Anything imported before L<namespace::clean> will be scrubbed.
Anything imported or declared after will be still be available.
package Record;
use Digest::MD5 qw(md5_hex);
use Moo;
use namespace::clean;
has name => (is => 'ro', required => 1);
has id => (is => 'lazy');
sub _build_id {
my ($self) = @_;
return md5_hex($self->name);
}
1;
If you were to import C<md5_hex> after L<namespace::clean> you would
be able to call C<< ->md5_hex() >> on your C<Record> instances (and it
probably wouldn't do what you expect!).
L<Moo::Role>s behave slightly differently. Since their methods are
composed into the consuming class, they can do a little more for you
automatically. As long as you declare your imports before calling
C<use Moo::Role>, those imports and the ones L<Moo::Role> itself
provides will not be composed into consuming classes so there's usually
no need to use L<namespace::clean>.
B<On L<namespace::autoclean>:> Older versions of L<namespace::autoclean> would
inflate Moo classes to full L<Moose> classes, losing the benefits of Moo. If
you want to use L<namespace::autoclean> with a Moo class, make sure you are
using version 0.16 or newer.
=head1 INCOMPATIBILITIES WITH MOOSE
There is no built-in type system. C<isa> is verified with a coderef; if you
need complex types, L<Type::Tiny> can provide types, type libraries, and
will work seamlessly with both L<Moo> and L<Moose>. L<Type::Tiny> can be
considered the successor to L<MooseX::Types> and provides a similar API, so
that you can write
use Types::Standard;
has days_to_live => (is => 'ro', isa => Int);
C<initializer> is not supported in core since the author considers it to be a
bad idea and Moose best practices recommend avoiding it. Meanwhile C<trigger> or
C<coerce> are more likely to be able to fulfill your needs.
There is no meta object. If you need this level of complexity you need
L<Moose> - Moo is small because it explicitly does not provide a metaprotocol.
However, if you load L<Moose>, then
Class::MOP::class_of($moo_class_or_role)
will return an appropriate metaclass pre-populated by L<Moo>.
No support for C<super>, C<override>, C<inner>, or C<augment> - the author
considers augment to be a bad idea, and override can be translated:
override foo => sub {
...
super();
...
};
around foo => sub {
my ($orig, $self) = (shift, shift);
...
$self->$orig(@_);
...
};
The C<dump> method is not provided by default. The author suggests loading
L<Devel::Dwarn> into C<main::> (via C<perl -MDevel::Dwarn ...> for example) and
using C<$obj-E<gt>$::Dwarn()> instead.
L</default> only supports coderefs and plain scalars, because passing a hash
or array reference as a default is almost always incorrect since the value is
then shared between all objects using that default.
C<lazy_build> is not supported; you are instead encouraged to use the
C<< is => 'lazy' >> option supported by L<Moo> and
L<MooseX::AttributeShortcuts>.
C<auto_deref> is not supported since the author considers it a bad idea and
it has been considered best practice to avoid it for some time.
C<documentation> will show up in a L<Moose> metaclass created from your class
but is otherwise ignored. Then again, L<Moose> ignores it as well, so this
is arguably not an incompatibility.
Since C<coerce> does not require C<isa> to be defined but L<Moose> does
require it, the metaclass inflation for coerce alone is a trifle insane
and if you attempt to subtype the result will almost certainly break.
C<BUILDARGS> is not triggered if your class does not have any attributes.
Without attributes, C<BUILDARGS> return value would be ignored, so we just
skip calling the method instead.
Handling of warnings: when you C<use Moo> we enable strict and warnings, in a
similar way to Moose. The authors recommend the use of C<strictures>, which
enables FATAL warnings, and several extra pragmas when used in development:
L<indirect>, L<multidimensional>, and L<bareword::filehandles>.
Additionally, L<Moo> supports a set of attribute option shortcuts intended to
reduce common boilerplate. The set of shortcuts is the same as in the L<Moose>
module L<MooseX::AttributeShortcuts> as of its version 0.009+. So if you:
package MyClass;
use Moo;
use strictures 2;
The nearest L<Moose> invocation would be:
package MyClass;
use Moose;
use warnings FATAL => "all";
use MooseX::AttributeShortcuts;
or, if you're inheriting from a non-Moose class,
package MyClass;
use Moose;
use MooseX::NonMoose;
use warnings FATAL => "all";
use MooseX::AttributeShortcuts;
Finally, Moose requires you to call
__PACKAGE__->meta->make_immutable;
at the end of your class to get an inlined (i.e. not horribly slow)
constructor. Moo does it automatically the first time ->new is called
on your class. (C<make_immutable> is a no-op in Moo to ease migration.)
An extension L<MooX::late> exists to ease translating Moose packages
to Moo by providing a more Moose-like interface.
=head1 SUPPORT
Users' IRC: #moose on irc.perl.org
=for :html
L<(click for instant chatroom login)|http://chat.mibbit.com/#moose@irc.perl.org>
Development and contribution IRC: #web-simple on irc.perl.org
=for :html
L<(click for instant chatroom login)|http://chat.mibbit.com/#web-simple@irc.perl.org>
Bugtracker: L<https://rt.cpan.org/Public/Dist/Display.html?Name=Moo>
Git repository: L<git://github.com/moose/Moo.git>
Git browser: L<https://github.com/moose/Moo>
=head1 AUTHOR
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
=head1 CONTRIBUTORS
dg - David Leadbeater (cpan:DGL) <dgl@dgl.cx>
frew - Arthur Axel "fREW" Schmidt (cpan:FREW) <frioux@gmail.com>
hobbs - Andrew Rodland (cpan:ARODLAND) <arodland@cpan.org>
jnap - John Napiorkowski (cpan:JJNAPIORK) <jjn1056@yahoo.com>
ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com>
ajgb - Alex J. G. Burzyński (cpan:AJGB) <ajgb@cpan.org>
doy - Jesse Luehrs (cpan:DOY) <doy at tozt dot net>
perigrin - Chris Prather (cpan:PERIGRIN) <chris@prather.org>
Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
ilmari - Dagfinn Ilmari Mannsåker (cpan:ILMARI) <ilmari@ilmari.org>
tobyink - Toby Inkster (cpan:TOBYINK) <tobyink@cpan.org>
haarg - Graham Knop (cpan:HAARG) <haarg@cpan.org>
mattp - Matt Phillips (cpan:MATTP) <mattp@cpan.org>
bluefeet - Aran Deltac (cpan:BLUEFEET) <bluefeet@gmail.com>
bubaflub - Bob Kuo (cpan:BUBAFLUB) <bubaflub@cpan.org>
ether = Karen Etheridge (cpan:ETHER) <ether@cpan.org>
=head1 COPYRIGHT
Copyright (c) 2010-2015 the Moo L</AUTHOR> and L</CONTRIBUTORS>
as listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself. See L<http://dev.perl.org/licenses/>.
=cut
MOO
$fatpacked{"Moo/HandleMoose.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_HANDLEMOOSE';
package Moo::HandleMoose;
use Moo::_strictures;
no warnings 'once';
use Moo::_Utils;
use Sub::Quote qw(quotify);
our %TYPE_MAP;
our $SETUP_DONE;
sub import { return if $SETUP_DONE; inject_all(); $SETUP_DONE = 1; }
sub inject_all {
die "Can't inflate Moose metaclass with Moo::sification disabled"
if $Moo::sification::disabled;
require Class::MOP;
inject_fake_metaclass_for($_)
for grep $_ ne 'Moo::Object', do { no warnings 'once'; keys %Moo::MAKERS };
inject_fake_metaclass_for($_) for keys %Moo::Role::INFO;
require Moose::Meta::Method::Constructor;
@Moo::HandleMoose::FakeConstructor::ISA = 'Moose::Meta::Method::Constructor';
@Moo::HandleMoose::FakeMeta::ISA = 'Moose::Meta::Method::Meta';
}
sub maybe_reinject_fake_metaclass_for {
my ($name) = @_;
our %DID_INJECT;
if (delete $DID_INJECT{$name}) {
unless ($Moo::Role::INFO{$name}) {
Moo->_constructor_maker_for($name)->install_delayed;
}
inject_fake_metaclass_for($name);
}
}
sub inject_fake_metaclass_for {
my ($name) = @_;
require Class::MOP;
require Moo::HandleMoose::FakeMetaClass;
Class::MOP::store_metaclass_by_name(
$name, bless({ name => $name }, 'Moo::HandleMoose::FakeMetaClass')
);
require Moose::Util::TypeConstraints;
if ($Moo::Role::INFO{$name}) {
Moose::Util::TypeConstraints::find_or_create_does_type_constraint($name);
} else {
Moose::Util::TypeConstraints::find_or_create_isa_type_constraint($name);
}
}
{
package Moo::HandleMoose::FakeConstructor;
sub _uninlined_body { \&Moose::Object::new }
}
sub inject_real_metaclass_for {
my ($name) = @_;
our %DID_INJECT;
return Class::MOP::get_metaclass_by_name($name) if $DID_INJECT{$name};
require Moose; require Moo; require Moo::Role; require Scalar::Util;
Class::MOP::remove_metaclass_by_name($name);
my ($am_role, $am_class, $meta, $attr_specs, $attr_order) = do {
if (my $info = $Moo::Role::INFO{$name}) {
my @attr_info = @{$info->{attributes}||[]};
(1, 0, Moose::Meta::Role->initialize($name),
{ @attr_info },
[ @attr_info[grep !($_ % 2), 0..$#attr_info] ]
)
} elsif ( my $cmaker = Moo->_constructor_maker_for($name) ) {
my $specs = $cmaker->all_attribute_specs;
(0, 1, Moose::Meta::Class->initialize($name), $specs,
[ sort { $specs->{$a}{index} <=> $specs->{$b}{index} } keys %$specs ]
);
} else {
# This codepath is used if $name does not exist in $Moo::MAKERS
(0, 0, Moose::Meta::Class->initialize($name), {}, [] )
}
};
foreach my $spec (values %$attr_specs) {
if (my $inflators = delete $spec->{moosify}) {
$_->($spec) for @$inflators;
}
}
my %methods
= %{($am_role ? 'Moo::Role' : 'Moo')->_concrete_methods_of($name)};
# if stuff gets added afterwards, _maybe_reset_handlemoose should
# trigger the recreation of the metaclass but we need to ensure the
# Moo::Role cache is cleared so we don't confuse Moo itself.
if (my $info = $Moo::Role::INFO{$name}) {
delete $info->{methods};
}
# needed to ensure the method body is stable and get things named
Sub::Defer::undefer_sub($_) for grep defined, values %methods;
my @attrs;
{
# This local is completely not required for roles but harmless
local @{_getstash($name)}{keys %methods};
my %seen_name;
foreach my $name (@$attr_order) {
$seen_name{$name} = 1;
my %spec = %{$attr_specs->{$name}};
my %spec_map = (
map { $_->name => $_->init_arg||$_->name }
(
(grep { $_->has_init_arg }
$meta->attribute_metaclass->meta->get_all_attributes),
grep { exists($_->{init_arg}) ? defined($_->init_arg) : 1 }
map {
my $meta = Moose::Util::resolve_metatrait_alias('Attribute', $_)
->meta;
map $meta->get_attribute($_), $meta->get_attribute_list
} @{$spec{traits}||[]}
)
);
# have to hard code this because Moose's role meta-model is lacking
$spec_map{traits} ||= 'traits';
$spec{is} = 'ro' if $spec{is} eq 'lazy' or $spec{is} eq 'rwp';
my $coerce = $spec{coerce};
if (my $isa = $spec{isa}) {
my $tc = $spec{isa} = do {
if (my $mapped = $TYPE_MAP{$isa}) {
my $type = $mapped->();
unless ( Scalar::Util::blessed($type)
&& $type->isa("Moose::Meta::TypeConstraint") ) {
die "error inflating attribute '$name' for package '$_[0]': "
."\$TYPE_MAP{$isa} did not return a valid type constraint'";
}
$coerce ? $type->create_child_type(name => $type->name) : $type;
} else {
Moose::Meta::TypeConstraint->new(
constraint => sub { eval { &$isa; 1 } }
);
}
};
if ($coerce) {
$tc->coercion(Moose::Meta::TypeCoercion->new)
->_compiled_type_coercion($coerce);
$spec{coerce} = 1;
}
} elsif ($coerce) {
my $attr = quotify($name);
my $tc = Moose::Meta::TypeConstraint->new(
constraint => sub { die "This is not going to work" },
inlined => sub {
'my $r = $_[42]{'.$attr.'}; $_[42]{'.$attr.'} = 1; $r'
},
);
$tc->coercion(Moose::Meta::TypeCoercion->new)
->_compiled_type_coercion($coerce);
$spec{isa} = $tc;
$spec{coerce} = 1;
}
%spec =
map { $spec_map{$_} => $spec{$_} }
grep { exists $spec_map{$_} }
keys %spec;
push @attrs, $meta->add_attribute($name => %spec);
}
foreach my $mouse (do { our %MOUSE; @{$MOUSE{$name}||[]} }) {
foreach my $attr ($mouse->get_all_attributes) {
my %spec = %{$attr};
delete @spec{qw(
associated_class associated_methods __METACLASS__
provides curries
)};
my $name = delete $spec{name};
next if $seen_name{$name}++;
push @attrs, $meta->add_attribute($name => %spec);
}
}
}
foreach my $meth_name (keys %methods) {
my $meth_code = $methods{$meth_name};
$meta->add_method($meth_name, $meth_code) if $meth_code;
}
if ($am_role) {
my $info = $Moo::Role::INFO{$name};
$meta->add_required_methods(@{$info->{requires}});
foreach my $modifier (@{$info->{modifiers}}) {
my ($type, @args) = @$modifier;
my $code = pop @args;
$meta->${\"add_${type}_method_modifier"}($_, $code) for @args;
}
}
elsif ($am_class) {
foreach my $attr (@attrs) {
foreach my $method (@{$attr->associated_methods}) {
$method->{body} = $name->can($method->name);
}
}
bless(
$meta->find_method_by_name('new'),
'Moo::HandleMoose::FakeConstructor',
);
my $meta_meth;
if (
$meta_meth = $meta->find_method_by_name('meta')
and $meta_meth->body == \&Moo::Object::meta
) {
bless($meta_meth, 'Moo::HandleMoose::FakeMeta');
}
# a combination of Moo and Moose may bypass a Moo constructor but still
# use a Moo DEMOLISHALL. We need to make sure this is loaded before
# global destruction.
require Method::Generate::DemolishAll;
}
$meta->add_role(Class::MOP::class_of($_))
for grep !/\|/ && $_ ne $name, # reject Foo|Bar and same-role-as-self
do { no warnings 'once'; keys %{$Moo::Role::APPLIED_TO{$name}} };
$DID_INJECT{$name} = 1;
$meta;
}
1;
MOO_HANDLEMOOSE
$fatpacked{"Moo/HandleMoose/FakeMetaClass.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_HANDLEMOOSE_FAKEMETACLASS';
package Moo::HandleMoose::FakeMetaClass;
use Moo::_strictures;
sub DESTROY { }
sub AUTOLOAD {
my ($meth) = (our $AUTOLOAD =~ /([^:]+)$/);
my $self = shift;
die "Can't call $meth without object instance"
if !ref $self;
die "Can't inflate Moose metaclass with Moo::sification disabled"
if $Moo::sification::disabled;
require Moo::HandleMoose;
Moo::HandleMoose::inject_real_metaclass_for($self->{name})->$meth(@_)
}
sub can {
my $self = shift;
return $self->SUPER::can(@_)
if !ref $self or $Moo::sification::disabled;
require Moo::HandleMoose;
Moo::HandleMoose::inject_real_metaclass_for($self->{name})->can(@_)
}
sub isa {
my $self = shift;
return $self->SUPER::isa(@_)
if !ref $self or $Moo::sification::disabled;
require Moo::HandleMoose;
Moo::HandleMoose::inject_real_metaclass_for($self->{name})->isa(@_)
}
sub make_immutable { $_[0] }
1;
MOO_HANDLEMOOSE_FAKEMETACLASS
$fatpacked{"Moo/HandleMoose/_TypeMap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_HANDLEMOOSE__TYPEMAP';
package Moo::HandleMoose::_TypeMap;
use Moo::_strictures;
package
Moo::HandleMoose;
our %TYPE_MAP;
package Moo::HandleMoose::_TypeMap;
use Scalar::Util ();
use Config;
our %WEAK_TYPES;
sub _str_to_ref {
my $in = shift;
return $in
if ref $in;
if ($in =~ /(?:^|=)[A-Z]+\(0x([0-9a-zA-Z]+)\)$/) {
my $id = do { no warnings 'portable'; hex "$1" };
require B;
my $sv = bless \$id, 'B::SV';
my $ref = eval { $sv->object_2svref };
if (!defined $ref) {
die <<'END_ERROR';
Moo initialization encountered types defined in a parent thread - ensure that
Moo is require()d before any further thread spawns following a type definition.
END_ERROR
}
return $ref;
}
return $in;
}
sub TIEHASH { bless {}, $_[0] }
sub STORE {
my ($self, $key, $value) = @_;
my $type = _str_to_ref($key);
$WEAK_TYPES{$type} = $type;
Scalar::Util::weaken($WEAK_TYPES{$type})
if ref $type;
$self->{$key} = $value;
}
sub FETCH { $_[0]->{$_[1]} }
sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} }
sub NEXTKEY { each %{$_[0]} }
sub EXISTS { exists $_[0]->{$_[1]} }
sub DELETE { delete $_[0]->{$_[1]} }
sub CLEAR { %{$_[0]} = () }
sub SCALAR { scalar %{$_[0]} }
sub CLONE {
my @types = map {
defined $WEAK_TYPES{$_} ? ($WEAK_TYPES{$_} => $TYPE_MAP{$_}) : ()
} keys %TYPE_MAP;
%WEAK_TYPES = ();
%TYPE_MAP = @types;
}
sub DESTROY {
my %types = %{$_[0]};
untie %TYPE_MAP;
%TYPE_MAP = %types;
}
if ($Config{useithreads}) {
my @types = %TYPE_MAP;
tie %TYPE_MAP, __PACKAGE__;
%TYPE_MAP = @types;
}
1;
MOO_HANDLEMOOSE__TYPEMAP
$fatpacked{"Moo/Object.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_OBJECT';
package Moo::Object;
use Moo::_strictures;
our %NO_BUILD;
our %NO_DEMOLISH;
our $BUILD_MAKER;
our $DEMOLISH_MAKER;
sub new {
my $class = shift;
unless (exists $NO_DEMOLISH{$class}) {
unless ($NO_DEMOLISH{$class} = !$class->can('DEMOLISH')) {
($DEMOLISH_MAKER ||= do {
require Method::Generate::DemolishAll;
Method::Generate::DemolishAll->new
})->generate_method($class);
}
}
my $proto = $class->BUILDARGS(@_);
$NO_BUILD{$class} and
return bless({}, $class);
$NO_BUILD{$class} = !$class->can('BUILD') unless exists $NO_BUILD{$class};
$NO_BUILD{$class}
? bless({}, $class)
: bless({}, $class)->BUILDALL($proto);
}
# Inlined into Method::Generate::Constructor::_generate_args() - keep in sync
sub BUILDARGS {
my $class = shift;
if ( scalar @_ == 1 ) {
unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
die "Single parameters to new() must be a HASH ref"
." data => ". $_[0] ."\n";
}
return { %{ $_[0] } };
}
elsif ( @_ % 2 ) {
die "The new() method for $class expects a hash reference or a"
. " key/value list. You passed an odd number of arguments\n";
}
else {
return {@_};
}
}
sub BUILDALL {
my $self = shift;
$self->${\(($BUILD_MAKER ||= do {
require Method::Generate::BuildAll;
Method::Generate::BuildAll->new
})->generate_method(ref($self)))}(@_);
}
sub DEMOLISHALL {
my $self = shift;
$self->${\(($DEMOLISH_MAKER ||= do {
require Method::Generate::DemolishAll;
Method::Generate::DemolishAll->new
})->generate_method(ref($self)))}(@_);
}
sub does {
return !!0
unless ($INC{'Moose/Role.pm'} || $INC{'Role/Tiny.pm'});
require Moo::Role;
my $does = Moo::Role->can("does_role");
{ no warnings 'redefine'; *does = $does }
goto &$does;
}
# duplicated in Moo::Role
sub meta {
require Moo::HandleMoose::FakeMetaClass;
my $class = ref($_[0])||$_[0];
bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass');
}
1;
MOO_OBJECT
$fatpacked{"Moo/Role.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_ROLE';
package Moo::Role;
use Moo::_strictures;
use Moo::_Utils;
use Role::Tiny ();
our @ISA = qw(Role::Tiny);
our $VERSION = '2.000002';
$VERSION = eval $VERSION;
require Moo::sification;
Moo::sification->import;
BEGIN {
*INFO = \%Role::Tiny::INFO;
*APPLIED_TO = \%Role::Tiny::APPLIED_TO;
*ON_ROLE_CREATE = \@Role::Tiny::ON_ROLE_CREATE;
}
our %INFO;
our %APPLIED_TO;
our %APPLY_DEFAULTS;
our @ON_ROLE_CREATE;
sub _install_tracked {
my ($target, $name, $code) = @_;
$INFO{$target}{exports}{$name} = $code;
_install_coderef "${target}::${name}" => "Moo::Role::${name}" => $code;
}
sub import {
my $target = caller;
my ($me) = @_;
_set_loaded(caller);
strict->import;
warnings->import;
if ($Moo::MAKERS{$target} and $Moo::MAKERS{$target}{is_class}) {
die "Cannot import Moo::Role into a Moo class";
}
$INFO{$target} ||= {};
# get symbol table reference
my $stash = _getstash($target);
_install_tracked $target => has => sub {
my $name_proto = shift;
my @name_proto = ref $name_proto eq 'ARRAY' ? @$name_proto : $name_proto;
if (@_ % 2 != 0) {
require Carp;
Carp::croak("Invalid options for " . join(', ', map "'$_'", @name_proto)
. " attribute(s): even number of arguments expected, got " . scalar @_)
}
my %spec = @_;
foreach my $name (@name_proto) {
my $spec_ref = @name_proto > 1 ? +{%spec} : \%spec;
($INFO{$target}{accessor_maker} ||= do {
require Method::Generate::Accessor;
Method::Generate::Accessor->new
})->generate_method($target, $name, $spec_ref);
push @{$INFO{$target}{attributes}||=[]}, $name, $spec_ref;
$me->_maybe_reset_handlemoose($target);
}
};
# install before/after/around subs
foreach my $type (qw(before after around)) {
_install_tracked $target => $type => sub {
require Class::Method::Modifiers;
push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
$me->_maybe_reset_handlemoose($target);
};
}
_install_tracked $target => requires => sub {
push @{$INFO{$target}{requires}||=[]}, @_;
$me->_maybe_reset_handlemoose($target);
};
_install_tracked $target => with => sub {
$me->apply_roles_to_package($target, @_);
$me->_maybe_reset_handlemoose($target);
};
return if $me->is_role($target); # already exported into this package
$INFO{$target}{is_role} = 1;
*{_getglob("${target}::meta")} = $me->can('meta');
# grab all *non-constant* (stash slot is not a scalarref) subs present
# in the symbol table and store their refaddrs (no need to forcibly
# inflate constant subs into real subs) - also add '' to here (this
# is used later) with a map to the coderefs in case of copying or re-use
my @not_methods = ('', map { *$_{CODE}||() } grep !ref($_), values %$stash);
@{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods;
# a role does itself
$APPLIED_TO{$target} = { $target => undef };
$_->($target)
for @ON_ROLE_CREATE;
}
push @ON_ROLE_CREATE, sub {
my $target = shift;
if ($INC{'Moo/HandleMoose.pm'}) {
Moo::HandleMoose::inject_fake_metaclass_for($target);
}
};
# duplicate from Moo::Object
sub meta {
require Moo::HandleMoose::FakeMetaClass;
my $class = ref($_[0])||$_[0];
bless({ name => $class }, 'Moo::HandleMoose::FakeMetaClass');
}
sub unimport {
my $target = caller;
_unimport_coderefs($target, $INFO{$target});
}
sub _maybe_reset_handlemoose {
my ($class, $target) = @_;
if ($INC{"Moo/HandleMoose.pm"}) {
Moo::HandleMoose::maybe_reinject_fake_metaclass_for($target);
}
}
sub methods_provided_by {
my ($self, $role) = @_;
_load_module($role);
$self->_inhale_if_moose($role);
die "${role} is not a Moo::Role" unless $self->is_role($role);
return $self->SUPER::methods_provided_by($role);
}
sub is_role {
my ($self, $role) = @_;
$self->_inhale_if_moose($role);
$self->SUPER::is_role($role);
}
sub _inhale_if_moose {
my ($self, $role) = @_;
my $meta;
if (!$self->SUPER::is_role($role)
and (
$INC{"Moose.pm"}
and $meta = Class::MOP::class_of($role)
and ref $meta ne 'Moo::HandleMoose::FakeMetaClass'
and $meta->isa('Moose::Meta::Role')
)
or (
Mouse::Util->can('find_meta')
and $meta = Mouse::Util::find_meta($role)
and $meta->isa('Mouse::Meta::Role')
)
) {
my $is_mouse = $meta->isa('Mouse::Meta::Role');
$INFO{$role}{methods} = {
map +($_ => $role->can($_)),
grep $role->can($_),
grep !($is_mouse && $_ eq 'meta'),
grep !$meta->get_method($_)->isa('Class::MOP::Method::Meta'),
$meta->get_method_list
};
$APPLIED_TO{$role} = {
map +($_->name => 1), $meta->calculate_all_roles
};
$INFO{$role}{requires} = [ $meta->get_required_method_list ];
$INFO{$role}{attributes} = [
map +($_ => do {
my $attr = $meta->get_attribute($_);
my $spec = { %{ $is_mouse ? $attr : $attr->original_options } };
if ($spec->{isa}) {
my $get_constraint = do {
my $pkg = $is_mouse
? 'Mouse::Util::TypeConstraints'
: 'Moose::Util::TypeConstraints';
_load_module($pkg);
$pkg->can('find_or_create_isa_type_constraint');
};
my $tc = $get_constraint->($spec->{isa});
my $check = $tc->_compiled_type_constraint;
$spec->{isa} = sub {
&$check or die "Type constraint failed for $_[0]"
};
if ($spec->{coerce}) {
# Mouse has _compiled_type_coercion straight on the TC object
$spec->{coerce} = $tc->${\(
$tc->can('coercion')||sub { $_[0] }
)}->_compiled_type_coercion;
}
}
$spec;
}), $meta->get_attribute_list
];
my $mods = $INFO{$role}{modifiers} = [];
foreach my $type (qw(before after around)) {
# Mouse pokes its own internals so we have to fall back to doing
# the same thing in the absence of the Moose API method
my $map = $meta->${\(
$meta->can("get_${type}_method_modifiers_map")
or sub { shift->{"${type}_method_modifiers"} }
)};
foreach my $method (keys %$map) {
foreach my $mod (@{$map->{$method}}) {
push @$mods, [ $type => $method => $mod ];
}
}
}
require Class::Method::Modifiers if @$mods;
$INFO{$role}{inhaled_from_moose} = 1;
$INFO{$role}{is_role} = 1;
}
}
sub _maybe_make_accessors {
my ($self, $target, $role) = @_;
my $m;
if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}
or $INC{"Moo.pm"}
and $m = Moo->_accessor_maker_for($target)
and ref($m) ne 'Method::Generate::Accessor') {
$self->_make_accessors($target, $role);
}
}
sub _make_accessors_if_moose {
my ($self, $target, $role) = @_;
if ($INFO{$role} && $INFO{$role}{inhaled_from_moose}) {
$self->_make_accessors($target, $role);
}
}
sub _make_accessors {
my ($self, $target, $role) = @_;
my $acc_gen = ($Moo::MAKERS{$target}{accessor} ||= do {
require Method::Generate::Accessor;
Method::Generate::Accessor->new
});
my $con_gen = $Moo::MAKERS{$target}{constructor};
my @attrs = @{$INFO{$role}{attributes}||[]};
while (my ($name, $spec) = splice @attrs, 0, 2) {
# needed to ensure we got an index for an arrayref based generator
if ($con_gen) {
$spec = $con_gen->all_attribute_specs->{$name};
}
$acc_gen->generate_method($target, $name, $spec);
}
}
sub role_application_steps {
qw(_handle_constructor _maybe_make_accessors),
$_[0]->SUPER::role_application_steps;
}
sub apply_roles_to_package {
my ($me, $to, @roles) = @_;
foreach my $role (@roles) {
_load_module($role);
$me->_inhale_if_moose($role);
die "${role} is not a Moo::Role" unless $me->is_role($role);
}
$me->SUPER::apply_roles_to_package($to, @roles);
}
sub apply_single_role_to_package {
my ($me, $to, $role) = @_;
_load_module($role);
$me->_inhale_if_moose($role);
die "${role} is not a Moo::Role" unless $me->is_role($role);
$me->SUPER::apply_single_role_to_package($to, $role);
}
sub create_class_with_roles {
my ($me, $superclass, @roles) = @_;
my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles);
return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
foreach my $role (@roles) {
_load_module($role);
$me->_inhale_if_moose($role);
}
my $m;
if ($INC{"Moo.pm"}
and $m = Moo->_accessor_maker_for($superclass)
and ref($m) ne 'Method::Generate::Accessor') {
# old fashioned way time.
*{_getglob("${new_name}::ISA")} = [ $superclass ];
$Moo::MAKERS{$new_name} = {is_class => 1};
$me->apply_roles_to_package($new_name, @roles);
_set_loaded($new_name, (caller)[1]);
return $new_name;
}
$me->SUPER::create_class_with_roles($superclass, @roles);
foreach my $role (@roles) {
die "${role} is not a Moo::Role" unless $me->is_role($role);
}
$Moo::MAKERS{$new_name} = {is_class => 1};
$me->_handle_constructor($new_name, $_) for @roles;
_set_loaded($new_name, (caller)[1]);
return $new_name;
}
sub apply_roles_to_object {
my ($me, $object, @roles) = @_;
my $new = $me->SUPER::apply_roles_to_object($object, @roles);
_set_loaded(ref $new, (caller)[1]);
my $apply_defaults = $APPLY_DEFAULTS{ref $new} ||= do {
my %attrs = map { @{$INFO{$_}{attributes}||[]} } @roles;
if ($INC{'Moo.pm'}
and keys %attrs
and my $con_gen = Moo->_constructor_maker_for(ref $new)
and my $m = Moo->_accessor_maker_for(ref $new)) {
require Sub::Quote;
my $specs = $con_gen->all_attribute_specs;
my $assign = "{no warnings 'void';\n";
my %captures;
foreach my $name ( keys %attrs ) {
my $spec = $specs->{$name};
if ($m->has_eager_default($name, $spec)) {
my ($has, $has_cap)
= $m->generate_simple_has('$_[0]', $name, $spec);
my ($code, $pop_cap)
= $m->generate_use_default('$_[0]', $name, $spec, $has);
$assign .= $code . ";\n";
@captures{keys %$has_cap, keys %$pop_cap}
= (values %$has_cap, values %$pop_cap);
}
}
$assign .= "}";
Sub::Quote::quote_sub($assign, \%captures);
}
else {
sub {};
}
};
$new->$apply_defaults;
return $new;
}
sub _composable_package_for {
my ($self, $role) = @_;
my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
return $composed_name if $Role::Tiny::COMPOSED{role}{$composed_name};
$self->_make_accessors_if_moose($composed_name, $role);
$self->SUPER::_composable_package_for($role);
}
sub _install_single_modifier {
my ($me, @args) = @_;
_install_modifier(@args);
}
sub _install_does {
my ($me, $to) = @_;
# If Role::Tiny actually installed the DOES, give it a name
my $new = $me->SUPER::_install_does($to) or return;
return _name_coderef("${to}::DOES", $new);
}
sub does_role {
my ($proto, $role) = @_;
return 1
if Role::Tiny::does_role($proto, $role);
my $meta;
if ($INC{'Moose.pm'}
and $meta = Class::MOP::class_of($proto)
and ref $meta ne 'Moo::HandleMoose::FakeMetaClass'
and $meta->can('does_role')
) {
return $meta->does_role($role);
}
return 0;
}
sub _handle_constructor {
my ($me, $to, $role) = @_;
my $attr_info = $INFO{$role} && $INFO{$role}{attributes};
return unless $attr_info && @$attr_info;
my $info = $INFO{$to};
my $con = $INC{"Moo.pm"} && Moo->_constructor_maker_for($to);
my %existing
= $info ? @{$info->{attributes} || []}
: $con ? %{$con->all_attribute_specs || {}}
: ();
my @attr_info =
map { @{$attr_info}[$_, $_+1] }
grep { ! $existing{$attr_info->[$_]} }
map { 2 * $_ } 0..@$attr_info/2-1;
if ($info) {
push @{$info->{attributes}||=[]}, @attr_info;
}
elsif ($con) {
# shallow copy of the specs since the constructor will assign an index
$con->register_attribute_specs(map ref() ? { %$_ } : $_, @attr_info);
}
}
1;
__END__
=head1 NAME
Moo::Role - Minimal Object Orientation support for Roles
=head1 SYNOPSIS
package My::Role;
use Moo::Role;
use strictures 2;
sub foo { ... }
sub bar { ... }
has baz => (
is => 'ro',
);
1;
And elsewhere:
package Some::Class;
use Moo;
use strictures 2;
# bar gets imported, but not foo
with('My::Role');
sub foo { ... }
1;
=head1 DESCRIPTION
C<Moo::Role> builds upon L<Role::Tiny>, so look there for most of the
documentation on how this works. The main addition here is extra bits to make
the roles more "Moosey;" which is to say, it adds L</has>.
=head1 IMPORTED SUBROUTINES
See L<Role::Tiny/IMPORTED SUBROUTINES> for all the other subroutines that are
imported by this module.
=head2 has
has attr => (
is => 'ro',
);
Declares an attribute for the class to be composed into. See
L<Moo/has> for all options.
=head1 CLEANING UP IMPORTS
L<Moo::Role> cleans up its own imported methods and any imports
declared before the C<use Moo::Role> statement automatically.
Anything imported after C<use Moo::Role> will be composed into
consuming packages. A package that consumes this role:
package My::Role::ID;
use Digest::MD5 qw(md5_hex);
use Moo::Role;
use Digest::SHA qw(sha1_hex);
requires 'name';
sub as_md5 { my ($self) = @_; return md5_hex($self->name); }
sub as_sha1 { my ($self) = @_; return sha1_hex($self->name); }
1;
..will now have a C<< $self->sha1_hex() >> method available to it
that probably does not do what you expect. On the other hand, a call
to C<< $self->md5_hex() >> will die with the helpful error message:
C<Can't locate object method "md5_hex">.
See L<Moo/"CLEANING UP IMPORTS"> for more details.
=head1 SUPPORT
See L<Moo> for support and contact information.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut
MOO_ROLE
$fatpacked{"Moo/_Utils.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO__UTILS';
package Moo::_Utils;
no warnings 'once'; # guard against -w
sub _getglob { \*{$_[0]} }
sub _getstash { \%{"$_[0]::"} }
use constant lt_5_8_3 => ( $] < 5.008003 or $ENV{MOO_TEST_PRE_583} ) ? 1 : 0;
use constant can_haz_subutil => (
$INC{"Sub/Util.pm"}
|| ( !$INC{"Sub/Name.pm"} && eval { require Sub::Util } )
) && defined &Sub::Util::set_subname;
use constant can_haz_subname => (
$INC{"Sub/Name.pm"}
|| ( !$INC{"Sub/Util.pm"} && eval { require Sub::Name } )
) && defined &Sub::Name::subname;
use Moo::_strictures;
use Module::Runtime qw(use_package_optimistically module_notional_filename);
use Devel::GlobalDestruction ();
use Exporter qw(import);
use Moo::_mro;
use Config;
our @EXPORT = qw(
_getglob _install_modifier _load_module _maybe_load_module
_get_linear_isa _getstash _install_coderef _name_coderef
_unimport_coderefs _in_global_destruction _set_loaded
);
sub _in_global_destruction ();
*_in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction;
sub _install_modifier {
my ($into, $type, $name, $code) = @_;
if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
require Sub::Defer;
Sub::Defer::undefer_sub($to_modify);
}
Class::Method::Modifiers::install_modifier(@_);
}
our %MAYBE_LOADED;
sub _load_module {
my $module = $_[0];
my $file = module_notional_filename($module);
use_package_optimistically($module);
return 1
if $INC{$file};
my $error = $@ || "Can't locate $file";
# can't just ->can('can') because a sub-package Foo::Bar::Baz
# creates a 'Baz::' key in Foo::Bar's symbol table
my $stash = _getstash($module)||{};
return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash;
return 1
if $INC{"Moose.pm"} && Class::MOP::class_of($module)
or Mouse::Util->can('find_meta') && Mouse::Util::find_meta($module);
die $error;
}
sub _maybe_load_module {
my $module = $_[0];
return $MAYBE_LOADED{$module}
if exists $MAYBE_LOADED{$module};
if(! eval { use_package_optimistically($module) }) {
warn "$module exists but failed to load with error: $@";
}
elsif ( $INC{module_notional_filename($module)} ) {
return $MAYBE_LOADED{$module} = 1;
}
return $MAYBE_LOADED{$module} = 0;
}
sub _set_loaded {
$INC{Module::Runtime::module_notional_filename($_[0])} ||= $_[1];
}
sub _get_linear_isa {
return mro::get_linear_isa($_[0]);
}
sub _install_coderef {
my ($glob, $code) = (_getglob($_[0]), _name_coderef(@_));
no warnings 'redefine';
if (*{$glob}{CODE}) {
*{$glob} = $code;
}
# perl will sometimes warn about mismatched prototypes coming from the
# inheritance cache, so disable them if we aren't redefining a sub
else {
no warnings 'prototype';
*{$glob} = $code;
}
}
sub _name_coderef {
shift if @_ > 2; # three args is (target, name, sub)
can_haz_subutil ? Sub::Util::set_subname(@_) :
can_haz_subname ? Sub::Name::subname(@_) : $_[1];
}
sub _unimport_coderefs {
my ($target, $info) = @_;
return unless $info and my $exports = $info->{exports};
my %rev = reverse %$exports;
my $stash = _getstash($target);
foreach my $name (keys %$exports) {
if ($stash->{$name} and defined(&{$stash->{$name}})) {
if ($rev{$target->can($name)}) {
my $old = delete $stash->{$name};
my $full_name = join('::',$target,$name);
# Copy everything except the code slot back into place (e.g. $has)
foreach my $type (qw(SCALAR HASH ARRAY IO)) {
next unless defined(*{$old}{$type});
no strict 'refs';
*$full_name = *{$old}{$type};
}
}
}
}
}
if ($Config{useithreads}) {
require Moo::HandleMoose::_TypeMap;
}
1;
MOO__UTILS
$fatpacked{"Moo/_mro.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO__MRO';
package Moo::_mro;
use Moo::_strictures;
if ($] >= 5.010) {
require mro;
} else {
require MRO::Compat;
}
1;
MOO__MRO
$fatpacked{"Moo/_strictures.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO__STRICTURES';
package Moo::_strictures;
use strict;
use warnings;
sub import {
if ($ENV{MOO_FATAL_WARNINGS}) {
require strictures;
strictures->VERSION(2);
@_ = ('strictures');
goto &strictures::import;
}
else {
strict->import;
warnings->import;
}
}
1;
MOO__STRICTURES
$fatpacked{"Moo/sification.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MOO_SIFICATION';
package Moo::sification;
use Moo::_strictures;
no warnings 'once';
use Devel::GlobalDestruction qw(in_global_destruction);
sub unimport {
die "Can't disable Moo::sification after inflation has been done"
if $Moo::HandleMoose::SETUP_DONE;
our $disabled = 1;
}
sub Moo::HandleMoose::AuthorityHack::DESTROY {
unless (our $disabled or in_global_destruction) {
require Moo::HandleMoose;
Moo::HandleMoose->import;
}
}
sub import {
return
if our $setup_done;
if ($INC{"Moose.pm"}) {
require Moo::HandleMoose;
Moo::HandleMoose->import;
} else {
$Moose::AUTHORITY = bless({}, 'Moo::HandleMoose::AuthorityHack');
}
$setup_done = 1;
}
1;
MOO_SIFICATION
$fatpacked{"Sub/Defer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_DEFER';
package Sub::Defer;
use Moo::_strictures;
use Exporter qw(import);
use Moo::_Utils qw(_getglob _install_coderef);
use Scalar::Util qw(weaken);
our $VERSION = '2.000002';
$VERSION = eval $VERSION;
our @EXPORT = qw(defer_sub undefer_sub undefer_all);
our @EXPORT_OK = qw(undefer_package);
our %DEFERRED;
sub undefer_sub {
my ($deferred) = @_;
my ($target, $maker, $undeferred_ref) = @{
$DEFERRED{$deferred}||return $deferred
};
return ${$undeferred_ref}
if ${$undeferred_ref};
${$undeferred_ref} = my $made = $maker->();
# make sure the method slot has not changed since deferral time
if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
no warnings 'redefine';
# I believe $maker already evals with the right package/name, so that
# _install_coderef calls are not necessary --ribasushi
*{_getglob($target)} = $made;
}
$DEFERRED{$made} = $DEFERRED{$deferred};
weaken $DEFERRED{$made}
unless $target;
return $made;
}
sub undefer_all {
undefer_sub($_) for keys %DEFERRED;
return;
}
sub undefer_package {
my $package = shift;
my @subs = grep { $DEFERRED{$_}[0] =~ /^${package}::[^:]+$/ } keys %DEFERRED;
undefer_sub($_) for @subs;
return;
}
sub defer_info {
my ($deferred) = @_;
my $info = $DEFERRED{$deferred||''} or return undef;
[ @$info ];
}
sub defer_sub {
my ($target, $maker) = @_;
my $undeferred;
my $deferred_info;
my $deferred = sub {
$undeferred ||= undefer_sub($deferred_info->[3]);
goto &$undeferred;
};
$deferred_info = [ $target, $maker, \$undeferred, $deferred ];
weaken($deferred_info->[3]);
weaken($DEFERRED{$deferred} = $deferred_info);
_install_coderef($target => $deferred) if defined $target;
return $deferred;
}
sub CLONE {
%DEFERRED = map { defined $_ && $_->[3] ? ($_->[3] => $_) : () } values %DEFERRED;
foreach my $info (values %DEFERRED) {
weaken($info)
unless $info->[0] && ${$info->[2]};
}
}
1;
__END__
=head1 NAME
Sub::Defer - defer generation of subroutines until they are first called
=head1 SYNOPSIS
use Sub::Defer;
my $deferred = defer_sub 'Logger::time_since_first_log' => sub {
my $t = time;
sub { time - $t };
};
Logger->time_since_first_log; # returns 0 and replaces itself
Logger->time_since_first_log; # returns time - $t
=head1 DESCRIPTION
These subroutines provide the user with a convenient way to defer creation of
subroutines and methods until they are first called.
=head1 SUBROUTINES
=head2 defer_sub
my $coderef = defer_sub $name => sub { ... };
This subroutine returns a coderef that encapsulates the provided sub - when
it is first called, the provided sub is called and is -itself- expected to
return a subroutine which will be goto'ed to on subsequent calls.
If a name is provided, this also installs the sub as that name - and when
the subroutine is undeferred will re-install the final version for speed.
Exported by default.
=head2 undefer_sub
my $coderef = undefer_sub \&Foo::name;
If the passed coderef has been L<deferred|/defer_sub> this will "undefer" it.
If the passed coderef has not been deferred, this will just return it.
If this is confusing, take a look at the example in the L</SYNOPSIS>.
Exported by default.
=head2 undefer_all
undefer_all();
This will undefer all defered subs in one go. This can be very useful in a
forking environment where child processes would each have to undefer the same
subs. By calling this just before you start forking children you can undefer
all currently deferred subs in the parent so that the children do not have to
do it. Note this may bake the behavior of some subs that were intended to
calculate their behavior later, so it shouldn't be used midway through a
module load or class definition.
Exported by default.
=head2 undefer_package
undefer_package($package);
This undefers all defered subs in a package.
Not exported by default.
=head1 SUPPORT
See L<Moo> for support and contact information.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut
SUB_DEFER
$fatpacked{"Sub/Quote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SUB_QUOTE';
package Sub::Quote;
sub _clean_eval { eval $_[0] }
use Moo::_strictures;
use Sub::Defer qw(defer_sub);
use Scalar::Util qw(weaken);
use Exporter qw(import);
use B ();
BEGIN {
*_HAVE_PERLSTRING = defined &B::perlstring ? sub(){1} : sub(){0};
}
our $VERSION = '2.000002';
$VERSION = eval $VERSION;
our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub qsub);
our @EXPORT_OK = qw(quotify capture_unroll inlinify);
our %QUOTED;
sub quotify {
! defined $_[0] ? 'undef()'
: _HAVE_PERLSTRING ? B::perlstring($_[0])
: qq["\Q$_[0]\E"];
}
sub capture_unroll {
my ($from, $captures, $indent) = @_;
join(
'',
map {
/^([\@\%\$])/
or die "capture key should start with \@, \% or \$: $_";
(' ' x $indent).qq{my ${_} = ${1}{${from}->{${\quotify $_}}};\n};
} keys %$captures
);
}
sub inlinify {
my ($code, $args, $extra, $local) = @_;
my $do = 'do { '.($extra||'');
if ($code =~ s/^(\s*package\s+([a-zA-Z0-9:]+);)//) {
$do .= $1;
}
if ($code =~ s{
\A((?:\#\ BEGIN\ quote_sub\ PRELUDE\n.*?\#\ END\ quote_sub\ PRELUDE\n)?\s*)
(^\s*) my \s* \(([^)]+)\) \s* = \s* \@_;
}{}xms) {
my ($pre, $indent, $code_args) = ($1, $2, $3);
$do .= $pre;
if ($code_args ne $args) {
$do .= $indent . 'my ('.$code_args.') = ('.$args.'); ';
}
}
elsif ($local || $args ne '@_') {
$do .= ($local ? 'local ' : '').'@_ = ('.$args.'); ';
}
$do.$code.' }';
}
sub quote_sub {
# HOLY DWIMMERY, BATMAN!
# $name => $code => \%captures => \%options
# $name => $code => \%captures
# $name => $code
# $code => \%captures => \%options
# $code
my $options =
(ref($_[-1]) eq 'HASH' and ref($_[-2]) eq 'HASH')
? pop
: {};
my $captures = ref($_[-1]) eq 'HASH' ? pop : undef;
undef($captures) if $captures && !keys %$captures;
my $code = pop;
my $name = $_[0];
my ($package, $hints, $bitmask, $hintshash) = (caller(0))[0,8,9,10];
my $context
="# BEGIN quote_sub PRELUDE\n"
."package $package;\n"
."BEGIN {\n"
." \$^H = ".quotify($hints).";\n"
." \${^WARNING_BITS} = ".quotify($bitmask).";\n"
." \%^H = (\n"
. join('', map
" ".quotify($_)." => ".quotify($hintshash->{$_}).",",
keys %$hintshash)
." );\n"
."}\n"
."# END quote_sub PRELUDE\n";
$code = "$context$code";
my $quoted_info;
my $unquoted;
my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
$unquoted if 0;
unquote_sub($quoted_info->[4]);
};
$quoted_info = [ $name, $code, $captures, \$unquoted, $deferred ];
weaken($quoted_info->[3]);
weaken($quoted_info->[4]);
weaken($QUOTED{$deferred} = $quoted_info);
return $deferred;
}
sub quoted_from_sub {
my ($sub) = @_;
my $quoted_info = $QUOTED{$sub||''} or return undef;
my ($name, $code, $captured, $unquoted, $deferred) = @{$quoted_info};
$unquoted &&= $$unquoted;
if (($deferred && $deferred eq $sub)
|| ($unquoted && $unquoted eq $sub)) {
return [ $name, $code, $captured, $unquoted, $deferred ];
}
return undef;
}
sub unquote_sub {
my ($sub) = @_;
my $quoted = $QUOTED{$sub} or return undef;
my $unquoted = $quoted->[3];
unless ($unquoted && $$unquoted) {
my ($name, $code, $captures) = @$quoted;
my $make_sub = "{\n";
my %captures = $captures ? %$captures : ();
$captures{'$_UNQUOTED'} = \$unquoted;
$captures{'$_QUOTED'} = \$quoted;
$make_sub .= capture_unroll("\$_[1]", \%captures, 2);
$make_sub .= (
$name
# disable the 'variable $x will not stay shared' warning since
# we're not letting it escape from this scope anyway so there's
# nothing trying to share it
? " no warnings 'closure';\n sub ${name} {\n"
: " \$\$_UNQUOTED = sub {\n"
);
$make_sub .= " \$_QUOTED if 0;\n";
$make_sub .= " \$_UNQUOTED if 0;\n";
$make_sub .= $code;
$make_sub .= " }".($name ? '' : ';')."\n";
if ($name) {
$make_sub .= " \$\$_UNQUOTED = \\&${name}\n";
}
$make_sub .= "}\n1;\n";
$ENV{SUB_QUOTE_DEBUG} && warn $make_sub;
{
no strict 'refs';
local *{$name} if $name;
my ($success, $e);
{
local $@;
$success = _clean_eval($make_sub, \%captures);
$e = $@;
}
unless ($success) {
die "Eval went very, very wrong:\n\n${make_sub}\n\n$e";
}
weaken($QUOTED{$$unquoted} = $quoted);
}
}
$$unquoted;
}
sub qsub ($) {
goto "e_sub;
}
sub CLONE {
%QUOTED = map { defined $_ ? (
$_->[3] && ${$_->[3]} ? (${ $_->[3] } => $_) : (),
$_->[4] ? ($_->[4] => $_) : (),
) : () } values %QUOTED;
weaken($_) for values %QUOTED;
}
1;
__END__
=head1 NAME
Sub::Quote - efficient generation of subroutines via string eval
=head1 SYNOPSIS
package Silly;
use Sub::Quote qw(quote_sub unquote_sub quoted_from_sub);
quote_sub 'Silly::kitty', q{ print "meow" };
quote_sub 'Silly::doggy', q{ print "woof" };
my $sound = 0;
quote_sub 'Silly::dagron',
q{ print ++$sound % 2 ? 'burninate' : 'roar' },
{ '$sound' => \$sound };
And elsewhere:
Silly->kitty; # meow
Silly->doggy; # woof
Silly->dagron; # burninate
Silly->dagron; # roar
Silly->dagron; # burninate
=head1 DESCRIPTION
This package provides performant ways to generate subroutines from strings.
=head1 SUBROUTINES
=head2 quote_sub
my $coderef = quote_sub 'Foo::bar', q{ print $x++ . "\n" }, { '$x' => \0 };
Arguments: ?$name, $code, ?\%captures, ?\%options
C<$name> is the subroutine where the coderef will be installed.
C<$code> is a string that will be turned into code.
C<\%captures> is a hashref of variables that will be made available to the
code. The keys should be the full name of the variable to be made available,
including the sigil. The values should be references to the values. The
variables will contain copies of the values. See the L</SYNOPSIS>'s
C<Silly::dagron> for an example using captures.
=head3 options
=over 2
=item * no_install
B<Boolean>. Set this option to not install the generated coderef into the
passed subroutine name on undefer.
=back
=head2 unquote_sub
my $coderef = unquote_sub $sub;
Forcibly replace subroutine with actual code.
If $sub is not a quoted sub, this is a no-op.
=head2 quoted_from_sub
my $data = quoted_from_sub $sub;
my ($name, $code, $captures, $compiled_sub) = @$data;
Returns original arguments to quote_sub, plus the compiled version if this
sub has already been unquoted.
Note that $sub can be either the original quoted version or the compiled
version for convenience.
=head2 inlinify
my $prelude = capture_unroll '$captures', {
'$x' => 1,
'$y' => 2,
}, 4;
my $inlined_code = inlinify q{
my ($x, $y) = @_;
print $x + $y . "\n";
}, '$x, $y', $prelude;
Takes a string of code, a string of arguments, a string of code which acts as a
"prelude", and a B<Boolean> representing whether or not to localize the
arguments.
=head2 quotify
my $quoted_value = quotify $value;
Quotes a single (non-reference) scalar value for use in a code string. Numbers
aren't treated specially and will be quoted as strings, but undef will quoted as
C<undef()>.
=head2 capture_unroll
my $prelude = capture_unroll '$captures', {
'$x' => 1,
'$y' => 2,
}, 4;
Arguments: $from, \%captures, $indent
Generates a snippet of code which is suitable to be used as a prelude for
L</inlinify>. C<$from> is a string will be used as a hashref in the resulting
code. The keys of C<%captures> are the names of the variables and the values
are ignored. C<$indent> is the number of spaces to indent the result by.
=head2 qsub
my $hash = {
coderef => qsub q{ print "hello"; },
other => 5,
};
Arguments: $code
Works exactly like L</quote_sub>, but includes a prototype to only accept a
single parameter. This makes it easier to include in hash structures or lists.
=head1 CAVEATS
Much of this is just string-based code-generation, and as a result, a few
caveats apply.
=head2 return
Calling C<return> from a quote_sub'ed sub will not likely do what you intend.
Instead of returning from the code you defined in C<quote_sub>, it will return
from the overall function it is composited into.
So when you pass in:
quote_sub q{ return 1 if $condition; $morecode }
It might turn up in the intended context as follows:
sub foo {
<important code a>
do {
return 1 if $condition;
$morecode
};
<important code b>
}
Which will obviously return from foo, when all you meant to do was return from
the code context in quote_sub and proceed with running important code b.
=head2 pragmas
C<Sub::Quote> preserves the environment of the code creating the
quoted subs. This includes the package, strict, warnings, and any
other lexical pragmas. This is done by prefixing the code with a
block that sets up a matching environment. When inlining C<Sub::Quote>
subs, care should be taken that user pragmas won't effect the rest
of the code.
=head1 SUPPORT
See L<Moo> for support and contact information.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut
SUB_QUOTE
$fatpacked{"Tak.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK';
package Tak;
use Tak::Loop;
use strictures 1;
our $VERSION = '0.001004'; # 0.1.4
our ($loop, $did_upgrade);
sub loop { $loop ||= Tak::Loop->new }
sub loop_upgrade {
return if $did_upgrade;
require IO::Async::Loop;
my $new_loop = IO::Async::Loop->new;
$loop->pass_watches_to($new_loop) if $loop;
$loop = $new_loop;
$did_upgrade = 1;
}
sub loop_until {
my ($class, $done) = @_;
return if $done;
$class->loop->loop_once until $_[1];
}
sub await_all {
my ($class, @requests) = @_;
@requests = grep !$_->is_done, @requests;
return unless @requests;
my %req = map +("$_" => "$_"), @requests;
my $done;
my %on_r = map {
my $orig = $_->{on_result};
my $tag = $req{$_};
($_ => sub { delete $req{$tag}; $orig->(@_); $done = 1 unless keys %req; })
} @requests;
my $call = sub { $class->loop_until($done) };
foreach (@requests) {
my $req = $_;
my $inner = $call;
$call = sub { local $req->{on_result} = $on_r{$req}; $inner->() };
}
$call->();
return;
}
1;
=head1 NAME
Tak - Multi host remote control over ssh (then I wrote Object::Remote)
=head1 SYNOPSIS
# Curse at mst for doing it again under a different name
# Curse at mst some more
$ cpanm Object::Remote
# Now go use that
(sorry, I should've done a tombstone release ages back)
bin/tak -h user1@host1 -h user2@host2 exec cat /etc/hostname
or
in Takfile:
package Tak::MyScript;
use Tak::Takfile;
use Tak::ObjectClient;
sub each_get_homedir {
my ($self, $remote) = @_;
my $oc = Tak::ObjectClient->new(remote => $remote);
my $home = $oc->new_object('Path::Class::Dir')->absolute->stringify;
$self->stdout->print(
$remote->host.': '.$home."\n"
);
}
1;
then
tak -h something get-homedir
=head1 WHERE'S THE REST?
A drink leaked in my bag on the way back from LPW. My laptop is finally
alive again though so I'll try and turn my slides into a vague attempt
at documentation while I'm traveling to/from christmas things.
=head1 Example
$ cat Takfile
package Tak::MyScript;
use strict;
use warnings;
use Tak::Takfile;
use Tak::ObjectClient;
use lib "./lib";
sub each_host {
my ($self, $remote) = @_;
my $oc = Tak::ObjectClient->new(remote => $remote);
my $name = $oc->new_object('My::Hostname');
print "Connected to hostname: " . $name . "\n";
}
1;
-----
$cat ./lib/My/Hostname
package My::Hostname;
use Sys::Hostname;
sub new {
my ($self) = @_;
my $name = hostname;
return $name;
}
1;
=head1 AUTHOR
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
=head1 CONTRIBUTORS
None required yet. Maybe this module is perfect (hahahahaha ...).
=head1 COPYRIGHT
Copyright (c) 2011 the Tak L</AUTHOR> and L</CONTRIBUTORS>
as listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself.
=cut
TAK
$fatpacked{"Tak/Client.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_CLIENT';
package Tak::Client;
use Tak;
use Tak::Request;
use Moo;
has service => (is => 'ro', required => 1);
has curried => (is => 'ro', default => sub { [] });
sub curry {
my ($self, @curry) = @_;
(ref $self)->new(%$self, curried => [ @{$self->curried}, @curry ]);
}
sub send { shift->receive(@_) }
sub receive {
my ($self, @message) = @_;
$self->service->receive(@{$self->curried}, @message);
}
sub start {
my ($self, $register, @payload) = @_;
my $req = $self->_new_request($register);
$self->start_request($req, @payload);
return $req;
}
sub start_request {
my ($self, $req, @payload) = @_;
$self->service->start_request($req, @{$self->curried}, @payload);
}
sub request_class { 'Tak::Request' }
sub _new_request {
my ($self, $args) = @_;
$self->request_class->new($args);
}
sub do {
shift->result_of(@_)->get;
}
sub result_of {
my ($self, @payload) = @_;
my $done;
my $result;
my $req = $self->start({
on_result => sub { $result = shift },
}, @payload);
Tak->loop_until($result);
return $result;
}
sub clone_or_self {
my ($self) = @_;
(ref $self)->new(
service => $self->service->clone_or_self,
curried => [ @{$self->curried} ],
);
}
1;
TAK_CLIENT
$fatpacked{"Tak/Client/RemoteRouter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_CLIENT_REMOTEROUTER';
package Tak::Client::RemoteRouter;
use Moo;
extends 'Tak::Client::Router';
has host => (is => 'ro', required => 1);
1;
TAK_CLIENT_REMOTEROUTER
$fatpacked{"Tak/Client/Router.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_CLIENT_ROUTER';
package Tak::Client::Router;
use Moo;
extends 'Tak::Client';
sub ensure {
shift->do(meta => ensure => @_);
}
1;
TAK_CLIENT_ROUTER
$fatpacked{"Tak/CommandService.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_COMMANDSERVICE';
package Tak::CommandService;
use Capture::Tiny qw(capture);
use IPC::System::Simple qw(runx EXIT_ANY);
use IPC::Open3;
use Symbol qw(gensym);
use Moo;
with 'Tak::Role::Service';
sub handle_exec {
my ($self, $command) = @_;
my $code;
my ($stdout, $stderr) = capture {
$code = runx(EXIT_ANY, @$command);
};
return { stdout => $stdout, stderr => $stderr, exit_code => $code };
}
sub start_stream_exec_request {
my ($self, $req, $command) = @_;
my $err = gensym;
my $pid = open3(my $in, my $out, $err, @$command)
or return $req->failure("Couldn't spawn process: $!");
close($in); # bye
my $done = sub {
Tak->loop->unwatch_io(handle => $_, on_read_ready => 1)
for ($out, $err);
waitpid($pid, 0);
$req->success({ exit_code => $? });
};
my $outbuf = '';
my $errbuf = '';
Tak->loop->watch_io(
handle => $out,
on_read_ready => sub {
if (sysread($out, $outbuf, 1024, length($outbuf)) > 0) {
$req->progress(stdout => $1) while $outbuf =~ s/^(.*)\n//;
} else {
$req->progress(stdout => $outbuf) if $outbuf;
$req->progress(stderr => $errbuf) if $errbuf;
$done->();
}
}
);
Tak->loop->watch_io(
handle => $err,
on_read_ready => sub {
if (sysread($err, $errbuf, 1024, length($errbuf)) > 0) {
$req->progress(stderr => $1) while $errbuf =~ s/^(.*)\n//;
}
}
);
}
1;
TAK_COMMANDSERVICE
$fatpacked{"Tak/ConnectionReceiver.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_CONNECTIONRECEIVER';
package Tak::ConnectionReceiver;
use Tak::Request;
use Scalar::Util qw(weaken);
use Log::Contextual qw(:log);
use Moo;
with 'Tak::Role::Service';
has requests => (is => 'ro', default => sub { {} });
has channel => (is => 'ro', required => 1);
has service => (is => 'ro', required => 1);
has on_close => (is => 'ro', required => 1);
sub BUILD {
weaken(my $self = shift);
my $channel = $self->channel;
Tak->loop->watch_io(
handle => $channel->read_fh,
on_read_ready => sub {
$channel->read_messages(sub { $self->receive(@_) });
}
);
}
sub DEMOLISH {
Tak->loop->unwatch_io(
handle => $_[0]->channel->read_fh,
on_read_ready => 1,
);
}
sub receive_request {
my ($self, $tag, $meta, @payload) = @_;
my $channel = $self->channel;
unless (ref($meta) eq 'HASH') {
$channel->write_message(mistake => $tag => 'meta value not a hashref');
return;
}
my $req = Tak::Request->new(
($meta->{progress}
? (on_progress => sub { $channel->write_message(progress => $tag => @_) })
: ()),
on_result => sub { $channel->write_message(result => $tag => $_[0]->flatten) }
);
$self->service->start_request($req => @payload);
}
sub receive_progress {
my ($self, $tag, @payload) = @_;
$self->requests->{$tag}->progress(@payload);
}
sub receive_result {
my ($self, $tag, @payload) = @_;
(delete $self->requests->{$tag})->result(@payload);
}
sub receive_message {
my ($self, @payload) = @_;
$self->service->receive(@payload);
}
sub receive_close {
my ($self, @payload) = @_;
$self->on_close->(@payload);
}
1;
TAK_CONNECTIONRECEIVER
$fatpacked{"Tak/ConnectionService.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_CONNECTIONSERVICE';
package Tak::ConnectionService;
use Tak::ConnectionReceiver;
use Tak::JSONChannel;
use Moo;
has receiver => (is => 'ro', writer => '_set_receiver');
has channel => (is => 'ro', writer => '_set_channel');
sub BUILD {
my ($self, $args) = @_;
my $channel = $self->_set_channel(
Tak::JSONChannel->new(map +($_ => $args->{$_}), qw(read_fh write_fh))
);
my $receiver = $self->_set_receiver(
Tak::ConnectionReceiver->new(
channel => $channel, service => $args->{listening_service},
on_close => $args->{on_close},
)
);
}
sub start_request {
my ($self, $req, @payload) = @_;
$self->receiver->requests->{my $tag = "$req"} = $req;
my $meta = { progress => !!$req->on_progress };
$self->channel->write_message(request => $tag => $meta => @payload);
}
sub receive {
my ($self, @payload) = @_;
$self->channel->write_message(message => @payload);
}
1;
TAK_CONNECTIONSERVICE
$fatpacked{"Tak/ConnectorService.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_CONNECTORSERVICE';
package Tak::ConnectorService;
use IPC::Open2;
use IO::Socket::UNIX;
use IO::Socket::INET; # Sucks to be v6, see comment where used
use IO::All;
use Tak::Router;
use Tak::Client;
use Tak::ConnectionService;
use Net::OpenSSH;
use Tak::STDIONode;
use Moo;
with 'Tak::Role::Service';
has connections => (is => 'ro', default => sub { Tak::Router->new });
has ssh => (is => 'ro', default => sub { {} });
sub handle_create {
my ($self, $on, %args) = @_;
die [ mistake => "No target supplied to create" ] unless $on;
my $log_level = $args{log_level}||'info';
my ($kid_in, $kid_out, $kid_pid) = $self->_open($on, $log_level);
if ($kid_pid) {
$kid_in->print($Tak::STDIONode::DATA, "__END__\n") unless $on eq '-';
# Need to get a handshake to indicate STDIOSetup has finished
# messing around with file descriptors, otherwise we can severely
# confuse things by sending before the dup.
my $up = <$kid_out>;
die [ failure => "Garbled response from child: $up" ]
unless $up eq "Shere\n";
}
my $connection = Tak::ConnectionService->new(
read_fh => $kid_out, write_fh => $kid_in,
listening_service => Tak::Router->new
);
my $client = Tak::Client->new(service => $connection);
# actually, we should register with a monotonic id and
# stash the pid elsewhere. but meh for now.
my $pid = $client->do(meta => 'pid');
my $name = $on.':'.$pid;
my $conn_router = Tak::Router->new;
$conn_router->register(local => $connection->receiver->service);
$conn_router->register(remote => $connection);
$self->connections->register($name, $conn_router);
return ($name);
}
sub _open {
my ($self, $on, @args) = @_;
if ($on eq '-') {
my $kid_pid = IPC::Open2::open2(my $kid_out, my $kid_in, 'tak-stdio-node', '-', @args)
or die "Couldn't open2 child: $!";
return ($kid_in, $kid_out, $kid_pid);
} elsif ($on =~ /^\.?\//) { # ./foo or /foo
my $sock = IO::Socket::UNIX->new($on)
or die "Couldn't open unix domain socket ${on}: $!";
return ($sock, $sock, undef);
} elsif ($on =~ /:/) { # foo:80 we hope
# IO::Socket::IP is a better answer. But can pull in XS deps.
# Well, more strictly it pulls in Socket::GetAddrInfo, which can
# actually work without its XS implementation (just doesn't handle v6)
# and I've not properly pondered how to make things like fatpacking
# Just Fucking Work in such a circumstance. First person to need IPv6
# and be reading this comment, please start a conversation about it.
my $sock = IO::Socket::INET->new(PeerAddr => $on)
or die "Couldn't open TCP socket ${on}: $!";
return ($sock, $sock, undef);
}
my $ssh = $self->ssh->{$on} ||= Net::OpenSSH->new($on);
$ssh->error and
die "Couldn't establish ssh connection: ".$ssh->error;
return $ssh->open2('perl','-', $on, @args);
}
sub start_connection_request {
my ($self, $req, @payload) = @_;;
$self->connections->start_request($req, @payload);
}
sub receive_connection {
my ($self, @payload) = @_;
$self->connections->receive(@payload);
}
1;
TAK_CONNECTORSERVICE
$fatpacked{"Tak/EvalService.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_EVALSERVICE';
package Tak::EvalService;
use Eval::WithLexicals;
use Data::Dumper::Concise;
use Capture::Tiny qw(capture);
use Moo;
with 'Tak::Role::Service';
has 'eval_withlexicals' => (is => 'lazy');
has 'service_client' => (is => 'ro', predicate => 'has_service_client');
sub _build_eval_withlexicals {
my ($self) = @_;
Eval::WithLexicals->new(
$self->has_service_client
? (lexicals => { '$client' => \($self->service_client) })
: ()
);
}
sub handle_eval {
my ($self, $perl) = @_;
unless ($perl) {
die [ mistake => eval_input => "No code supplied" ];
}
if (my $ref = ref($perl)) {
die [ mistake => eval_input => "Code was a ${ref} reference" ];
}
my ($ok, @ret);
my ($stdout, $stderr);
if (eval {
($stdout, $stderr) = capture {
@ret = $self->eval_withlexicals->eval($perl);
};
1
}) {
$ok = 1;
} else {
($ok, @ret) = (0, $@);
}
my $dumped_ret;
unless (eval { $dumped_ret = Dumper(@ret); 1 }) {
$dumped_ret = "Error dumping ${\($ok ? 'result' : 'exception')}: $@";
$ok = 0;
}
return {
stdout => $stdout, stderr => $stderr,
($ok ? 'return' : 'exception') => $dumped_ret
};
}
1;
TAK_EVALSERVICE
$fatpacked{"Tak/JSONChannel.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_JSONCHANNEL';
package Tak::JSONChannel;
use JSON::PP qw(encode_json decode_json);
use IO::Handle;
use Scalar::Util qw(weaken);
use Log::Contextual qw(:log);
use Moo;
has read_fh => (is => 'ro', required => 1);
has write_fh => (is => 'ro', required => 1);
has _read_buf => (is => 'ro', default => sub { my $x = ''; \$x });
sub BUILD { shift->write_fh->autoflush(1); }
sub read_messages {
my ($self, $cb) = @_;
my $rb = $self->_read_buf;
if (sysread($self->read_fh, $$rb, 1024, length($$rb)) > 0) {
while ($$rb =~ s/^(.*)\n//) {
my $line = $1;
log_trace { "Received $line" };
if (my $unpacked = $self->_unpack_line($line)) {
$cb->(@$unpacked);
}
}
} else {
log_trace { "Closing" };
$cb->('close', 'channel');
}
}
sub _unpack_line {
my ($self, $line) = @_;
my $data = eval { decode_json($line) };
unless ($data) {
$self->write_message(mistake => invalid_json => $@||'No data and no exception');
return;
}
unless (ref($data) eq 'ARRAY') {
$self->write_message(mistake => message_format => "Not an ARRAY");
return;
}
unless (@$data > 0) {
$self->write_message(mistake => message_format => "Empty request array");
return;
}
$data;
}
sub write_message {
my ($self, @msg) = @_;
my $json = eval { encode_json(\@msg) };
unless ($json) {
$self->_raw_write_message(
encode_json(
[ failure => invalid_message => $@||'No data and no exception' ]
)
);
return;
}
log_trace { "Sending: $json" };
$self->_raw_write_message($json);
}
sub _raw_write_message {
my ($self, $raw) = @_;
#warn "Sending: ${raw}\n";
print { $self->write_fh } $raw."\n"
or log_error { "Error writing: $!" };
}
1;
TAK_JSONCHANNEL
$fatpacked{"Tak/Loop.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_LOOP';
package Tak::Loop;
use IO::Select;
use Moo;
has is_running => (is => 'rw', clearer => 'loop_stop');
has _read_watches => (is => 'ro', default => sub { {} });
has _read_select => (is => 'ro', default => sub { IO::Select->new });
sub pass_watches_to {
my ($self, $new_loop) = @_;
foreach my $fh ($self->_read_select->handles) {
$new_loop->watch_io(
handle => $fh,
on_read_ready => $self->_read_watches->{$fh}
);
}
}
sub watch_io {
my ($self, %watch) = @_;
my $fh = $watch{handle};
if (my $cb = $watch{on_read_ready}) {
$self->_read_select->add($fh);
$self->_read_watches->{$fh} = $cb;
}
}
sub unwatch_io {
my ($self, %watch) = @_;
my $fh = $watch{handle};
if ($watch{on_read_ready}) {
$self->_read_select->remove($fh);
delete $self->_read_watches->{$fh};
}
}
sub loop_once {
my ($self) = @_;
my $read = $self->_read_watches;
my ($readable) = IO::Select->select($self->_read_select, undef, undef, 0.5);
# I would love to trap errors in the select call but IO::Select doesn't
# differentiate between an error and a timeout.
# -- no, love, mst.
foreach my $fh (@$readable) {
$read->{$fh}();
}
}
sub loop_forever {
my ($self) = @_;
$self->is_running(1);
while ($self->is_running) {
$self->loop_once;
}
}
1;
TAK_LOOP
$fatpacked{"Tak/MetaService.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_METASERVICE';
package Tak::MetaService;
use Tak::WeakClient;
use Log::Contextual qw(:log);
use Moo;
with 'Tak::Role::Service';
has router => (is => 'ro', required => 1, weak_ref => 1);
sub handle_pid {
return $$;
}
sub handle_ensure {
my $self = shift;
my ($name) = @_;
return "Already have ${name}" if $self->router->services->{$name};
$self->handle_register(@_);
}
sub handle_register {
my ($self, $name, $class, %args) = @_;
(my $file = $class) =~ s/::/\//g;
require "${file}.pm";
if (my $expose = delete $args{expose}) {
%args = (%args, %{$self->_construct_exposed_clients($expose)});
}
my $new = $class->new(\%args);
$self->router->register($name => $new);
return "Registered ${name}";
}
sub _construct_exposed_clients {
my ($self, $expose) = @_;
my $router = $self->router;
my %client;
foreach my $name (keys %$expose) {
local $_ = $expose->{$name};
if (ref eq 'HASH') {
$client{$name} = Tak::Client->new(
service => Tak::Router->new(
services => $self->_construct_exposed_clients($_)
)
);
} elsif (ref eq 'ARRAY') {
if (my ($svc, @rest) = @$_) {
die "router has no service ${svc}"
unless my $service = $router->services->{$svc};
my $client_class = (
Scalar::Util::isweak($router->services->{$svc})
? 'Tak::WeakClient'
: 'Tak::Client'
);
$client{$name} = $client_class->new(service => $service)
->curry(@rest);
} else {
$client{$name} = Tak::WeakClient->new(service => $router);
}
} else {
die "expose key ${name} was ".ref;
}
}
\%client;
}
1;
TAK_METASERVICE
$fatpacked{"Tak/ModuleLoader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_MODULELOADER';
package Tak::ModuleLoader;
use Tak::ModuleLoader::Hook;
use Moo;
with 'Tak::Role::Service';
has module_sender => (is => 'ro', required => 1);
has inc_hook => (is => 'lazy');
sub _build_inc_hook {
my ($self) = @_;
Tak::ModuleLoader::Hook->new(sender => $self->module_sender);
}
sub handle_enable {
my ($self) = @_;
push @INC, $self->inc_hook;
return 'enabled';
}
sub handle_disable {
my ($self) = @_;
my $hook = $self->inc_hook;
@INC = grep $_ ne $hook, @INC;
return 'disabled';
}
sub DEMOLISH {
my ($self) = @_;
$self->handle_disable;
}
1;
TAK_MODULELOADER
$fatpacked{"Tak/ModuleLoader/Hook.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_MODULELOADER_HOOK';
package Tak::ModuleLoader::Hook;
use Moo;
has sender => (is => 'ro', required => 1, weak_ref => 1);
sub Tak::ModuleLoader::Hook::INC { # unqualified INC forced into package main
my ($self, $module) = @_;
my $result = $self->sender->result_of(source_for => $module);
if ($result->is_success) {
my $code = $result->get;
open my $fh, '<', \$code;
return $fh;
}
return;
}
1;
TAK_MODULELOADER_HOOK
$fatpacked{"Tak/ModuleSender.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_MODULESENDER';
package Tak::ModuleSender;
use IO::All;
use List::Util qw(first);
use Config;
use Moo;
with 'Tak::Role::Service';
has dir_list => (is => 'lazy');
sub _build_dir_list {
my %core = map +($_ => 1), @Config{qw(privlibexp archlibexp)};
[ map io->dir($_), grep !/$Config{archname}$/, grep !$core{$_}, @INC ];
}
sub handle_source_for {
my ($self, $module) = @_;
my $io = first { $_->exists } map $_->catfile($module), @{$self->dir_list};
unless ($io) {
die [ 'failure' ];
}
my $code = $io->all;
return $code;
}
1;
TAK_MODULESENDER
$fatpacked{"Tak/MyScript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_MYSCRIPT';
package Tak::MyScript;
use Moo;
extends 'Tak::Script';
sub _my_script_package { 'Tak::MyScript' }
sub BUILD {
my ($self) = @_;
$self->_load_file('Takfile') if -e 'Takfile';
}
sub _load_file_in_my_script {
require $_[1];
}
1;
TAK_MYSCRIPT
$fatpacked{"Tak/ObjectClient.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_OBJECTCLIENT';
package Tak::ObjectClient;
use Tak::ObjectProxy;
use Moo;
with 'Tak::Role::ObjectMangling';
has remote => (is => 'ro', required => 1);
has object_service => (is => 'lazy');
sub _build_object_service {
my ($self) = @_;
my $remote = $self->remote;
$remote->ensure(object_service => 'Tak::ObjectService');
$remote->curry('object_service');
}
sub proxy_method_call {
my ($self, @call) = @_;
my $client = $self->object_service;
my $ready = $self->encode_objects(\@call);
my $context = wantarray;
my $res = $client->do(call_method => $context => $ready);
my $unpacked = $self->decode_objects($res);
if ($context) {
return @$unpacked;
} elsif (defined $context) {
return $unpacked->[0];
} else {
return;
}
}
sub proxy_death {
my ($self, $proxy) = @_;
$self->client->do(remove_object => $proxy->{tag});
}
sub inflate {
my ($self, $tag) = @_;
bless({ client => $self, tag => $tag }, 'Tak::ObjectProxy');
}
sub deflate {
my ($self, $obj) = @_;
unless (ref($obj) eq 'Tak::ObjectProxy') {
die "Can't deflate non-proxied object ${obj}";
}
return +{ __proxied_object__ => $obj->{tag} };
}
sub new_object {
my ($self, $class, @args) = @_;
$self->proxy_method_call($class, 'new', @args);
}
1;
TAK_OBJECTCLIENT
$fatpacked{"Tak/ObjectProxy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_OBJECTPROXY';
package Tak::ObjectProxy;
use strictures 1;
sub AUTOLOAD {
my $self = shift;
(my $method) = (our $AUTOLOAD =~ /([^:]+)$/);
$self->{client}->proxy_method_call($self, $method => @_);
}
sub DESTROY {
my $self = shift;
$self->{client}->proxy_death($self);
}
1;
TAK_OBJECTPROXY
$fatpacked{"Tak/ObjectService.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_OBJECTSERVICE';
package Tak::ObjectService;
use overload ();
use Moo;
with 'Tak::Role::Service';
with 'Tak::Role::ObjectMangling';
has proxied => (is => 'ro', init_arg => undef, default => sub { {} });
sub inflate {
my ($self, $tag) = @_;
$self->proxied->{$tag};
}
sub deflate {
my ($self, $obj) = @_;
my $tag = overload::StrVal($obj);
$self->proxied->{$tag} = $obj;
return +{ __proxied_object__ => $tag };
}
sub handle_call_method {
my ($self, $context, $call) = @_;
my ($invocant, $method, @args) = @{$self->decode_objects($call)};
my @res;
eval {
if (!ref($invocant)) {
(my $file = $invocant) =~ s/::/\//g;
require "${file}.pm";
}
if ($context) {
@res = $invocant->$method(@args);
} elsif (defined $context) {
$res[0] = $invocant->$method(@args);
} else {
$invocant->$method(@args);
}
1;
} or die [ failure => "$@" ];
return $self->encode_objects(\@res);
}
sub handle_remove_object {
my ($self, $tag) = @_;
my $had = !!delete $self->proxied->{$tag};
return $had;
}
1;
TAK_OBJECTSERVICE
$fatpacked{"Tak/REPL.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_REPL';
package Tak::REPL;
use Term::ReadLine;
use Moo;
has client => (is => 'ro', required => 1);
sub run {
my $client = $_[0]->client;
my $read = Term::ReadLine->new('REPL');
while (1) {
my $line = $read->readline('re.pl$ ');
last unless defined $line;
next unless length $line;
my $result = $client->do(eval => $line);
print exists($result->{return})
? $result->{return}
: "Error: ".$result->{exception};
if ($result->{stdout}) {
chomp($result->{stdout});
print "STDOUT:\n${\$result->{stdout}}\n";
}
if ($result->{stderr}) {
chomp($result->{stderr});
print "STDERR:\n${\$result->{stderr}}\n";
}
}
}
1;
TAK_REPL
$fatpacked{"Tak/Request.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_REQUEST';
package Tak::Request;
use Tak::Result;
use Moo;
has on_progress => (is => 'ro');
has on_result => (is => 'ro', required => 1);
has is_done => (is => 'rw', default => sub { 0 });
sub progress {
my ($self, @report) = @_;
if (my $cb = $self->on_progress) {
$cb->(@report);
}
}
sub result {
my ($self, $type, @data) = @_;
$self->is_done(1);
$self->on_result->(Tak::Result->new(type => $type, data => \@data));
}
sub flatten {
my ($self) = @_;
return ($self->type, @{$self->data});
}
sub success { shift->result(success => @_) }
sub mistake { shift->result(mistake => @_) }
sub failure { shift->result(failure => @_) }
sub fatal { shift->result(fatal => @_) }
1;
TAK_REQUEST
$fatpacked{"Tak/Result.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_RESULT';
package Tak::Result;
use Moo;
has type => (is => 'ro', required => 1);
has data => (is => 'ro', required => 1);
sub flatten { $_[0]->type, @{$_[0]->data} }
sub is_success { $_[0]->type eq 'success' }
sub get {
my ($self) = @_;
$self->throw unless $self->is_success;
return wantarray ? @{$self->data} : $self->data->[0];
}
sub throw {
my ($self) = @_;
die $self->exception;
}
sub exception {
my ($self) = @_;
$self->type.': '.join ' ', @{$self->data};
}
1;
TAK_RESULT
$fatpacked{"Tak/Role/ObjectMangling.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_ROLE_OBJECTMANGLING';
package Tak::Role::ObjectMangling;
use Scalar::Util qw(weaken);
use JSON::PP qw(encode_json decode_json);
use Moo::Role;
requires 'inflate';
requires 'deflate';
has encoder_json => (is => 'lazy');
has decoder_json => (is => 'lazy');
sub _build_encoder_json {
JSON::PP->new->allow_nonref(1)->convert_blessed(1);
}
sub _build_decoder_json {
my $self = shift;
weaken($self);
JSON::PP->new->allow_nonref(1)->filter_json_single_key_object(
__proxied_object__ => sub { $self->inflate($_[0]) }
);
}
sub encode_objects {
my ($self, $data) = @_;
local *UNIVERSAL::TO_JSON = sub { $self->deflate($_[0]) };
decode_json($self->encoder_json->encode($data));
}
sub decode_objects {
my ($self, $data) = @_;
$self->decoder_json->decode(encode_json($data));
}
TAK_ROLE_OBJECTMANGLING
$fatpacked{"Tak/Role/ScriptActions.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_ROLE_SCRIPTACTIONS';
package Tak::Role::ScriptActions;
use Moo::Role;
no warnings::illegalproto;
sub every_exec (stream|s) {
my ($self, $remotes, $options, @command) = @_;
my @requests;
$_->ensure(command_service => 'Tak::CommandService') for @$remotes;
foreach my $remote (@$remotes) {
if ($options->{stream}) {
my $stdout = $self->stdout;
my $host = $remote->host;
push @requests, $remote->start(
{
on_result => sub { $self->print_exec_result($remote, @_) },
on_progress => sub {
$stdout->print($host.' '.$_[0].': '.$_[1]);
$stdout->print("\n") unless $_[1] =~ /\n\Z/;
}
},
command_service => stream_exec => \@command
);
} else {
push @requests, $remote->start(
{ on_result => sub { $self->print_exec_result($remote, @_) } },
command_service => exec => \@command
);
}
}
Tak->await_all(@requests);
}
sub print_exec_result {
my ($self, $remote, $result) = @_;
my $res = eval { $result->get }
or do {
$self->stderr->print("Host ${\$remote->host}: Error: $@\n");
return;
};
my $code = $res->{exit_code};
$self->stdout->print(
"Host ${\$remote->host}: ".($code ? "NOT OK ${code}" : "OK")."\n"
);
if ($res->{stderr}) {
$self->stdout->print("Stderr:\n${\$res->{stderr}}\n");
}
if ($res->{stdout}) {
$self->stdout->print("Stdout:\n${\$res->{stdout}}\n");
}
}
sub each_repl (I=s@;m=s@;M=s@) {
my ($self, $remote, $options) = @_;
require Tak::REPL;
require B;
$remote->ensure(
eval_service => 'Tak::EvalService',
expose => { service_client => [] },
);
foreach my $lib (@{$options->{'I'}||[]}) {
$remote->do(eval_service => eval => "lib->import(${\B::perlstring($lib)})");
}
foreach my $module (@{$options->{'m'}||[]}) {
$remote->do(eval_service => eval => "use ${module} ()");
}
foreach my $spec (@{$options->{'M'}||[]}) {
my ($module, $import) = split('=', $spec);
my $extra = '';
if ($import) {
$extra = ' '.join(', ', map B::perlstring($_), split(',',$import));
}
$remote->do(eval_service => eval => "use ${module}${extra}");
}
Tak::REPL->new(client => $remote->curry('eval_service'))->run;
}
1;
TAK_ROLE_SCRIPTACTIONS
$fatpacked{"Tak/Role/Service.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_ROLE_SERVICE';
package Tak::Role::Service;
use Moo::Role;
sub start_request {
my ($self, $req, $type, @payload) = @_;
unless ($type) {
$req->mistake(request_type => "No request type given");
return;
}
if (my $meth = $self->can("handle_${type}")) {
my @result;
if (eval { @result = $self->$meth(@payload); 1 }) {
$req->success(@result);
} else {
if (ref($@) eq 'ARRAY') {
$req->result(@{$@});
} else {
$req->failure(exception => $@);
}
}
} elsif ($meth = $self->can("start_${type}_request")) {
$self->$meth($req => @payload);
} else {
$req->mistake(request_type => "Unknown request type ${type}");
}
}
sub receive {
my ($self, $type, @payload) = @_;
if (my $meth = $self->can("receive_${type}")) {
$self->$meth(@payload);
}
}
# This assumes that by default either services are not stateful
# or do want to have persistent state. It's notably overriden by Router.
sub clone_or_self { $_[0] }
1;
TAK_ROLE_SERVICE
$fatpacked{"Tak/Router.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_ROUTER';
package Tak::Router;
use Tak::MetaService;
use Scalar::Util qw(weaken);
use Log::Contextual qw(:log);
use Moo;
has services => (is => 'ro', default => sub { {} });
sub BUILD {
my ($self) = @_;
$self->register(meta => Tak::MetaService->new(router => $self));
}
sub start_request {
my ($self, $req, $target, @payload) = @_;
return $req->mistake("Reached router with no target")
unless $target;
return $req->failure("Reached router with invalid target ${target}")
unless my $next = $self->services->{$target};
$next->start_request($req, @payload);
}
sub receive {
my ($self, $target, @payload) = @_;
return unless $target;
log_debug { "Message received for ${target}" };
return log_info { "Discarded message to ${target}" }
unless my $next = $self->services->{$target};
$next->receive(@payload);
}
sub register {
my ($self, $name, $service) = @_;
$self->services->{$name} = $service;
}
sub register_weak {
my ($self, $name, $service) = @_;
weaken($self->services->{$name} = $service);
}
sub deregister {
my ($self, $name) = @_;
delete $self->services->{$name}
}
sub clone_or_self {
my ($self) = @_;
(ref $self)->new(services => { %{$self->services} });
}
1;
TAK_ROUTER
$fatpacked{"Tak/STDIONode.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_STDIONODE';
package Tak::STDIONode;
our $DATA = do { local $/; <DATA> };
1;
__DATA__
TAK_STDIONODE
$fatpacked{"Tak/STDIOSetup.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_STDIOSETUP';
package Tak::STDIOSetup;
use Log::Contextual qw(:log);
use Log::Contextual::SimpleLogger;
use Tak::ConnectionService;
use Tak::Router;
use Tak;
use IO::Handle;
use strictures 1;
sub run {
open my $stdin, '<&', \*STDIN or die "Duping stdin: $!";
open my $stdout, '>&', \*STDOUT or die "Duping stdout: $!";
$stdout->autoflush(1);
# if we don't re-open them then 0 and 1 get re-used - which is not
# only potentially bloody confusing but results in warnings like:
# "Filehandle STDOUT reopened as STDIN only for input"
close STDIN or die "Closing stdin: $!";
open STDIN, '<', '/dev/null' or die "Re-opening stdin: $!";
close STDOUT or die "Closing stdout: $!";
open STDOUT, '>', '/dev/null' or die "Re-opening stdout: $!";
my ($host, $level) = @ARGV;
my $sig = '<'.join ':', $host, $$.'> ';
Log::Contextual::set_logger(
Log::Contextual::SimpleLogger->new({
levels_upto => $level,
coderef => sub { print STDERR $sig, @_; }
})
);
my $done;
my $connection = Tak::ConnectionService->new(
read_fh => $stdin, write_fh => $stdout,
listening_service => Tak::Router->new,
on_close => sub { $done = 1 }
);
$connection->receiver->service->register_weak(remote => $connection);
$0 = 'tak-stdio-node';
log_debug { "Node starting" };
# Tell the other end that we've finished messing around with file
# descriptors and that it's therefore safe to start sending requests.
print $stdout "Shere\n";
Tak->loop_until($done);
if (our $Next) { goto &$Next }
}
1;
TAK_STDIOSETUP
$fatpacked{"Tak/Script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_SCRIPT';
package Tak::Script;
use Getopt::Long qw(GetOptionsFromArray :config posix_defaults bundling);
use Config::Settings;
use IO::Handle;
use Tak::Client::Router;
use Tak::Client::RemoteRouter;
use Tak::Router;
use Log::Contextual qw(:log);
use Log::Contextual::SimpleLogger;
use Moo;
with 'Tak::Role::ScriptActions';
has options => (is => 'ro', required => 1);
has env => (is => 'ro', required => 1);
has log_level => (is => 'rw');
has stdin => (is => 'lazy');
has stdout => (is => 'lazy');
has stderr => (is => 'lazy');
sub _build_stdin { shift->env->{stdin} }
sub _build_stdout { shift->env->{stdout} }
sub _build_stderr { shift->env->{stderr} }
has config => (is => 'lazy');
sub _build_config {
my ($self) = @_;
my $file = $self->options->{config} || '.tak/default.conf';
if (-e $file) {
Config::Settings->new->parse_file($file);
} else {
{};
}
}
has local_client => (is => 'lazy');
sub _build_local_client {
my ($self) = @_;
Tak::Client::Router->new(service => Tak::Router->new);
}
sub BUILD {
shift->setup_logger;
}
sub setup_logger {
my ($self) = @_;
my @level_names = qw(fatal error warn info debug trace);
my $options = $self->options;
my $level = 2 + ($options->{verbose}||0) - ($options->{quiet}||0);
my $upto = $level_names[$level];
$self->log_level($upto);
Log::Contextual::set_logger(
Log::Contextual::SimpleLogger->new({
levels_upto => $upto,
coderef => sub { print STDERR '<local> ', @_ },
})
);
}
sub _parse_options {
my ($self, $string, $argv) = @_;
my @spec = split ';', $string;
my %opt;
GetOptionsFromArray($argv, \%opt, @spec);
return \%opt;
}
sub run {
my ($self) = @_;
my @argv = @{$self->env->{argv}};
unless (@argv && $argv[0]) {
return $self->local_help;
}
my $cmd = shift(@argv);
$cmd =~ s/-/_/g;
if (my $code = $self->can("local_$cmd")) {
return $self->_run($cmd, $code, @argv);
} elsif ($code = $self->can("each_$cmd")) {
return $self->_run_each($cmd, $code, @argv);
} elsif ($code = $self->can("every_$cmd")) {
return $self->_run_every($cmd, $code, @argv);
}
$self->stderr->print("No such command: ${cmd}\n");
return $self->local_help;
}
sub _load_file {
my ($self, $file) = @_;
$self->_load_file_in_my_script($file);
}
sub local_help {
my ($self) = @_;
$self->stderr->print("Help unimplemented\n");
}
sub _maybe_parse_options {
my ($self, $code, $argv) = @_;
if (my $proto = prototype($code)) {
$self->_parse_options($proto, $argv);
} else {
{};
}
}
sub _run_local {
my ($self, $cmd, $code, @argv) = @_;
my $opt = $self->_maybe_parse_options($code, \@argv);
$self->$code($opt, @argv);
}
sub _run_each {
my ($self, $cmd, $code, @argv) = @_;
my @targets = $self->_host_list_for($cmd);
unless (@targets) {
$self->stderr->print("No targets for ${cmd}\n");
return;
}
my $opt = $self->_maybe_parse_options($code, \@argv);
$self->local_client->ensure(connector => 'Tak::ConnectorService');
foreach my $target (@targets) {
my $remote = $self->_connection_to($target);
$self->$code($remote, $opt, @argv);
}
}
sub _run_every {
my ($self, $cmd, $code, @argv) = @_;
my @targets = $self->_host_list_for($cmd);
unless (@targets) {
$self->stderr->print("No targets for ${cmd}\n");
return;
}
my $opt = $self->_maybe_parse_options($code, \@argv);
$self->local_client->ensure(connector => 'Tak::ConnectorService');
my @remotes = map $self->_connection_to($_), @targets;
$self->$code(\@remotes, $opt, @argv);
}
sub _host_list_for {
my ($self, $command) = @_;
my @host_spec = map split(' ', $_), @{$self->options->{host}};
unshift(@host_spec, '-') if $self->options->{local};
return @host_spec;
}
sub _connection_to {
my ($self, $target) = @_;
log_debug { "Connecting to ${target}" };
my @path = $self->local_client->do(
connector => create => $target, log_level => $self->log_level
);
my ($local, $remote) =
map $self->local_client->curry(connector => connection => @path => $_),
qw(local remote);
$local->ensure(module_sender => 'Tak::ModuleSender');
$remote->ensure(
module_loader => 'Tak::ModuleLoader',
expose => { module_sender => [ 'remote', 'module_sender' ] }
);
$remote->do(module_loader => 'enable');
log_debug { "Setup connection to ${target}" };
Tak::Client::RemoteRouter->new(
%$remote, host => $target
);
}
1;
TAK_SCRIPT
$fatpacked{"Tak/Takfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_TAKFILE';
package Tak::Takfile;
use strictures 1;
use warnings::illegalproto ();
sub import {
strictures->import;
warnings::illegalproto->unimport;
}
1;
TAK_TAKFILE
$fatpacked{"Tak/WeakClient.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TAK_WEAKCLIENT';
package Tak::WeakClient;
use Moo;
extends 'Tak::Client';
has service => (is => 'ro', required => 1, weak_ref => 1);
sub clone_or_self {
my ($self) = @_;
my $new = $self->service->clone_or_self;
($new ne $self->service
? 'Tak::Client'
: ref($self))->new(service => $new, curried => [ @{$self->curried} ]);
}
1;
TAK_WEAKCLIENT
$fatpacked{"aliased.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'ALIASED';
package aliased;
our $VERSION = '0.31';
$VERSION = eval $VERSION;
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(alias prefix);
use strict;
sub _croak {
require Carp;
Carp::croak(@_);
}
sub import {
my ( $class, $package, $alias, @import ) = @_;
if ( @_ <= 1 ) {
$class->export_to_level(1);
return;
}
my $callpack = caller(0);
_load_alias( $package, $callpack, @import );
_make_alias( $package, $callpack, $alias );
}
sub _get_alias {
my $package = shift;
$package =~ s/.*(?:::|')//;
return $package;
}
sub _make_alias {
my ( $package, $callpack, $alias ) = @_;
$alias ||= _get_alias($package);
my $destination = $alias =~ /::/
? $alias
: "$callpack\::$alias";
no strict 'refs';
*{ $destination } = sub () { $package };
}
sub _load_alias {
my ( $package, $callpack, @import ) = @_;
# We don't localize $SIG{__DIE__} here because we need to be careful about
# restoring its value if there is a failure. Very, very tricky.
my $sigdie = $SIG{__DIE__};
{
my $code =
@import == 0
? "package $callpack; use $package;"
: "package $callpack; use $package (\@import)";
eval $code;
if ( my $error = $@ ) {
$SIG{__DIE__} = $sigdie;
_croak($error);
}
$sigdie = $SIG{__DIE__}
if defined $SIG{__DIE__};
}
# Make sure a global $SIG{__DIE__} makes it out of the localization.
$SIG{__DIE__} = $sigdie if defined $sigdie;
return $package;
}
sub alias {
my ( $package, @import ) = @_;
my $callpack = scalar caller(0);
return _load_alias( $package, $callpack, @import );
}
sub prefix {
my ($class) = @_;
return sub {
my ($name) = @_;
my $callpack = caller(0);
if ( not @_ ) {
return _load_alias( $class, $callpack );
}
elsif ( @_ == 1 && defined $name ) {
return _load_alias( "${class}::$name", $callpack );
}
else {
_croak("Too many arguments to prefix('$class')");
}
};
}
1;
__END__
=head1 NAME
aliased - Use shorter versions of class names.
=head1 VERSION
0.31
=head1 SYNOPSIS
# Class name interface
use aliased 'My::Company::Namespace::Customer';
my $cust = Customer->new;
use aliased 'My::Company::Namespace::Preferred::Customer' => 'Preferred';
my $pref = Preferred->new;
# Variable interface
use aliased;
my $Customer = alias "My::Other::Namespace::Customer";
my $cust = $Customer->new;
my $Preferred = alias "My::Other::Namespace::Preferred::Customer";
my $pref = $Preferred->new;
=head1 DESCRIPTION
C<aliased> is simple in concept but is a rather handy module. It loads the
class you specify and exports into your namespace a subroutine that returns
the class name. You can explicitly alias the class to another name or, if you
prefer, you can do so implicitly. In the latter case, the name of the
subroutine is the last part of the class name. Thus, it does something
similar to the following:
#use aliased 'Some::Annoyingly::Long::Module::Name::Customer';
use Some::Annoyingly::Long::Module::Name::Customer;
sub Customer {
return 'Some::Annoyingly::Long::Module::Name::Customer';
}
my $cust = Customer->new;
This module is useful if you prefer a shorter name for a class. It's also
handy if a class has been renamed.
(Some may object to the term "aliasing" because we're not aliasing one
namespace to another, but it's a handy term. Just keep in mind that this is
done with a subroutine and not with typeglobs and weird namespace munging.)
Note that this is B<only> for C<use>ing OO modules. You cannot use this to
load procedural modules. See the L<Why OO Only?|Why OO Only?> section. Also,
don't let the version number fool you. This code is ridiculously simple and
is just fine for most use.
=head2 Implicit Aliasing
The most common use of this module is:
use aliased 'Some::Module::name';
C<aliased> will allow you to reference the class by the last part of the
class name. Thus, C<Really::Long::Name> becomes C<Name>. It does this by
exporting a subroutine into your namespace with the same name as the aliased
name. This subroutine returns the original class name.
For example:
use aliased "Acme::Company::Customer";
my $cust = Customer->find($id);
Note that any class method can be called on the shorter version of the class
name, not just the constructor.
=head2 Explicit Aliasing
Sometimes two class names can cause a conflict (they both end with C<Customer>
for example), or you already have a subroutine with the same name as the
aliased name. In that case, you can make an explicit alias by stating the
name you wish to alias to:
use aliased 'Original::Module::Name' => 'NewName';
Here's how we use C<aliased> to avoid conflicts:
use aliased "Really::Long::Name";
use aliased "Another::Really::Long::Name" => "Aname";
my $name = Name->new;
my $aname = Aname->new;
You can even alias to a different package:
use aliased "Another::Really::Long::Name" => "Another::Name";
my $aname = Another::Name->new;
Messing around with different namespaces is a really bad idea and you probably
don't want to do this. However, it might prove handy if the module you are
using has been renamed. If the interface has not changed, this allows you to
use the new module by only changing one line of code.
use aliased "New::Module::Name" => "Old::Module::Name";
my $thing = Old::Module::Name->new;
=head2 Import Lists
Sometimes, even with an OO module, you need to specify extra arguments when
using the module. When this happens, simply use L<Explicit Aliasing> followed
by the import list:
Snippet 1:
use Some::Module::Name qw/foo bar/;
my $o = Some::Module::Name->some_class_method;
Snippet 2 (equivalent to snippet 1):
use aliased 'Some::Module::Name' => 'Name', qw/foo bar/;
my $o = Name->some_class_method;
B<Note>: remember, you cannot use import lists with L<Implicit Aliasing>. As
a result, you may simply prefer to only use L<Explicit Aliasing> as a matter
of style.
=head2 alias()
This function is only exported if you specify C<use aliased> with no import
list.
use aliased;
my $alias = alias($class);
my $alias = alias($class, @imports);
alias() is an alternative to C<use aliased ...> which uses less magic and
avoids some of the ambiguities.
Like C<use aliased> it C<use>s the $class (pass in @imports, if given) but
instead of providing an C<Alias> constant it simply returns a scalar set to
the $class name.
my $thing = alias("Some::Thing::With::A::Long::Name");
# Just like Some::Thing::With::A::Long::Name->method
$thing->method;
The use of a scalar instead of a constant avoids any possible ambiguity
when aliasing two similar names:
# No ambiguity despite the fact that they both end with "Name"
my $thing = alias("Some::Thing::With::A::Long::Name");
my $other = alias("Some::Other::Thing::With::A::Long::Name");
and there is no magic constant exported into your namespace.
The only caveat is loading of the $class happens at run time. If $class
exports anything you might want to ensure it is loaded at compile time with:
my $thing;
BEGIN { $thing = alias("Some::Thing"); }
However, since OO classes rarely export this should not be necessary.
=head2 prefix() (experimental)
This function is only exported if you specify C<use aliased> with no import
list.
use aliased;
Sometimes you find you have a ton of packages in the same top-level namespace
and you want to alias them, but only use them on demand. For example:
# instead of:
MailVerwaltung::Client::Exception::REST::Response->throw()
my $error = prefix('MailVerwaltung::Client::Exception');
$error->('REST::Response')->throw(); # same as above
$error->()->throw; # same as MailVerwaltung::Client::Exception->throw
=head2 Why OO Only?
Some people have asked why this code only support object-oriented modules
(OO). If I were to support normal subroutines, I would have to allow the
following syntax:
use aliased 'Some::Really::Long::Module::Name';
my $data = Name::data();
That causes a serious problem. The only (reasonable) way it can be done is to
handle the aliasing via typeglobs. Thus, instead of a subroutine that
provides the class name, we alias one package to another (as the
L<namespace|namespace> module does.) However, we really don't want to simply
alias one package to another and wipe out namespaces willy-nilly. By merely
exporting a single subroutine to a namespace, we minimize the issue.
Fortunately, this doesn't seem to be that much of a problem. Non-OO modules
generally support exporting of the functions you need and this eliminates the
need for a module such as this.
=head1 EXPORT
This modules exports a subroutine with the same name as the "aliased" name.
=head1 BUGS
There are no known bugs in this module, but feel free to email me reports.
=head1 SEE ALSO
The L<namespace> module.
=head1 THANKS
Many thanks to Rentrak, Inc. (http://www.rentrak.com/) for graciously allowing
me to replicate the functionality of some of their internal code.
=head1 AUTHOR
Curtis Poe, C<< ovid [at] cpan [dot] org >>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2005 by Curtis "Ovid" Poe
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.5 or,
at your option, any later version of Perl 5 you may have available.
=cut
ALIASED
$fatpacked{"oo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'OO';
package oo;
use Moo::_strictures;
use Moo::_Utils;
sub moo {
print <<'EOMOO';
______
< Moo! >
------
\ ^__^
\ (oo)\_______
(__)\ )\/\
||----w |
|| ||
EOMOO
exit 0;
}
BEGIN {
my $package;
sub import {
moo() if $0 eq '-';
$package = $_[1] || 'Class';
if ($package =~ /^\+/) {
$package =~ s/^\+//;
_load_module($package);
}
}
use Filter::Simple sub { s/^/package $package;\nuse Moo;\n/; }
}
1;
__END__
=head1 NAME
oo - syntactic sugar for Moo oneliners
=head1 SYNOPSIS
perl -Moo=Foo -e 'has bar => ( is => q[ro], default => q[baz] ); print Foo->new->bar'
# loads an existing class and re-"opens" the package definition
perl -Moo=+My::Class -e 'print __PACKAGE__->new->bar'
=head1 DESCRIPTION
oo.pm is a simple source filter that adds C<package $name; use Moo;> to the
beginning of your script, intended for use on the command line via the -M
option.
=head1 SUPPORT
See L<Moo> for support and contact information.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut
OO
$fatpacked{"strictures.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRICTURES';
package strictures;
use strict;
use warnings FATAL => 'all';
BEGIN {
*_PERL_LT_5_8_4 = ($] < 5.008004) ? sub(){1} : sub(){0};
*_CAN_GOTO_VERSION = ($] >= 5.008000) ? sub(){1} : sub(){0};
}
our $VERSION = '2.000000';
$VERSION = eval $VERSION;
our @WARNING_CATEGORIES = grep { exists $warnings::Offsets{$_} } qw(
closure
chmod
deprecated
exiting
experimental
experimental::autoderef
experimental::const_attr
experimental::lexical_subs
experimental::lexical_topic
experimental::postderef
experimental::re_strict
experimental::refaliasing
experimental::regex_sets
experimental::signatures
experimental::smartmatch
experimental::win32_perlio
glob
imprecision
io
closed
exec
layer
newline
pipe
syscalls
unopened
locale
misc
missing
numeric
once
overflow
pack
portable
recursion
redefine
redundant
regexp
severe
debugging
inplace
internal
malloc
signal
substr
syntax
ambiguous
bareword
digit
illegalproto
parenthesis
precedence
printf
prototype
qw
reserved
semicolon
taint
threads
uninitialized
umask
unpack
untie
utf8
non_unicode
nonchar
surrogate
void
void_unusual
y2k
);
sub VERSION {
{
no warnings;
local $@;
if (defined $_[1] && eval { &UNIVERSAL::VERSION; 1}) {
$^H |= 0x20000
unless _PERL_LT_5_8_4;
$^H{strictures_enable} = int $_[1];
}
}
_CAN_GOTO_VERSION ? goto &UNIVERSAL::VERSION : &UNIVERSAL::VERSION;
}
our %extra_load_states;
our $Smells_Like_VCS;
sub import {
my $class = shift;
my %opts = ref $_[0] ? %{$_[0]} : @_;
if (!exists $opts{version}) {
$opts{version}
= exists $^H{strictures_enable} ? delete $^H{strictures_enable}
: int $VERSION;
}
$opts{file} = (caller)[1];
$class->_enable(\%opts);
}
sub _enable {
my ($class, $opts) = @_;
my $version = $opts->{version};
$version = 'undef'
if !defined $version;
my $method = "_enable_$version";
if (!$class->can($method)) {
require Carp;
Carp::croak("Major version specified as $version - not supported!");
}
$class->$method($opts);
}
sub _enable_1 {
my ($class, $opts) = @_;
strict->import;
warnings->import(FATAL => 'all');
if (_want_extra($opts->{file})) {
_load_extras(qw(indirect multidimensional bareword::filehandles));
indirect->unimport(':fatal')
if $extra_load_states{indirect};
multidimensional->unimport
if $extra_load_states{multidimensional};
bareword::filehandles->unimport
if $extra_load_states{'bareword::filehandles'};
}
}
our @V2_NONFATAL = grep { exists $warnings::Offsets{$_} } (
'exec', # not safe to catch
'recursion', # will be caught by other mechanisms
'internal', # not safe to catch
'malloc', # not safe to catch
'newline', # stat on nonexistent file with a newline in it
'experimental', # no reason for these to be fatal
'deprecated', # unfortunately can't make these fatal
'portable', # everything worked fine here, just may not elsewhere
);
our @V2_DISABLE = grep { exists $warnings::Offsets{$_} } (
'once' # triggers inconsistently, can't be fatalized
);
sub _enable_2 {
my ($class, $opts) = @_;
strict->import;
warnings->import;
warnings->import(FATAL => @WARNING_CATEGORIES);
warnings->unimport(FATAL => @V2_NONFATAL);
warnings->import(@V2_NONFATAL);
warnings->unimport(@V2_DISABLE);
if (_want_extra($opts->{file})) {
_load_extras(qw(indirect multidimensional bareword::filehandles));
indirect->unimport(':fatal')
if $extra_load_states{indirect};
multidimensional->unimport
if $extra_load_states{multidimensional};
bareword::filehandles->unimport
if $extra_load_states{'bareword::filehandles'};
}
}
sub _want_extra_env {
if (exists $ENV{PERL_STRICTURES_EXTRA}) {
if (_PERL_LT_5_8_4 and $ENV{PERL_STRICTURES_EXTRA}) {
die 'PERL_STRICTURES_EXTRA checks are not available on perls older'
. "than 5.8.4: please unset \$ENV{PERL_STRICTURES_EXTRA}\n";
}
return $ENV{PERL_STRICTURES_EXTRA} ? 1 : 0;
}
return undef;
}
sub _want_extra {
my $file = shift;
my $want_env = _want_extra_env();
return $want_env
if defined $want_env;
return (
!_PERL_LT_5_8_4
and $file =~ /^(?:t|xt|lib|blib)[\\\/]/
and defined $Smells_Like_VCS ? $Smells_Like_VCS
: ( $Smells_Like_VCS = !!(
-e '.git' || -e '.svn' || -e '.hg'
|| (-e '../../dist.ini'
&& (-e '../../.git' || -e '../../.svn' || -e '../../.hg' ))
))
);
}
sub _load_extras {
my @extras = @_;
my @failed;
foreach my $mod (@extras) {
next
if exists $extra_load_states{$mod};
$extra_load_states{$mod} = eval "require $mod; 1;" or do {
push @failed, $mod;
#work around 5.8 require bug
(my $file = $mod) =~ s|::|/|g;
delete $INC{"${file}.pm"};
};
}
if (@failed) {
my $failed = join ' ', @failed;
my $extras = join ' ', @extras;
print STDERR <<EOE;
strictures.pm extra testing active but couldn't load all modules. Missing were:
$failed
Extra testing is auto-enabled in checkouts only, so if you're the author
of a strictures-using module you need to run:
cpan $extras
but these modules are not required by your users.
EOE
}
}
1;
__END__
=head1 NAME
strictures - turn on strict and make all warnings fatal
=head1 SYNOPSIS
use strictures 2;
is equivalent to
use strict;
use warnings FATAL => 'all';
use warnings NONFATAL => qw(
exec
recursion
internal
malloc
newline
experimental
deprecated
portable
);
no warnings 'once';
except when called from a file which matches:
(caller)[1] =~ /^(?:t|xt|lib|blib)[\\\/]/
and when either C<.git>, C<.svn>, or C<.hg> is present in the current directory
(with the intention of only forcing extra tests on the author side) -- or when
C<.git>, C<.svn>, or C<.hg> is present two directories up along with
C<dist.ini> (which would indicate we are in a C<dzil test> operation, via
L<Dist::Zilla>) -- or when the C<PERL_STRICTURES_EXTRA> environment variable is
set, in which case it also does the equivalent of
no indirect 'fatal';
no multidimensional;
no bareword::filehandles;
Note that C<PERL_STRICTURES_EXTRA> may at some point add even more tests, with
only a minor version increase, but any changes to the effect of C<use
strictures> in normal mode will involve a major version bump.
If any of the extra testing modules are not present, L<strictures> will
complain loudly, once, via C<warn()>, and then shut up. But you really
should consider installing them, they're all great anti-footgun tools.
=head1 DESCRIPTION
I've been writing the equivalent of this module at the top of my code for
about a year now. I figured it was time to make it shorter.
Things like the importer in C<use Moose> don't help me because they turn
warnings on but don't make them fatal -- which from my point of view is
useless because I want an exception to tell me my code isn't warnings-clean.
Any time I see a warning from my code, that indicates a mistake.
Any time my code encounters a mistake, I want a crash -- not spew to STDERR
and then unknown (and probably undesired) subsequent behaviour.
I also want to ensure that obvious coding mistakes, like indirect object
syntax (and not so obvious mistakes that cause things to accidentally compile
as such) get caught, but not at the cost of an XS dependency and not at the
cost of blowing things up on another machine.
Therefore, L<strictures> turns on additional checking, but only when it thinks
it's running in a test file in a VCS checkout -- although if this causes
undesired behaviour this can be overridden by setting the
C<PERL_STRICTURES_EXTRA> environment variable.
If additional useful author side checks come to mind, I'll add them to the
C<PERL_STRICTURES_EXTRA> code path only -- this will result in a minor version
increase (e.g. 1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the
mechanism of this code will result in a sub-version increase (e.g. 1.000000 to
1.000001 (1.0.1)).
=head1 CATEGORY SELECTIONS
strictures does not enable fatal warnings for all categories.
=over 4
=item exec
Includes a warning that can cause your program to continue running
unintentionally after an internal fork. Not safe to fatalize.
=item recursion
Infinite recursion will end up overflowing the stack eventually anyway.
=item internal
Triggers deep within perl, in places that are not safe to trap.
=item malloc
Triggers deep within perl, in places that are not safe to trap.
=item newline
Includes a warning for using stat on a valid but suspect filename, ending in a
newline.
=item experimental
Experimental features are used intentionally.
=item deprecated
Deprecations will inherently be added to in the future in unexpected ways,
so making them fatal won't be reliable.
=item portable
Doesn't indicate an actual problem with the program, only that it may not
behave properly if run on a different machine.
=item once
Can't be fatalized. Also triggers very inconsistently, so we just disable it.
=back
=head1 VERSIONS
Depending on the version of strictures requested, different warnings will be
enabled. If no specific version is requested, the current version's behavior
will be used. Versions can be requested using perl's standard mechanism:
use strictures 2;
Or, by passing in a C<version> option:
use strictures version => 2;
=head2 VERSION 2
Equivalent to:
use strict;
use warnings FATAL => 'all';
use warnings NONFATAL => qw(
exec
recursion
internal
malloc
newline
experimental
deprecated
portable
);
no warnings 'once';
# and if in dev mode:
no indirect 'fatal';
no multidimensional;
no bareword::filehandles;
Additionally, any warnings created by modules using L<warnings::register> or
C<warnings::register_categories()> will not be fatalized.
=head2 VERSION 1
Equivalent to:
use strict;
use warnings FATAL => 'all';
# and if in dev mode:
no indirect 'fatal';
no multidimensional;
no bareword::filehandles;
=head1 METHODS
=head2 import
This method does the setup work described above in L</DESCRIPTION>. Optionally
accepts a C<version> option to request a specific version's behavior.
=head2 VERSION
This method traps the C<< strictures->VERSION(1) >> call produced by a use line
with a version number on it and does the version check.
=head1 EXTRA TESTING RATIONALE
Every so often, somebody complains that they're deploying via C<git pull>
and that they don't want L<strictures> to enable itself in this case -- and that
setting C<PERL_STRICTURES_EXTRA> to 0 isn't acceptable (additional ways to
disable extra testing would be welcome but the discussion never seems to get
that far).
In order to allow us to skip a couple of stages and get straight to a
productive conversation, here's my current rationale for turning the
extra testing on via a heuristic:
The extra testing is all stuff that only ever blows up at compile time;
this is intentional. So the oft-raised concern that it's different code being
tested is only sort of the case -- none of the modules involved affect the
final optree to my knowledge, so the author gets some additional compile
time crashes which he/she then fixes, and the rest of the testing is
completely valid for all environments.
The point of the extra testing -- especially C<no indirect> -- is to catch
mistakes that newbie users won't even realise are mistakes without
help. For example,
foo { ... };
where foo is an & prototyped sub that you forgot to import -- this is
pernicious to track down since all I<seems> fine until it gets called
and you get a crash. Worse still, you can fail to have imported it due
to a circular require, at which point you have a load order dependent
bug which I've seen before now I<only> show up in production due to tiny
differences between the production and the development environment. I wrote
L<http://shadow.cat/blog/matt-s-trout/indirect-but-still-fatal/> to explain
this particular problem before L<strictures> itself existed.
As such, in my experience so far L<strictures>' extra testing has
I<avoided> production versus development differences, not caused them.
Additionally, L<strictures>' policy is very much "try and provide as much
protection as possible for newbies -- who won't think about whether there's
an option to turn on or not" -- so having only the environment variable
is not sufficient to achieve that (I get to explain that you need to add
C<use strict> at least once a week on freenode #perl -- newbies sometimes
completely skip steps because they don't understand that that step
is important).
I make no claims that the heuristic is perfect -- it's already been evolved
significantly over time, especially for 1.004 where we changed things to
ensure it only fires on files in your checkout (rather than L<strictures>-using
modules you happened to have installed, which was just silly). However, I
hope the above clarifies why a heuristic approach is not only necessary but
desirable from a point of view of providing new users with as much safety as
possible, and will allow any future discussion on the subject to focus on "how
do we minimise annoyance to people deploying from checkouts intentionally".
=head1 SEE ALSO
=over 4
=item *
L<indirect>
=item *
L<multidimensional>
=item *
L<bareword::filehandles>
=back
=head1 COMMUNITY AND SUPPORT
=head2 IRC channel
irc.perl.org #toolchain
(or bug 'mst' in query on there or freenode)
=head2 Git repository
Gitweb is on http://git.shadowcat.co.uk/ and the clone URL is:
git clone git://git.shadowcat.co.uk/p5sagit/strictures.git
The web interface to the repository is at:
http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit/strictures.git
=head1 AUTHOR
mst - Matt S. Trout (cpan:MSTROUT) <mst@shadowcat.co.uk>
=head1 CONTRIBUTORS
Karen Etheridge (cpan:ETHER) <ether@cpan.org>
Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@gmail.com>
haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
=head1 COPYRIGHT
Copyright (c) 2010 the strictures L</AUTHOR> and L</CONTRIBUTORS>
as listed above.
=head1 LICENSE
This library is free software and may be distributed under the same terms
as perl itself.
=cut
STRICTURES
$fatpacked{"strictures/extra.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRICTURES_EXTRA';
package strictures::extra;
use strict;
use warnings FATAL => 'all';
sub import {
$ENV{PERL_STRICTURES_EXTRA} = 1;
}
sub unimport {
$ENV{PERL_STRICTURES_EXTRA} = 0;
}
1;
__END__
=head1 NAME
strictures::extra - enable or disable strictures additional checks
=head1 SYNOPSIS
no strictures::extra;
# will not enable indirect, multidimensional, or bareword filehandle checks
use strictures;
=head1 DESCRIPTION
Enable or disable strictures additional checks, preventing checks for C<.git>
or other VCS directories.
Equivalent to setting the C<PERL_STRICTURES_EXTRA> environment variable.
=head1 AUTHORS
See L<strictures> for authors.
=head1 COPYRIGHT AND LICENSE
See L<strictures> for the copyright and license.
=cut
STRICTURES_EXTRA
s/^ //mg for values %fatpacked;
my $class = 'FatPacked::'.(0+\%fatpacked);
no strict 'refs';
*{"${class}::files"} = sub { keys %{$_[0]} };
if ($] < 5.008) {
*{"${class}::INC"} = sub {
if (my $fat = $_[0]{$_[1]}) {
return sub {
return 0 unless length $fat;
$fat =~ s/^([^\n]*\n?)//;
$_ = $1;
return 1;
};
}
return;
};
}
else {
*{"${class}::INC"} = sub {
if (my $fat = $_[0]{$_[1]}) {
open my $fh, '<', \$fat
or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
return $fh;
}
return;
};
}
unshift @INC, bless \%fatpacked, $class;
} # END OF FATPACK CODE
#!/usr/bin/env perl
use Tak::STDIOSetup;
Tak::STDIOSetup->run;