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"} = <<'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"} = <<'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"} = <<'CAPTURE_TINY';
#
# This file is part of Capture-Tiny
#
# This software is Copyright (c) 2009 by David Golden.
#
# This is free software, licensed under:
#
# The Apache License, Version 2.0, January 2004
#
use 5.006;
use strict;
use warnings;
package Capture::Tiny;
BEGIN {
$Capture::Tiny::VERSION = '0.11';
}
# ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
use Carp ();
use Exporter ();
use IO::Handle ();
use File::Spec ();
use File::Temp qw/tempfile tmpnam/;
# Get PerlIO or fake it
BEGIN {
local $@;
eval { require PerlIO; PerlIO->can('get_layers') }
or *PerlIO::get_layers = sub { return () };
}
our @ISA = qw/Exporter/;
our @EXPORT_OK = qw/capture capture_merged tee tee_merged/;
our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
my $IS_WIN32 = $^O eq 'MSWin32';
our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
my $DEBUGFH;
open $DEBUGFH, ">&STDERR" 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, '-e', '$SIG{HUP}=sub{exit}; '
. 'if( my $fn=shift ){ open my $fh, qq{>$fn}; print {$fh} $$; close $fh;} '
. 'my $buf; while (sysread(STDIN, $buf, 2048)) { '
. 'syswrite(STDOUT, $buf); syswrite(STDERR, $buf)}'
);
#--------------------------------------------------------------------------#
# filehandle manipulation
#--------------------------------------------------------------------------#
sub _relayer {
my ($fh, $layers) = @_;
_debug("# requested layers (@{$layers}) to $fh\n");
my %seen = ( unix => 1, perlio => 1 ); # filter these out
my @unique = grep { !$seen{$_}++ } @$layers;
_debug("# applying unique layers (@unique) to $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 {
close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
_debug( "# closed " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . "\n" );
}
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;
}
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;
}
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;
}
return %proxies;
}
sub _unproxy {
my (%proxies) = @_;
_debug( "# unproxing " . 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 = map { $_, IO::Handle->new } qw/stdin stdout stderr/;
_debug( "# copying std handles ...\n" );
_open $handles{stdin}, "<&STDIN";
_open $handles{stdout}, ">&STDOUT";
_open $handles{stderr}, ">&STDERR";
return \%handles;
}
sub _open_std {
my ($handles) = @_;
_open \*STDIN, "<&" . fileno $handles->{stdin};
_open \*STDOUT, ">&" . fileno $handles->{stdout};
_open \*STDERR, ">&" . fileno $handles->{stderr};
}
#--------------------------------------------------------------------------#
# private subs
#--------------------------------------------------------------------------#
sub _start_tee {
my ($which, $stash) = @_;
# 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();
if ( SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0) ) {
_debug( "# set no-inherit flag on $which tee\n" );
}
else {
_debug( "# 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) = @_;
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
}
sub _files_exist { -f $_ || return 0 for @_; return 1 }
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 {
seek $_[0],0,0; local $/; return scalar readline $_[0];
}
#--------------------------------------------------------------------------#
# _capture_tee() -- generic main sub for capturing or teeing
#--------------------------------------------------------------------------#
sub _capture_tee {
_debug( "# starting _capture_tee with (@_)...\n" );
my ($tee_stdout, $tee_stderr, $merge, $code) = @_;
# 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)],
stderr => [PerlIO::get_layers(\*STDERR)],
);
_debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# bypass scalar filehandles and tied handles
my %localize;
$localize{stdin}++, local(*STDIN) if grep { $_ eq 'scalar' } @{$layers{stdin}};
$localize{stdout}++, local(*STDOUT) if grep { $_ eq 'scalar' } @{$layers{stdout}};
$localize{stderr}++, local(*STDERR) if grep { $_ eq 'scalar' } @{$layers{stderr}};
$localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1") if tied *STDOUT && $] >= 5.008;
$localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2") if tied *STDERR && $] >= 5.008;
_debug( "# localized $_\n" ) for keys %localize;
my %proxy_std = _proxy_std();
_debug( "# proxy std is @{ [%proxy_std] }\n" );
my $stash = { old => _copy_std() };
# update layers after any proxying
%layers = (
stdin => [PerlIO::get_layers(\*STDIN) ],
stdout => [PerlIO::get_layers(\*STDOUT)],
stderr => [PerlIO::get_layers(\*STDERR)],
);
_debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
# get handles for capture and apply existing IO layers
$stash->{new}{$_} = $stash->{capture}{$_} = File::Temp->new for qw/stdout stderr/;
_debug("# will capture $_ on " .fileno($stash->{capture}{$_})."\n" ) for qw/stdout stderr/;
# tees may change $stash->{new}
_start_tee( stdout => $stash ) if $tee_stdout;
_start_tee( stderr => $stash ) if $tee_stderr;
_wait_for_tees( $stash ) if $tee_stdout || $tee_stderr;
# finalize redirection
$stash->{new}{stderr} = $stash->{new}{stdout} if $merge;
$stash->{new}{stdin} = $stash->{old}{stdin};
_debug( "# redirecting in parent ...\n" );
_open_std( $stash->{new} );
# execute user provided code
my ($exit_code, $inner_error, $outer_error);
{
local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
local *STDERR = *STDOUT if $merge; # minimize buffer mixups during $code
_debug( "# finalizing layers ...\n" );
_relayer(\*STDOUT, $layers{stdout});
_relayer(\*STDERR, $layers{stderr}) unless $merge;
_debug( "# running code $code ...\n" );
local $@;
eval { $code->(); $inner_error = $@ };
$exit_code = $?; # save this for later
$outer_error = $@; # save this for later
}
# restore prior filehandles and shut down tees
_debug( "# restoring ...\n" );
_open_std( $stash->{old} );
_close( $_ ) for values %{$stash->{old}}; # don't leak fds
_unproxy( %proxy_std );
_kill_tees( $stash ) if $tee_stdout || $tee_stderr;
# return captured output
_relayer($stash->{capture}{stdout}, $layers{stdout});
_relayer($stash->{capture}{stderr}, $layers{stderr}) unless $merge;
_debug( "# slurping captured $_ with layers: @{[PerlIO::get_layers($stash->{capture}{$_})]}\n") for qw/stdout stderr/;
my $got_out = _slurp($stash->{capture}{stdout});
my $got_err = $merge ? q() : _slurp($stash->{capture}{stderr});
print CT_ORIG_STDOUT $got_out if $localize{stdout} && $tee_stdout;
print CT_ORIG_STDERR $got_err if !$merge && $localize{stderr} && $tee_stdout;
$? = $exit_code;
$@ = $inner_error if $inner_error;
die $outer_error if $outer_error;
_debug( "# ending _capture_tee with (@_)...\n" );
return $got_out if $merge;
return wantarray ? ($got_out, $got_err) : $got_out;
}
#--------------------------------------------------------------------------#
# create API subroutines from [tee STDOUT flag, tee STDERR, merge flag]
#--------------------------------------------------------------------------#
my %api = (
capture => [0,0,0],
capture_merged => [0,0,1],
tee => [1,1,0],
tee_merged => [1,0,1], # don't tee STDOUT since merging
);
for my $sub ( keys %api ) {
my $args = join q{, }, @{$api{$sub}};
eval "sub $sub(&) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
}
1;
=pod
=head1 NAME
Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
=head1 VERSION
version 0.11
=head1 SYNOPSIS
use Capture::Tiny qw/capture tee capture_merged tee_merged/;
($stdout, $stderr) = capture {
# your code here
};
($stdout, $stderr) = tee {
# your code here
};
$merged = capture_merged {
# your code here
};
$merged = tee_merged {
# your code here
};
=head1 DESCRIPTION
Capture::Tiny provides a simple, portable way to capture 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 handles. Yes, it even
works on Windows. Stop guessing which of a dozen capturing modules to use in
any particular situation and just use this one.
This module was heavily inspired by L<IO::CaptureOutput>, which provides
similar functionality without the ability to tee output and with more
complicated code and API.
=head1 USAGE
The following functions are available. None are exported by default.
=head2 capture
($stdout, $stderr) = capture \&code;
$stdout = capture \&code;
The C<<< capture >>> function takes a code reference and returns what is sent to
STDOUT and STDERR. In scalar context, it returns only STDOUT. If no output
was received, returns an empty string. Regardless of context, all output is
captured -- nothing is passed to the existing handles.
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 ...
};
=head2 capture_merged
$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 STDOUT before
executing the function.) If no output was received, returns an empty string.
As with C<<< capture >>> it may be called in block form.
Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
properly ordered due to buffering.
=head2 tee
($stdout, $stderr) = 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. As with C<<< capture >>> it
may be called in block form.
=head2 tee_merged
$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. As with C<<< capture >>> it may be called
in block form.
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.
=head2 PerlIO layers
Capture::Tiny does it's best to preserve PerlIO layers such as ':utf8' or
':crlf' when capturing. Layers should be applied to STDOUT or STDERR I<before>
the call to C<<< capture >>> or C<<< tee >>>.
=head2 Closed STDIN, STDOUT or STDERR
Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
closed. However, since they may 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 reclose
them again when the capture block finishes.
=head2 Scalar filehandles and STDIN, STDOUT or STDERR
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 handle for the
duration of the C<<< capture >>> or C<<< tee >>> call and then send captured output to the
output handle after the capture is complete. (Requires Perl 5.8)
Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
reference.
=head2 Tied STDIN, STDOUT or STDERR
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 handle after
the capture is complete. (Requires Perl 5.8)
Capture::Tiny does not (yet) support resending utf8 encoded data to a tied
STDOUT or STDERR handle. Characters will appear as bytes.
Capture::Tiny attempts to preserve the semantics of tied STDIN, but capturing
or teeing when STDIN is tied is currently broken on Windows.
=head2 Modifiying STDIN, STDOUT or STDERR 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 UTF8.
=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 BUGS
Please report any bugs or feature requests using the CPAN Request Tracker.
Bugs can be submitted through the web interface at
L<http://rt.cpan.org/Dist/Display.html?Queue=Capture-Tiny>
When submitting a bug or request, please include a test-file or a patch to an
existing test-file that illustrates the bug or desired feature.
=head1 SEE ALSO
This is a selection of 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
=head1 SUPPORT
=head2 Bugs / Feature Requests
Please report any bugs or feature requests by email to C<bug-capture-tiny at rt.cpan.org>, or through
the web interface at L<http://rt.cpan.org/Public/Dist/Display.html?Name=Capture-Tiny>. You will be automatically notified of any
progress on the request by the system.
=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<http://github.com/dagolden/capture-tiny/tree>
git clone git://github.com/dagolden/capture-tiny.git
=head1 AUTHOR
David Golden <dagolden@cpan.org>
=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
__END__
CAPTURE_TINY
$fatpacked{"Class/C3.pm"} = <<'CLASS_C3';
package Class::C3;
use strict;
use warnings;
our $VERSION = '0.23';
our $C3_IN_CORE;
our $C3_XS;
BEGIN {
if($] > 5.009_004) {
$C3_IN_CORE = 1;
require mro;
}
else {
eval "require Class::C3::XS";
my $error = $@;
if(!$error) {
$C3_XS = 1;
}
else {
die $error if $error !~ /\blocate\b/;
require Algorithm::C3;
require Class::C3::next;
}
}
}
# this is our global stash of both
# MRO's and method dispatch tables
# the structure basically looks like
# this:
#
# $MRO{$class} = {
# MRO => [ <class precendence 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 interogate 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 overriden 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 algortihm
=head1 SYNOPSIS
# NOTE - DO NOT USE Class::C3 directly as a user, use MRO::Compat instead!
package A;
use Class::C3;
sub hello { 'A::hello' }
package B;
use base 'A';
use Class::C3;
package C;
use base 'A';
use Class::C3;
sub hello { 'C::hello' }
package D;
use base ('B', 'C');
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('Diamond_D') # prints D, B, C, A
print D->hello() # prints 'C::hello' instead of the standard p5 'A::hello'
D->can('hello')->(); # can() also works correctly
UNIVERSAL::can('D', '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 langauge Dylan (see links in the L<SEE ALSO> section),
and then later adopted as the prefered 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 precendence 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 trival, for more complex examples and a deeper explaination, 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;
The the more clunky:
package MyClass;
use Class::C3;
But hey, it's your choice, thats 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 initalize 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
convience. I apologize to anyone this causes problems for (although i would very suprised 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 ambigious, and generally not recomended anyway.
However, its use in conjuntion 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 recalulate 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 interogating 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. Installing this is recommended when possible, 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"} = <<'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.23';
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.02';
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
neccesary, 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"} = <<'DATA_DUMPER_CONCISE';
package Data::Dumper::Concise;
use 5.006;
$VERSION = '2.020';
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"} = <<'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 { return DwarnL(@_) if wantarray; DwarnS($_[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(@_) if wantarray; DdieS($_[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"} = <<'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"} = <<'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.105';
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';
require Exporter::Declare::Magic;
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 _find_export_class {
my $args = shift;
return shift( @$args )
if @$args
&& eval { $args->[0]->can('export_meta') };
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
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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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/Magic.pm"} = <<'EXPORTER_DECLARE_MAGIC';
package Exporter::Declare::Magic;
use strict;
use warnings;
use Devel::Declare::Parser;
use aliased 'Exporter::Declare::Magic::Sub';
use aliased 'Exporter::Declare::Export::Generator';
use Carp qw/croak/;
our @CARP_NOT = qw/
Exporter::Declare
Exporter::Declare::Specs
Exporter::Declare::Meta
Exporter::Declare::Magic
/;
BEGIN {
die "Devel::Declare::Parser version >= 0.017 is required for -magic\n"
unless $Devel::Declare::Parser::VERSION gt '0.016';
}
use Devel::Declare::Parser::Sublike;
use Exporter::Declare
'default_exports',
export => { -as => 'ed_export' },
gen_export => { -as => 'ed_gen_export' },
default_export => { -as => 'ed_default_export' },
gen_default_export => { -as => 'ed_gen_default_export' };
default_exports qw/
parsed_exports
parsed_default_exports
/;
parsed_default_exports( sublike => qw/parser/ );
parsed_default_exports( export => qw/
export
gen_export
default_export
gen_default_export
/);
Exporter::Declare::Meta->add_hash_metric( 'parsers' );
sub export {
my $class = Exporter::Declare::_find_export_class( \@_ );
_export( $class, undef, @_ );
}
sub gen_export {
my $class = Exporter::Declare::_find_export_class( \@_ );
_export( $class, Generator(), @_ );
}
sub default_export {
my $class = Exporter::Declare::_find_export_class( \@_ );
my $meta = $class->export_meta;
$meta->export_tags_push( 'default', _export( $class, undef, @_ ));
}
sub gen_default_export {
my $class = Exporter::Declare::_find_export_class( \@_ );
my $meta = $class->export_meta;
$meta->export_tags_push( 'default', _export( $class, Generator(), @_ ));
}
sub _export {
my %params = Exporter::Declare::_parse_export_params( @_ );
my ($parser) = @{ $params{args} };
if ( $parser ) {
my $ec = $params{export_class};
if ( $ec && $ec eq Generator ) {
$params{extra_exporter_props} = { parser => $parser, type => Sub };
}
else {
$params{export_class} = Sub;
$params{extra_exporter_props} = { parser => $parser };
}
}
Exporter::Declare::_add_export( %params );
}
sub parser {
my $class = Exporter::Declare::_find_export_class( \@_ );
my $name = shift;
my $code = pop;
croak "You must provide a name to parser()"
if !$name || ref $name;
croak "Too many parameters passed to parser()"
if @_ && defined $_[0];
$code ||= $class->can( $name );
croak "Could not find code for parser '$name'"
unless $code;
$class->export_meta->parsers_add( $name, $code );
}
sub parsed_exports {
my $class = Exporter::Declare::_find_export_class( \@_ );
my ( $parser, @items ) = @_;
croak "no parser specified" unless $parser;
_export( $class, Sub(), $_, $parser ) for @items;
}
sub parsed_default_exports {
my $class = Exporter::Declare::_find_export_class( \@_ );
my ( $parser, @names ) = @_;
croak "no parser specified" unless $parser;
for my $name ( @names ) {
_export( $class, Sub(), $name, $parser );
$class->export_meta->export_tags_push( 'default', $name );
}
}
1;
__END__
=head1 NAME
Exporter::Declare::Magic - Enhance Exporter::Declare with some fancy magic.
=head1 DESCRIPTION
=head1 SYNOPSIS
package Some::Exporter;
use Exporter::Declare '-magic';
... #Same as the basic exporter synopsis
#Quoting is not necessary unless you have space or special characters
export another_sub;
export parsed_sub parser;
# no 'sub' keyword, not a typo
export anonymous_export {
...
}
#No semicolon, not a typo
export parsed_anon parser {
...
}
# Same as export
default_export name { ... }
# No quoting required
export $VAR;
export %VAR;
my $iterator = 'a';
gen_export unique_class_id {
my $current = $iterator++;
return sub { $current };
}
gen_default_export '$my_letter' {
my $letter = $iterator++;
return \$letter;
}
parser myparser {
... See Devel::Declare
}
parsed_exports parser => qw/ parsed_sub_a parsed_sub_b /;
parsed_default_exports parser_b => qw/ parsed_sub_c /;
=head1 API
These all work fine in function or method form, however the syntax sugar will
only work in function form.
=over 4
=item parsed_exports( $parser, @exports )
Add exports that should use a 'Devel::Declare' based parser. The parser should
be the name of a registered L<Devel::Declare::Interface> parser, or the name of
a parser sub created using the parser() function.
=item parsed_default_exports( $parser, @exports )
Same as parsed_exports(), except exports are added to the -default tag.
=item parser name { ... }
=item parser name => \&code
Define a parser. You need to be familiar with Devel::Declare to make use of
this.
=item export( $name )
=item export( $name, $ref )
=item export( $name, $parser )
=item export( $name, $parser, $ref )
=item export name { ... }
=item export name parser { ... }
export is a keyword that lets you export any 1 item at a time. The item can be
exported by name, name+ref, or name+parser+ref. You can also use it without
parentheses or quotes followed by a codeblock.
=item default_export( $name )
=item default_export( $name, $ref )
=item default_export( $name, $parser )
=item default_export( $name, $parser, $ref )
=item default_export name { ... }
=item default_export name parser { ... }
=item gen_export( $name )
=item gen_export( $name, $ref )
=item gen_export( $name, $parser )
=item gen_export( $name, $parser, $ref )
=item gen_export name { ... }
=item gen_export name parser { ... }
=item gen_default_export( $name )
=item gen_default_export( $name, $ref )
=item gen_default_export( $name, $parser )
=item gen_default_export( $name, $parser, $ref )
=item gen_default_export name { ... }
=item gen_default_export name parser { ... }
These all act just like export(), except that they add subrefs as generators,
and/or add exports to the -default tag.
=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_MAGIC
$fatpacked{"Exporter/Declare/Magic/Parser.pm"} = <<'EXPORTER_DECLARE_MAGIC_PARSER';
package Exporter::Declare::Magic::Parser;
use strict;
use warnings;
use base 'Devel::Declare::Parser';
use Devel::Declare::Interface;
BEGIN { Devel::Declare::Interface::register_parser( 'export' )};
__PACKAGE__->add_accessor( '_inject' );
__PACKAGE__->add_accessor( 'parser' );
sub inject {
my $self = shift;
my @out;
if( my $items = $self->_inject() ) {
my $ref = ref( $items );
if ( $ref eq 'ARRAY' ) {
push @out => @$items;
}
elsif ( !$ref ) {
push @out => $items;
}
else {
$self->bail( "$items is not a valid injection" );
}
}
return @out;
}
sub _check_parts {
my $self = shift;
$self->bail( "You must provide a name to " . $self->name . "()" )
if ( !$self->parts || !@{ $self->parts });
if ( @{ $self->parts } > 3 ) {
( undef, undef, undef, my @bad ) = @{ $self->parts };
$self->bail(
"Syntax error near: " . join( ' and ',
map { $self->format_part($_)} @bad
)
);
}
}
sub sort_parts {
my $self = shift;
if ($self->parts->[0] =~ m/^[\%\$\&\@]/) {
$self->parts->[0] = [
$self->parts->[0],
undef,
];
}
$self->bail(
"Parsing Error, unrecognized tokens: "
. join( ', ', map {"'$_'"} $self->has_non_string_or_quote_parts )
) if $self->has_non_string_or_quote_parts;
my ( @names, @specs );
for my $part (@{ $self->parts }) {
$self->bail( "Bad part: $part" ) unless ref($part);
$part->[1] && $part->[1] eq '('
? ( push @specs => $part )
: ( push @names => $part )
}
if ( @names > 2 ) {
( undef, undef, my @bad ) = @names;
$self->bail(
"Syntax error near: " . join( ' and ',
map { $self->format_part($_)} @bad
)
);
}
return ( \@names, \@specs );
}
sub strip_prototype {
my $self = shift;
my $parts = $self->parts;
return unless @$parts > 3;
return unless ref( $parts->[2] );
return unless $parts->[2]->[0] eq 'sub';
return unless ref( $parts->[3] );
return unless $parts->[3]->[1] eq '(';
return unless !$parts->[2]->[1];
$self->prototype(
$parts->[3]->[1]
. $parts->[3]->[0]
. $self->end_quote($parts->[3]->[1])
);
delete $parts->[3];
}
sub rewrite {
my $self = shift;
$self->strip_prototype;
$self->_check_parts;
my $is_arrow = $self->parts->[1]
&& ($self->parts->[1] eq '=>' || $self->parts->[1] eq ',');
if ( $is_arrow && $self->parts->[2] ) {
my $is_ref = !ref( $self->parts->[2] );
my $is_sub = $is_ref ? 0 : $self->parts->[2]->[0] eq 'sub';
if (( $is_arrow && $is_ref )
|| ( @{ $self->parts } == 1 )) {
$self->new_parts([ $self->parts->[0], $self->parts->[2] ]);
return 1;
}
elsif (( $is_arrow && $is_sub )
|| ( @{ $self->parts } == 1 )) {
$self->new_parts([ $self->parts->[0] ]);
return 1;
}
}
my ( $names, $specs ) = $self->sort_parts();
$self->parser( $names->[1] ? $names->[1]->[0] : undef );
push @$names => 'undef' unless @$names > 1;
$self->new_parts( $names );
if ( @$specs ) {
$self->bail( "Too many spec defenitions" )
if @$specs > 1;
my $specs = eval "{ " . $specs->[0]->[0] . " }"
|| $self->bail($@);
$self->_inject( delete $specs->{ inject });
}
1;
}
1;
__END__
=head1 NAME
Exporter::Declare::Magic::Parser - The parser behind the export() magic.
=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_MAGIC_PARSER
$fatpacked{"Exporter/Declare/Magic/Sub.pm"} = <<'EXPORTER_DECLARE_MAGIC_SUB';
package Exporter::Declare::Magic::Sub;
use strict;
use warnings;
use base 'Exporter::Declare::Export::Sub';
sub inject {
my $self = shift;
my ($class, $name) = @_;
$self->SUPER::inject( $class, $name );
return unless $self->parser;
my $parser_sub = $self->exported_by->export_meta->parsers_get( $self->parser );
if ( $parser_sub ) {
require Devel::Declare;
Devel::Declare->setup_for(
$class,
{ $name => { const => $parser_sub } }
);
}
else {
require Devel::Declare::Interface;
require Exporter::Declare::Magic::Parser;
Devel::Declare::Interface::enhance(
$class,
$name,
$self->parser,
);
}
}
sub parser {
my $self = shift;
return $self->_data->{parser};
}
1;
=head1 NAME
Exporter::Declare::Magic::Sub - Export class for subs which are exported.
=head1 DESCRIPTION
Export class for subs which are exported. Overrides inject() in order to hook
into L<Devel::Declare> on parsed exports.
=head1 OVERRIDEN METHODS
=over 4
=item $export->inject( $class, $name );
Inject the sub, and apply the L<Devel::Declare> magic.
=back
=head1 NEW METHODS
=over 4
=item $parser_name = export->parser()
Get the name of the parse this sub should use with L<Devel::Declare> empty when
no parse should be used.
=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_MAGIC_SUB
$fatpacked{"Exporter/Declare/Meta.pm"} = <<'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);
$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 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"} = <<'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 _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 $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"} = <<'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.27104';
@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;
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;
}
} until ( !$self->{incr_text} );
$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 ( $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_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 or '';
}
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.27103
=head1 NOTE
JSON::PP was inculded in JSON distribution (CPAN module).
It comes to be a perl core module in Perl 5.14.
[STEPS]
* release this module as JSON::PPdev.
* release other PP::* modules as JSON::PP::Compat*.
* JSON distribution will inculde yet another JSON::PP modules.
They are JSNO::backportPP. So JSON.pm should work as it did at all!
* remove JSON::PP and JSON::PP::* modules from JSON distribution
and release it as developer version.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* release JSON distribution as stable version.
* rename JSON::PPdev into JSON::PP and release on CPAN. <<<< HERE
=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 = new JSON::PP
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-2010 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"} = <<'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"} = <<'LOG_CONTEXTUAL';
package Log::Contextual;
use strict;
use warnings;
our $VERSION = '0.004001';
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';
my @dlog = ((map "Dlog_$_", @levels), (map "DlogS_$_", @levels));
my @log = ((map "log_$_", @levels), (map "logS_$_", @levels));
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 before_import {
my ($class, $importer, $spec) = @_;
die 'Log::Contextual does not have a default import list'
if $spec->config->{default};
my @levels = @{$class->arg_levels($spec->config->{levels})};
for my $level (@levels) {
if ($spec->config->{log}) {
$spec->add_export("&log_$level", sub (&@) {
_do_log( $level => _get_logger( caller ), shift @_, @_)
});
$spec->add_export("&logS_$level", sub (&@) {
_do_logS( $level => _get_logger( caller ), $_[0], $_[1])
});
}
if ($spec->config->{dlog}) {
$spec->add_export("&Dlog_$level", sub (&@) {
my ($code, @args) = @_;
return _do_log( $level => _get_logger( caller ), sub {
local $_ = (@args?Data::Dumper::Concise::Dumper @args:'()');
$code->(@_)
}, @args );
});
$spec->add_export("&DlogS_$level", sub (&$) {
my ($code, $ref) = @_;
_do_logS( $level => _get_logger( caller ), sub {
local $_ = Data::Dumper::Concise::Dumper $ref;
$code->($ref)
}, $ref )
});
}
}
}
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 after_import {
my ($class, $importer, $specs) = @_;
if (my $l = $class->arg_logger($specs->config->{logger})) {
set_logger($l)
}
if (my $l = $class->arg_package_logger($specs->config->{package_logger})) {
_set_package_logger_for($importer, $l)
}
if (my $l = $class->arg_default_logger($specs->config->{default_logger})) {
_set_default_logger_for($importer, $l)
}
}
our $Get_Logger;
our %Default_Logger;
our %Package_Logger;
sub _set_default_logger_for {
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 } }
}
$Default_Logger{$_[0]} = $logger
}
sub _set_package_logger_for {
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 } }
}
$Package_Logger{$_[0]} = $logger
}
sub _get_logger($) {
my $package = shift;
(
$Package_Logger{$package} ||
$Get_Logger ||
$Default_Logger{$package} ||
die q( no logger set! you can't try to log something without a logger! )
)->($package);
}
sub set_logger {
my $logger = $_[0];
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 $Get_Logger;
$Get_Logger = $logger;
}
sub with_logger {
my $logger = $_[0];
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 $Get_Logger = $logger;
$_[1]->();
}
sub _do_log {
my $level = shift;
my $logger = shift;
my $code = shift;
my @values = @_;
$logger->$level($code->(@_))
if $logger->${\"is_$level"};
@values
}
sub _do_logS {
my $level = shift;
my $logger = shift;
my $code = shift;
my $value = shift;
$logger->$level($code->($value))
if $logger->${\"is_$level"};
$value
}
1;
__END__
=head1 NAME
Log::Contextual - Simple logging interface with a contextual log
=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 {
with_logger(Log::Contextual::SimpleLogger->new({
levels => [qw( trace debug )]
}) => sub {
log_trace { 'foo entered' };
my ($foo, $bar) = Dlog_trace { "params for foo: $_" } @_;
# ...
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
This module is a simple interface to extensible logging. 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.)
The reason for this module is to abstract your logging interface so that
logging is as painless as possible, while still allowing you to switch from one
logger to another.
=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 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 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_logger { $_[1] || Log::Log4perl->get_logger }
sub arg_levels { [qw(debug trace warn info error fatal custom_level)] }
# and *maybe* even these:
sub arg_package_logger { $_[1] }
sub arg_default_logger { $_[1] }
Note the C<< $_[1] || >> in C<arg_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 -logger => $foo, -levels => [qw(bar baz biff)];
Your C<arg_logger> method will get C<$foo> and your C<arg_levels>
will get C<[qw(bar baz biff)]>;
=head1 FUNCTIONS
=head2 set_logger
my $logger = WarnLogger->new;
set_logger $logger;
Arguments: C<Ref|CodeRef $returning_logger>
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: C<Ref|CodeRef $returning_logger, 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>
All of the following six functions 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.
=head3 log_trace
log_trace { 'entered method foo with args ' join q{,}, @args };
=head3 log_debug
log_debug { 'entered method foo' };
=head3 log_info
log_info { 'started process foo' };
=head3 log_warn
log_warn { 'possible misconfiguration at line 10' };
=head3 log_error
log_error { 'non-numeric user input!' };
=head3 log_fatal
log_fatal { '1 is never equal to 0!' };
=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"
=head3 Dlog_trace
my ($foo, $bar) = Dlog_trace { "entered method foo with args: $_" } @_;
=head3 Dlog_debug
Dlog_debug { "random data structure: $_" } { foo => $bar };
=head3 Dlog_info
return Dlog_info { "html from method returned: $_" } "<html>...</html>";
=head3 Dlog_warn
Dlog_warn { "probably invalid value: $_" } $foo;
=head3 Dlog_error
Dlog_error { "non-numeric user input! ($_)" } $port;
=head3 Dlog_fatal
Dlog_fatal { '1 is never equal to 0!' } 'ZOMG ZOMG' if 1 == 0;
=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 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 AUTHOR
frew - Arthur Axel "fREW" Schmidt <frioux@gmail.com>
=head1 DESIGNER
mst - Matt S. Trout <mst@shadowcat.co.uk>
=head1 COPYRIGHT
Copyright (c) 2010 the Log::Contextual L</AUTHOR> and L</DESIGNER> as listed
above.
=head1 LICENSE
This library is free software and may be distributed under the same terms as
Perl 5 itself.
=cut
LOG_CONTEXTUAL
$fatpacked{"Log/Contextual/SimpleLogger.pm"} = <<'LOG_CONTEXTUAL_SIMPLELOGGER';
package Log::Contextual::SimpleLogger;
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__
=head1 NAME
Log::Contextual::SimpleLogger - Super simple logger made for playing with Log::Contextual
=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
See L<Log::Contextual/"AUTHOR">
=head1 COPYRIGHT
See L<Log::Contextual/"COPYRIGHT">
=head1 LICENSE
See L<Log::Contextual/"LICENSE">
=cut
LOG_CONTEXTUAL_SIMPLELOGGER
$fatpacked{"Log/Contextual/TeeLogger.pm"} = <<'LOG_CONTEXTUAL_TEELOGGER';
package Log::Contextual::TeeLogger;
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__
=head1 NAME
Log::Contextual::TeeLogger - Output to more than one logger
=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
See L<Log::Contextual/"AUTHOR">
=head1 COPYRIGHT
See L<Log::Contextual/"COPYRIGHT">
=head1 LICENSE
See L<Log::Contextual/"LICENSE">
=cut
LOG_CONTEXTUAL_TEELOGGER
$fatpacked{"Log/Contextual/WarnLogger.pm"} = <<'LOG_CONTEXTUAL_WARNLOGGER';
package Log::Contextual::WarnLogger;
use strict;
use warnings;
{
my @levels = (qw( trace debug info warn error fatal ));
my %level_num; @level_num{ @levels } = (0 .. $#levels);
for my $name (@levels) {
no strict 'refs';
my $is_name = "is_$name";
*{$name} = sub {
my $self = shift;
$self->_log( $name, @_ )
if $self->$is_name;
};
*{$is_name} = sub {
my $self = shift;
return 1 if $ENV{$self->{env_prefix} . '_' . uc $name};
my $upto = $ENV{$self->{env_prefix} . '_UPTO'};
return unless $upto;
$upto = lc $upto;
return $level_num{$name} >= $level_num{$upto};
};
}
}
sub new {
my ($class, $args) = @_;
my $self = bless {}, $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__
=head1 NAME
Log::Contextual::WarnLogger - Simple logger for libraries using Log::Contextual
=head1 SYNOPSIS
package My::Package;
use Log::Contextual::WarnLogger;
use Log::Contextual qw( :log ),
-default_logger => Log::Contextual::WarnLogger->new({
env_prefix => 'MY_PACKAGE'
});
# 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 ] $conf >>
my $l = Log::Contextual::WarnLogger->new({
env_prefix
});
Creates a new logger object where C<env_prefix> defines what the prefix is for
the environment variables that will be checked for the six log levels. 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!' );
=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;
=head1 AUTHOR
See L<Log::Contextual/"AUTHOR">
=head1 COPYRIGHT
See L<Log::Contextual/"COPYRIGHT">
=head1 LICENSE
See L<Log::Contextual/"LICENSE">
=cut
LOG_CONTEXTUAL_WARNLOGGER
$fatpacked{"MRO/Compat.pm"} = <<'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.11';
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 FooClass; use base qw/X Y Z/;
package X; use base qw/ZZZ/;
package Y; use base qw/ZZZ/;
package Z; use base qw/ZZZ/;
package main;
use MRO::Compat;
my $linear = mro::get_linear_isa('FooClass');
print join(q{, }, @$linear);
# Prints: "FooClass, X, ZZZ, 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"} = <<'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"} = <<'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"} = <<'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"} = <<'METHOD_GENERATE_ACCESSOR';
package Method::Generate::Accessor;
use strictures 1;
use Moo::_Utils;
use base qw(Moo::Object);
use Sub::Quote;
use B 'perlstring';
BEGIN {
our $CAN_HAZ_XS =
!$ENV{MOO_XS_DISABLE}
&&
_maybe_load_module('Class::XSAccessor')
&&
(Class::XSAccessor->VERSION > 1.06)
;
}
sub generate_method {
my ($self, $into, $name, $spec, $quote_opts) = @_;
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};
} elsif ($is eq 'lazy') {
$spec->{init_arg} = undef unless exists $spec->{init_arg};
$spec->{reader} = $name unless exists $spec->{reader};
$spec->{lazy} = 1;
$spec->{builder} ||= '_build_'.$name unless $spec->{default};
} elsif ($is ne 'bare') {
die "Unknown is ${is}";
}
my %methods;
if (my $reader = $spec->{reader}) {
if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
$methods{$reader} = $self->_generate_xs(
getters => $into, $reader, $name
);
} 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}) {
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
);
} else {
$self->{captures} = {};
$methods{$accessor} =
quote_sub "${into}::${accessor}"
=> $self->_generate_getset($name, $spec)
=> delete $self->{captures}
;
}
}
if (my $writer = $spec->{writer}) {
if (
our $CAN_HAZ_XS
&& $self->is_simple_set($name, $spec)
) {
$methods{$writer} = $self->_generate_xs(
setters => $into, $writer, $name
);
} else {
$self->{captures} = {};
$methods{$writer} =
quote_sub "${into}::${writer}"
=> $self->_generate_set($name, $spec)
=> delete $self->{captures}
;
}
}
if (my $pred = $spec->{predicate}) {
$methods{$pred} =
quote_sub "${into}::${pred}" =>
' '.$self->_generate_simple_has('$_[0]', $name)."\n"
;
}
if (my $cl = $spec->{clearer}) {
$methods{$cl} =
quote_sub "${into}::${cl}" =>
" delete \$_[0]->{${\perlstring $name}}\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 [ $_ => $_ ], Role::Tiny->methods_provided_by($hspec);
} else {
die "You gave me a handles of ${hspec} and I have no idea why";
}
};
foreach my $spec (@specs) {
my ($proxy, $target, @args) = @$spec;
$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}" =>
'do { '.$self->_generate_get($name, $spec).qq! }||die "Attempted to access '${name}' but it is not set"!,
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 ($spec->{default} or $spec->{builder}));
}
sub is_simple_set {
my ($self, $name, $spec) = @_;
!grep $spec->{$_}, qw(coerce isa trigger weak_ref);
}
sub has_eager_default {
my ($self, $name, $spec) = @_;
(!$spec->{lazy} and ($spec->{default} or $spec->{builder}));
}
sub _generate_get {
my ($self, $name, $spec) = @_;
my $simple = $self->_generate_simple_get('$_[0]', $name);
if ($self->is_simple_get($name, $spec)) {
$simple;
} else {
'do { '.$self->_generate_use_default(
'$_[0]', $name, $spec,
$self->_generate_simple_has('$_[0]', $name),
).'; '.$simple.' }';
}
}
sub _generate_simple_has {
my ($self, $me, $name) = @_;
"exists ${me}->{${\perlstring $name}}";
}
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, $me, $name, $spec, $test) = @_;
$self->_generate_simple_set(
$me, $name, $spec, $self->_generate_get_default($me, $name, $spec)
).' unless '.$test;
}
sub _generate_get_default {
my ($self, $me, $name, $spec) = @_;
$spec->{default}
? $self->_generate_call_code($name, 'default', $me, $spec->{default})
: "${me}->${\$spec->{builder}}"
}
sub generate_simple_get {
my ($self, @args) = @_;
$self->_generate_simple_get(@args);
}
sub _generate_simple_get {
my ($self, $me, $name) = @_;
my $name_str = perlstring $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 $simple = $self->_generate_simple_set('$self', $name, $spec, '$value');
my $code = "do { my (\$self, \$value) = \@_;\n";
if ($coerce) {
$code .=
" \$value = "
.$self->_generate_coerce($name, '$self', '$value', $coerce).";\n";
}
if ($isa_check) {
$code .=
" ".$self->_generate_isa_check($name, '$value', $isa_check).";\n";
}
if ($trigger) {
my $fire = $self->_generate_trigger($name, '$self', '$value', $trigger);
$code .=
" ".$simple.";\n ".$fire.";\n"
." \$value;\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 _generate_coerce {
my ($self, $name, $obj, $value, $coerce) = @_;
$self->_generate_call_code($name, 'coerce', "${value}", $coerce);
}
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 _generate_isa_check {
my ($self, $name, $value, $check) = @_;
$self->_generate_call_code($name, 'isa_check', $value, $check);
}
sub _generate_call_code {
my ($self, $name, $type, $values, $sub) = @_;
if (my $quoted = quoted_from_sub($sub)) {
my $code = $quoted->[1];
my $at_ = '@_ = ('.$values.');';
if (my $captures = $quoted->[2]) {
my $cap_name = qq{\$${type}_captures_for_${name}};
$self->{captures}->{$cap_name} = \$captures;
Sub::Quote::inlinify(
$code, $values, Sub::Quote::capture_unroll($cap_name, $captures, 6)
);
} else {
Sub::Quote::inlinify($code, $values);
}
} else {
my $cap_name = qq{\$${type}_for_${name}};
$self->{captures}->{$cap_name} = \$sub;
"${cap_name}->(${values})";
}
}
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) = @_;
if ($self->has_eager_default($name, $spec)) {
my $get_indent = ' ' x ($spec->{isa} ? 6 : 4);
my $get_default = $self->_generate_get_default(
'$new', $_, $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, $me, $get_value,
$spec->{coerce}
)
}
($spec->{isa}
? " {\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"
)
.($spec->{trigger}
? ' '
.$self->_generate_trigger(
$name, $me, $self->_generate_simple_get($me, $name),
$spec->{trigger}
)." if ${test};\n"
: ''
);
} else {
" if (${test}) {\n"
.($spec->{coerce}
? " $source = "
.$self->_generate_coerce(
$name, $me, $source,
$spec->{coerce}
).";\n"
: ""
)
.($spec->{isa}
? " "
.$self->_generate_isa_check(
$name, $source, $spec->{isa}
).";\n"
: ""
)
." ".$self->_generate_simple_set($me, $name, $spec, $source).";\n"
.($spec->{trigger}
? " "
.$self->_generate_trigger(
$name, $me, $self->_generate_simple_get($me, $name),
$spec->{trigger}
).";\n"
: ""
)
." }\n";
}
}
sub generate_multi_set {
my ($self, $me, $to_set, $from) = @_;
"\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
}
sub _generate_simple_set {
my ($self, $me, $name, $spec, $value) = @_;
my $name_str = perlstring $name;
my $simple = "${me}->{${name_str}} = ${value}";
if ($spec->{weak_ref}) {
{ local $@; require Scalar::Util; }
# Perl < 5.8.3 can't weaken refs to readonly vars
# (e.g. string constants). This *can* be solved by:
#
#Internals::SetReadWrite($foo);
#Scalar::Util::weaken ($foo);
#Internals::SetReadOnly($foo);
#
# but requires XS and is just too damn crazy
# so simply throw a better exception
Moo::_Utils::lt_5_8_3() ? <<"EOC" : "Scalar::Util::weaken(${simple})";
eval { Scalar::Util::weaken($simple); 1 } or do {
if( \$@ =~ /Modification of a read-only value attempted/) {
{ local $@; 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_delegation {
my ($self, $asserter, $target, $args) = @_;
my $arg_string = do {
if (@$args) {
# I could, I reckon, linearise out non-refs here using perlstring
# 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 }
);
$into->can($name);
}
1;
METHOD_GENERATE_ACCESSOR
$fatpacked{"Method/Generate/BuildAll.pm"} = <<'METHOD_GENERATE_BUILDALL';
package Method::Generate::BuildAll;
use strictures 1;
use base qw(Moo::Object);
use Sub::Quote;
use Moo::_Utils;
use B 'perlstring';
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 '.perlstring($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 @{Moo::_Utils::_get_linear_isa($into)};
join '', map qq{ ${me}->${_}(${args});\n}, @builds;
}
1;
METHOD_GENERATE_BUILDALL
$fatpacked{"Method/Generate/Constructor.pm"} = <<'METHOD_GENERATE_CONSTRUCTOR';
package Method::Generate::Constructor;
use strictures 1;
use Sub::Quote;
use base qw(Moo::Object);
use Sub::Defer;
use B 'perlstring';
sub register_attribute_specs {
my ($self, %spec) = @_;
@{$self->{attribute_specs}||={}}{keys %spec} = values %spec;
$self;
}
sub all_attribute_specs {
$_[0]->{attribute_specs}
}
sub accessor_generator {
$_[0]->{accessor_generator}
}
sub construction_string {
my ($self) = @_;
$self->{construction_string} or 'bless({}, $class);'
}
sub install_delayed {
my ($self) = @_;
my $package = $self->{package};
defer_sub "${package}::new" => sub {
unquote_sub $self->generate_method(
$package, 'new', $self->{attribute_specs}, { no_install => 1 }
)
};
$self;
}
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')) {
{ local $@; require Method::Generate::BuildAll; }
$body .= Method::Generate::BuildAll->new->buildall_body_for(
$into, '$new', '$args'
);
}
$body .= ' return $new;'."\n";
if ($into->can('DEMOLISH')) {
{ local $@; 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_generator}) {
' if ($class ne '.perlstring($into).') {'."\n".
' '.$gen.";\n".
' return $class->'.$name.'(@_)'.";\n".
' }'."\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";
}
# 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 (@init, @slots, %test);
my $ag = $self->accessor_generator;
NAME: foreach my $name (sort keys %$spec) {
my $attr_spec = $spec->{$name};
unless ($ag->is_simple_attribute($name, $attr_spec)) {
next NAME unless defined($attr_spec->{init_arg})
or $ag->has_eager_default($name, $attr_spec);
$test{$name} = $attr_spec->{init_arg};
next NAME;
}
next NAME unless defined(my $i = $attr_spec->{init_arg});
push @init, $i;
push @slots, $name;
}
return '' unless @init or %test;
join '', (
@init
? ' '.$self->_cap_call($ag->generate_multi_set(
'$new', [ @slots ], '@{$args}{qw('.join(' ',@init).')}'
)).";\n"
: ''
), map {
my $arg_key = perlstring($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
));
} sort keys %test;
}
sub _check_required {
my ($self, $spec) = @_;
my @required_init =
map $spec->{$_}{init_arg},
grep $spec->{$_}{required},
sort keys %$spec;
return '' unless @required_init;
' if (my @missing = grep !exists $args->{$_}, qw('
.join(' ',@required_init).')) {'."\n"
.q{ die "Missing required arguments: ".join(', ', sort @missing);}."\n"
." }\n";
}
sub _check_isa {
my ($self, $spec) = @_;
my $acc = $self->accessor_generator;
my $captures = $self->{captures};
my $check = '';
foreach my $name (sort keys %$spec) {
my ($init, $isa) = @{$spec->{$name}}{qw(init_arg isa)};
next unless $init and $isa;
my $init_str = perlstring($init);
my ($code, $add_captures) = $acc->generate_isa_check(
$name, "\$args->{${init_str}}", $isa
);
@{$captures}{keys %$add_captures} = values %$add_captures;
$check .= " ${code}".(
(not($spec->{lazy}) and ($spec->{default} or $spec->{builder})
? ";\n"
: "if exists \$args->{${init_str}};\n"
)
);
}
return $check;
}
sub _fire_triggers {
my ($self, $spec) = @_;
my $acc = $self->accessor_generator;
my $captures = $self->{captures};
my $fire = '';
foreach my $name (sort keys %$spec) {
my ($init, $trigger) = @{$spec->{$name}}{qw(init_arg trigger)};
next unless $init && $trigger;
my ($code, $add_captures) = $acc->generate_trigger(
$name, '$new', $acc->generate_simple_get('$new', $name), $trigger
);
@{$captures}{keys %$add_captures} = values %$add_captures;
$fire .= " ${code} if exists \$args->{${\perlstring $init}};\n";
}
return $fire;
}
1;
METHOD_GENERATE_CONSTRUCTOR
$fatpacked{"Method/Generate/DemolishAll.pm"} = <<'METHOD_GENERATE_DEMOLISHALL';
package Method::Generate::DemolishAll;
use strictures 1;
use base qw(Moo::Object);
use Sub::Quote;
use Moo::_Utils;
use B qw(perlstring);
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 Moo::_Utils;
eval {
$self->DEMOLISHALL($Moo::_Utils::_in_global_destruction);
};
$@;
};
no warnings 'misc';
die $e if $e; # rethrow
!;
}
sub demolishall_body_for {
my ($self, $into, $me, $args) = @_;
my @demolishers =
grep *{_getglob($_)}{CODE},
map "${_}::DEMOLISH",
@{Moo::_Utils::_get_linear_isa($into)};
join '', map qq{ ${me}->${_}(${args});\n}, @demolishers;
}
sub _handle_subdemolish {
my ($self, $into) = @_;
' if (ref($_[0]) ne '.perlstring($into).') {'."\n".
' return shift->Moo::Object::DEMOLISHALL(@_)'.";\n".
' }'."\n";
}
1;
METHOD_GENERATE_DEMOLISHALL
$fatpacked{"Method/Inliner.pm"} = <<'METHOD_INLINER';
package Method::Inliner;
use strictures 1;
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"} = <<'MOO';
package Moo;
use strictures 1;
use Moo::_Utils;
use B 'perlstring';
our $VERSION = '0.009012'; # 0.9.12
$VERSION = eval $VERSION;
our %MAKERS;
sub import {
my $target = caller;
my $class = shift;
strictures->import;
return if $MAKERS{$target}; # already exported into this package
*{_getglob("${target}::extends")} = sub {
_load_module($_) for @_;
# Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA
@{*{_getglob("${target}::ISA")}{ARRAY}} = @_;
};
*{_getglob("${target}::with")} = sub {
{ local $@; require Moo::Role; }
die "Only one role supported at a time by with" if @_ > 1;
Moo::Role->apply_role_to_package($target, $_[0]);
};
$MAKERS{$target} = {};
*{_getglob("${target}::has")} = sub {
my ($name, %spec) = @_;
($MAKERS{$target}{accessor} ||= do {
{ local $@; require Method::Generate::Accessor; }
Method::Generate::Accessor->new
})->generate_method($target, $name, \%spec);
$class->_constructor_maker_for($target)
->register_attribute_specs($name, \%spec);
};
foreach my $type (qw(before after around)) {
*{_getglob "${target}::${type}"} = sub {
{ local $@; require Class::Method::Modifiers; }
_install_modifier($target, $type, @_);
};
}
{
no strict 'refs';
@{"${target}::ISA"} = do {
{; local $@; require Moo::Object; } ('Moo::Object');
} unless @{"${target}::ISA"};
}
}
sub _constructor_maker_for {
my ($class, $target, $select_super) = @_;
return unless $MAKERS{$target};
$MAKERS{$target}{constructor} ||= do {
{
local $@;
require Method::Generate::Constructor;
require Sub::Defer;
}
my ($moo_constructor, $con);
if ($select_super && $MAKERS{$select_super}) {
$moo_constructor = 1;
$con = $MAKERS{$select_super}{constructor};
} else {
my $t_new = $target->can('new');
if ($t_new) {
if ($t_new == Moo::Object->can('new')) {
$moo_constructor = 1;
} elsif (my $defer_target = (Sub::Defer::defer_info($t_new)||[])->[0]) {
my ($pkg) = ($defer_target =~ /^(.*)::[^:]+$/);
if ($MAKERS{$pkg}) {
$moo_constructor = 1;
$con = $MAKERS{$pkg}{constructor};
}
}
} else {
$moo_constructor = 1; # no other constructor, make a Moo one
}
};
Method::Generate::Constructor
->new(
package => $target,
accessor_generator => do {
{ local $@; require Method::Generate::Accessor; }
Method::Generate::Accessor->new;
},
construction_string => (
$moo_constructor
? ($con ? $con->construction_string : undef)
: ('$class->'.$target.'::SUPER::new(@_)')
),
subconstructor_generator => (
$class.'->_constructor_maker_for($class,'.perlstring($target).')'
),
)
->install_delayed
->register_attribute_specs(%{$con?$con->all_attribute_specs:{}})
}
}
1;
=pod
=encoding utf-8
=head1 NAME
Moo - Minimalist Object Orientation (with Moose compatiblity)
=head1 SYNOPSIS
package Cat::Food;
use Moo;
use Sub::Quote;
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 => quote_sub q{ die "$_[0] is too much cat food!" unless $_[0] < 15 },
);
1;
and else where
my $full = Cat::Food->new(
taste => 'DELICIOUS.',
brand => 'SWEET-TREATZ',
pounds => 10,
);
$full->feed_lion;
say $full->pounds;
=head1 DESCRIPTION
This module is an extremely light-weight, high-performance L<Moose> replacement.
It also avoids depending on any XS modules to allow simple deployments. The
name C<Moo> is based on the idea that it provides almost -but not quite- two
thirds of L<Moose>.
Unlike C<Mouse> this module does not aim at full L<Moose> compatibility. See
L</INCOMPATIBILITIES> for more details.
=head1 WHY MOO EXISTS
If you want a full object system with a rich Metaprotocol, L<Moose> is
already wonderful.
I've tried several times to use L<Mouse> but it's 3x the size of Moo and
takes longer to load than most of my Moo based CGI scripts take to run.
If you don't want L<Moose>, you don't want "less metaprotocol" like L<Mouse>,
you want "as little as possible" - which means "no metaprotocol", which is
what Moo provides.
By Moo 1.0 I intend to have Moo's equivalent of L<Any::Moose> built in -
if Moose gets loaded, any Moo class or role will act as a Moose equivalent
if treated as such.
Hence - Moo exists as its name - Minimal Object Orientation - with a pledge
to make it smooth to upgrade to L<Moose> when you need more than minimal
features.
=head1 IMPORTED METHODS
=head2 new
Foo::Bar->new( attr1 => 3 );
or
Foo::Bar->new({ attr1 => 3 });
=head2 BUILDARGS
around BUILDARGS => sub {
my $orig = shift;
my ( $class, @args ) = @_;
unshift @args, "attr1" if @args % 2 == 1;
return $class->$orig(@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 BUILDALL
Don't override (or probably even call) this method. Instead, you can 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 DESTROY
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 base class. Multiple superclasses can be passed for multiple
inheritance (but please use roles instead).
Calling extends more than once will REPLACE your superclasses, not add to
them like 'use base' would.
=head2 with
with 'Some::Role1';
with 'Some::Role2';
Composes a L<Role::Tiny> into current class. Only one role may be composed in
at a time to allow the code to remain as simple as possible.
=head2 has
has attr => (
is => 'ro',
);
Declares an attribute for the class.
The options for C<has> are as follows:
=over 2
=item * is
B<required>, must be C<ro> or C<rw>. Unsurprisingly, C<ro> generates an
accessor that will not respond to arguments; to be clear: a getter only. C<rw>
will create a perlish getter/setter.
=item * isa
Takes a coderef which is meant 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
isa => quote_sub q{
die "$_[0] is not a number!" unless looks_like_number $_[0]
},
L<Sub::Quote aware|/SUB QUOTE AWARE>
=item * coerce
Takes a coderef which is meant to coerce the attribute. The basic idea is to
do something like the following:
coerce => quote_sub q{
$_[0] + 1 unless $_[0] % 2
},
Coerce does not require C<isa> to be defined.
L<Sub::Quote aware|/SUB QUOTE AWARE>
=item * trigger
Takes a coderef which will get called any time the attribute is set. Coderef
will be invoked against the object with the new value as an argument.
Note that Moose also passes the old value, if any; this feature is not yet
supported.
L<Sub::Quote aware|/SUB QUOTE AWARE>
=item * default
Takes a coderef which will get called with $self as its only argument
to populate an attribute if no value is supplied to the constructor - or
if the attribute is lazy, when the attribute is first retrieved if no
value has yet been provided.
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 * predicate
Takes a method name which will return true if an attribute has a value.
A common example of this would be to call it C<has_$foo>, implying that the
object has a C<$foo> set.
=item * 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;
=item * clearer
Takes a method name which will clear the attribute.
=item * 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 * required
B<Boolean>. Set this if the attribute must be passed on instantiation.
=item * reader
The value of this attribute will be the name of the method to get the value of
the attribute. If you like Java style methods, you might set this to
C<get_foo>
=item * 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 * weak_ref
B<Boolean>. Set this if you want the reference that the attribute contains to
be weakened; use this when circular references are possible, which will cause
leaks.
=item * 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
=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.
=head1 INCOMPATIBILITIES WITH MOOSE
You can only compose one role at a time. If your application is large or
complex enough to warrant complex composition, you wanted L<Moose>.
There is no complex type system. C<isa> is verified with a coderef, if you
need complex types, just make a library of coderefs, or better yet, functions
that return quoted subs.
C<initializer> is not supported in core since the author considers it to be a
bad idea but may be supported by an extension in future.
There is no meta object. If you need this level of complexity you wanted
L<Moose> - Moo succeeds at being small because it explicitly does not
provide a metaprotocol.
No support for C<super>, C<override>, C<inner>, or C<augment> - override can
be handled by around albeit with a little more typing, and the author considers
augment to be a bad idea.
L</default> only supports coderefs, because doing otherwise is usually a
mistake anyway.
C<lazy_build> is not supported per se, but of course it will work if you
manually set all the options it implies.
C<auto_deref> is not supported since the author considers it a bad idea.
C<documentation> is not supported since it's a very poor replacement for POD.
=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>
=head1 COPYRIGHT
Copyright (c) 2010-2011 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.
=cut
MOO
$fatpacked{"Moo/Object.pm"} = <<'MOO_OBJECT';
package Moo::Object;
use strictures 1;
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 {
{ local $@; require Method::Generate::DemolishAll; }
Method::Generate::DemolishAll->new
})->generate_method($class);
}
}
$NO_BUILD{$class} and
return bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class);
$NO_BUILD{$class} = !$class->can('BUILD') unless exists $NO_BUILD{$class};
$NO_BUILD{$class}
? bless({ ref($_[0]) eq 'HASH' ? %{$_[0]} : @_ }, $class)
: do {
my $proto = ref($_[0]) eq 'HASH' ? $_[0] : { @_ };
bless({ %$proto }, $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 {
{ local $@; require Method::Generate::BuildAll; }
Method::Generate::BuildAll->new
})->generate_method(ref($self)))}(@_);
}
sub DEMOLISHALL {
my $self = shift;
$self->${\(($DEMOLISH_MAKER ||= do {
{ local $@; require Method::Generate::DemolishAll; }
Method::Generate::DemolishAll->new
})->generate_method(ref($self)))}(@_);
}
sub does {
{ local $@; require Role::Tiny; }
{ no warnings 'redefine'; *does = \&Role::Tiny::does_role }
goto &Role::Tiny::does_role;
}
1;
MOO_OBJECT
$fatpacked{"Moo/Role.pm"} = <<'MOO_ROLE';
package Moo::Role;
use strictures 1;
use Moo::_Utils;
use base qw(Role::Tiny);
BEGIN { *INFO = \%Role::Tiny::INFO }
our %INFO;
sub import {
my $target = caller;
strictures->import;
return if $INFO{$target}; # already exported into this package
# get symbol table reference
my $stash = do { no strict 'refs'; \%{"${target}::"} };
*{_getglob "${target}::has"} = sub {
my ($name, %spec) = @_;
($INFO{$target}{accessor_maker} ||= do {
{ local $@; require Method::Generate::Accessor; }
Method::Generate::Accessor->new
})->generate_method($target, $name, \%spec);
$INFO{$target}{attributes}{$name} = \%spec;
};
goto &Role::Tiny::import;
}
sub apply_role_to_package {
my ($me, $to, $role) = @_;
$me->SUPER::apply_role_to_package($to, $role);
$me->_handle_constructor($to, $INFO{$role}{attributes});
}
sub create_class_with_roles {
my ($me, $superclass, @roles) = @_;
my $new_name = join(
'__WITH__', $superclass, my $compose_name = join '__AND__', @roles
);
return $new_name if $Role::Tiny::COMPOSED{class}{$new_name};
{ local $@; require Sub::Quote; }
$me->SUPER::create_class_with_roles($superclass, @roles);
foreach my $role (@roles) {
die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
}
$Moo::MAKERS{$new_name} = {};
$me->_handle_constructor(
$new_name, { map %{$INFO{$_}{attributes}||{}}, @roles }, $superclass
);
return $new_name;
}
sub _install_single_modifier {
my ($me, @args) = @_;
_install_modifier(@args);
}
sub _handle_constructor {
my ($me, $to, $attr_info, $superclass) = @_;
return unless $attr_info && keys %$attr_info;
if ($INFO{$to}) {
@{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info;
} else {
# only fiddle with the constructor if the target is a Moo class
if ($INC{"Moo.pm"}
and my $con = Moo->_constructor_maker_for($to, $superclass)) {
$con->register_attribute_specs(%$attr_info);
}
}
}
1;
=head1 NAME
Moo::Role - Minimal Object Orientation support for Roles
=head1 SYNOPSIS
package My::Role;
use Moo::Role;
sub foo { ... }
sub bar { ... }
has baz => (
is => 'ro',
);
1;
else where
package Some::Class;
use Moo;
# 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 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"} = <<'MOO__UTILS';
package Moo::_Utils;
sub _getglob { \*{$_[0]} }
sub _getstash { \%{"$_[0]::"} }
BEGIN {
*lt_5_8_3 = $] < 5.008003
? sub () { 1 }
: sub () { 0 }
;
}
use strictures 1;
use base qw(Exporter);
use Moo::_mro;
our @EXPORT = qw(
_getglob _install_modifier _load_module _maybe_load_module
_get_linear_isa
);
sub _install_modifier {
my ($into, $type, $name, $code) = @_;
if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
{ local $@; require Sub::Defer; }
Sub::Defer::undefer_sub($to_modify);
}
Class::Method::Modifiers::install_modifier(@_);
}
our %MAYBE_LOADED;
# _load_module is inlined in Role::Tiny - make sure to copy if you update it.
sub _load_module {
(my $proto = $_[0]) =~ s/::/\//g;
return 1 if $INC{"${proto}.pm"};
# can't just ->can('can') because a sub-package Foo::Bar::Baz
# creates a 'Baz::' key in Foo::Bar's symbol table
return 1 if grep !/::$/, keys %{_getstash($_[0])||{}};
{ local $@; require "${proto}.pm"; }
return 1;
}
sub _maybe_load_module {
return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
(my $proto = $_[0]) =~ s/::/\//g;
local $@;
if (eval { require "${proto}.pm"; 1 }) {
$MAYBE_LOADED{$_[0]} = 1;
} else {
if (exists $INC{"${proto}.pm"}) {
warn "$_[0] exists but failed to load with error: $@";
}
$MAYBE_LOADED{$_[0]} = 0;
}
return $MAYBE_LOADED{$_[0]};
}
sub _get_linear_isa {
return mro::get_linear_isa($_[0]);
}
our $_in_global_destruction = 0;
END { $_in_global_destruction = 1 }
sub STANDARD_DESTROY {
my $self = shift;
my $e = do {
local $?;
local $@;
eval {
$self->DEMOLISHALL($_in_global_destruction);
};
$@;
};
no warnings 'misc';
die $e if $e; # rethrow
}
1;
MOO__UTILS
$fatpacked{"Moo/_mro.pm"} = <<'MOO__MRO';
package Moo::_mro;
local $@;
if ($] >= 5.010) {
require mro;
} else {
require MRO::Compat;
}
1;
MOO__MRO
$fatpacked{"Role/Tiny.pm"} = <<'ROLE_TINY';
package Role::Tiny;
sub _getglob { \*{$_[0]} }
sub _getstash { \%{"$_[0]::"} }
use strict;
use warnings FATAL => 'all';
our %INFO;
our %APPLIED_TO;
our %COMPOSED;
# inlined from Moo::_Utils - update that first.
sub _load_module {
(my $proto = $_[0]) =~ s/::/\//g;
return 1 if $INC{"${proto}.pm"};
# can't just ->can('can') because a sub-package Foo::Bar::Baz
# creates a 'Baz::' key in Foo::Bar's symbol table
return 1 if grep !/::$/, keys %{_getstash($_[0])||{}};
{ local $@; require "${proto}.pm"; }
return 1;
}
{ # \[] is REF, not SCALAR. \v1 is VSTRING (thanks to doy for that one)
my %reftypes = map +($_ => 1), qw(SCALAR REF VSTRING);
sub _is_scalar_ref { $reftypes{ref($_[0])} }
}
sub import {
my $target = caller;
my $me = shift;
strictures->import;
return if $INFO{$target}; # already exported into this package
# get symbol table reference
my $stash = do { no strict 'refs'; \%{"${target}::"} };
# install before/after/around subs
foreach my $type (qw(before after around)) {
*{_getglob "${target}::${type}"} = sub {
{ local $@; require Class::Method::Modifiers; }
push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ];
};
}
*{_getglob "${target}::requires"} = sub {
push @{$INFO{$target}{requires}||=[]}, @_;
};
*{_getglob "${target}::with"} = sub {
die "Only one role supported at a time by with" if @_ > 1;
$me->apply_role_to_package($target, $_[0]);
};
# 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)
@{$INFO{$target}{not_methods}={}}{
'', map { *$_{CODE}||() } grep !_is_scalar_ref($_), values %$stash
} = ();
# a role does itself
$APPLIED_TO{$target} = { $target => undef };
}
sub apply_role_to_package {
my ($me, $to, $role) = @_;
_load_module($role);
die "This is apply_role_to_package" if ref($to);
die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
$me->_check_requires($to, $role, @{$info->{requires}||[]});
$me->_install_methods($to, $role);
$me->_install_modifiers($to, $info->{modifiers});
# only add does() method to classes and only if they don't have one
if (not $INFO{$to} and not $to->can('does')) {
*{_getglob "${to}::does"} = \&does_role;
}
# copy our role list into the target's
@{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = ();
}
sub apply_roles_to_object {
my ($me, $object, @roles) = @_;
die "No roles supplied!" unless @roles;
my $class = ref($object);
bless($object, $me->create_class_with_roles($class, @roles));
$object;
}
sub create_class_with_roles {
my ($me, $superclass, @roles) = @_;
die "No roles supplied!" unless @roles;
my $new_name = join(
'__WITH__', $superclass, my $compose_name = join '__AND__', @roles
);
return $new_name if $COMPOSED{class}{$new_name};
foreach my $role (@roles) {
_load_module($role);
die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
}
if ($] >= 5.010) {
{ local $@; require mro; }
} else {
{ local $@; require MRO::Compat; }
}
my @composable = map $me->_composable_package_for($_), reverse @roles;
*{_getglob("${new_name}::ISA")} = [ @composable, $superclass ];
my @info = map +($INFO{$_} ? $INFO{$_} : ()), @roles;
$me->_check_requires(
$new_name, $compose_name,
do { my %h; @h{map @{$_->{requires}||[]}, @info} = (); keys %h }
);
*{_getglob "${new_name}::does"} = \&does_role unless $new_name->can('does');
@{$APPLIED_TO{$new_name}||={}}{
map keys %{$APPLIED_TO{$_}}, @roles
} = ();
$COMPOSED{class}{$new_name} = 1;
return $new_name;
}
sub _composable_package_for {
my ($me, $role) = @_;
my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role;
return $composed_name if $COMPOSED{role}{$composed_name};
$me->_install_methods($composed_name, $role);
my $base_name = $composed_name.'::_BASE';
*{_getglob("${composed_name}::ISA")} = [ $base_name ];
my $modifiers = $INFO{$role}{modifiers}||[];
my @mod_base;
foreach my $modified (
do { my %h; @h{map $_->[1], @$modifiers} = (); keys %h }
) {
push @mod_base, "sub ${modified} { shift->next::method(\@_) }";
}
{
local $@;
eval(my $code = join "\n", "package ${base_name};", @mod_base);
die "Evaling failed: $@\nTrying to eval:\n${code}" if $@;
}
$me->_install_modifiers($composed_name, $modifiers);
$COMPOSED{role}{$composed_name} = 1;
return $composed_name;
}
sub _check_requires {
my ($me, $to, $name, @requires) = @_;
if (my @requires_fail = grep !$to->can($_), @requires) {
# role -> role, add to requires, role -> class, error out
if (my $to_info = $INFO{$to}) {
push @{$to_info->{requires}||=[]}, @requires_fail;
} else {
die "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail);
}
}
}
sub _concrete_methods_of {
my ($me, $role) = @_;
my $info = $INFO{$role};
$info->{methods} ||= do {
# grab role symbol table
my $stash = do { no strict 'refs'; \%{"${role}::"}};
my $not_methods = $info->{not_methods};
+{
# grab all code entries that aren't in the not_methods list
map {
my $code = *{$stash->{$_}}{CODE};
# rely on the '' key we added in import for "no code here"
exists $not_methods->{$code||''} ? () : ($_ => $code)
} grep !_is_scalar_ref($stash->{$_}), keys %$stash
};
};
}
sub methods_provided_by {
my ($me, $role) = @_;
die "${role} is not a Role::Tiny" unless my $info = $INFO{$role};
(keys %{$me->_concrete_methods_of($role)}, @{$info->{requires}||[]});
}
sub _install_methods {
my ($me, $to, $role) = @_;
my $info = $INFO{$role};
my $methods = $me->_concrete_methods_of($role);
# grab target symbol table
my $stash = do { no strict 'refs'; \%{"${to}::"}};
# determine already extant methods of target
my %has_methods;
@has_methods{grep
+(_is_scalar_ref($stash->{$_}) || *{$stash->{$_}}{CODE}),
keys %$stash
} = ();
foreach my $i (grep !exists $has_methods{$_}, keys %$methods) {
no warnings 'once';
*{_getglob "${to}::${i}"} = $methods->{$i};
}
}
sub _install_modifiers {
my ($me, $to, $modifiers) = @_;
if (my $info = $INFO{$to}) {
push @{$info->{modifiers}}, @{$modifiers||[]};
} else {
foreach my $modifier (@{$modifiers||[]}) {
$me->_install_single_modifier($to, @$modifier);
}
}
}
sub _install_single_modifier {
my ($me, @args) = @_;
Class::Method::Modifiers::install_modifier(@args);
}
sub does_role {
my ($proto, $role) = @_;
return exists $APPLIED_TO{ref($proto)||$proto}{$role};
}
1;
=head1 NAME
Role::Tiny - Roles. Like a nouvelle cusine portion size slice of Moose.
=head1 SYNOPSIS
package Some::Role;
use Role::Tiny;
sub foo { ... }
sub bar { ... }
1;
else where
package Some::Class;
use Role::Tiny::With;
# bar gets imported, but not foo
with 'Some::Role';
sub foo { ... }
1;
=head1 DESCRIPTION
C<Role::Tiny> is a minimalist role composition tool.
=head1 ROLE COMPOSITION
Role composition can be thought of as much more clever and meaningful multiple
inheritance. The basics of this implementation of roles is:
=over 2
=item *
If a method is already defined on a class, that method will not be composed in
from the role.
=item *
If a method that the role L</requires> to be implemented is not implemented,
role application will fail loudly.
=back
Unlike L<Class::C3>, where the B<last> class inherited from "wins," role
composition is the other way around, where first wins. In a more complete
system (see L<Moose>) roles are checked to see if they clash. The goal of this
is to be much simpler, hence disallowing composition of multiple roles at once.
=head1 METHODS
=head2 apply_role_to_package
Role::Tiny->apply_role_to_package('Some::Package', 'Some::Role');
Composes role with package. See also L<Role::Tiny::With>.
=head2 apply_roles_to_object
Role::Tiny->apply_roles_to_object($foo, qw(Some::Role1 Some::Role2));
Composes roles in order into object directly. Object is reblessed into the
resulting class.
=head2 create_class_with_roles
Role::Tiny->create_class_with_roles('Some::Base', qw(Some::Role1 Some::Role2));
Creates a new class based on base, with the roles composed into it in order.
New class is returned.
=head1 SUBROUTINES
=head2 does_role
if (Role::Tiny::does_role($foo, 'Some::Role')) {
...
}
Returns true if class has been composed with role.
This subroutine is also installed as ->does on any class a Role::Tiny is
composed into unless that class already has an ->does method, so
if ($foo->does_role('Some::Role')) {
...
}
will work for classes but to test a role, one must use ::does_role directly
=head1 IMPORTED SUBROUTINES
=head2 requires
requires qw(foo bar);
Declares a list of methods that must be defined to compose role.
=head2 with
with 'Some::Role1';
with 'Some::Role2';
Composes another role into the current role. Only one role may be composed in
at a time to allow the code to remain as simple as possible.
=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 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut
ROLE_TINY
$fatpacked{"Role/Tiny/With.pm"} = <<'ROLE_TINY_WITH';
package Role::Tiny::With;
use strict;
use warnings FATAL => 'all';
use Exporter 'import';
our @EXPORT = qw( with );
sub with {
my $target = caller;
Role::Tiny->apply_role_to_package($target, @_)
}
1;
=head1 NAME
Role::Tiny::With - Neat interface for consumers of Role::Tiny roles
=head1 SYNOPSIS
package Some::Class;
use Role::Tiny::With;
with 'Some::Role';
# The role is now mixed in
=head1 DESCRIPTION
C<Role::Tiny> is a minimalist role composition tool. C<Role::Tiny::With>
provides a C<with> function to compose such roles.
=head1 AUTHORS
See L<Moo> for authors.
=head1 COPYRIGHT AND LICENSE
See L<Moo> for the copyright and license.
=cut
ROLE_TINY_WITH
$fatpacked{"Sub/Defer.pm"} = <<'SUB_DEFER';
package Sub::Defer;
use strictures 1;
use base qw(Exporter);
use Moo::_Utils;
our @EXPORT = qw(defer_sub undefer_sub);
our %DEFERRED;
sub undefer_sub {
my ($deferred) = @_;
my ($target, $maker, $undeferred_ref) = @{
$DEFERRED{$deferred}||return $deferred
};
${$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';
*{_getglob($target)} = $made;
}
push @{$DEFERRED{$made} = $DEFERRED{$deferred}}, $made;
return $made;
}
sub defer_info {
my ($deferred) = @_;
$DEFERRED{$deferred||''};
}
sub defer_sub {
my ($target, $maker) = @_;
my $undeferred;
my $deferred_string;
my $deferred = sub {
goto &{$undeferred ||= undefer_sub($deferred_string)};
};
$deferred_string = "$deferred";
$DEFERRED{$deferred} = [ $target, $maker, \$undeferred ];
*{_getglob $target} = $deferred if defined($target);
return $deferred;
}
1;
=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.
=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>.
SUB_DEFER
$fatpacked{"Sub/Quote.pm"} = <<'SUB_QUOTE';
package Sub::Quote;
use strictures 1;
sub _clean_eval { eval $_[0] }
use Sub::Defer;
use B 'perlstring';
use Scalar::Util qw(weaken);
use base qw(Exporter);
our @EXPORT = qw(quote_sub unquote_sub quoted_from_sub);
our %QUOTE_OUTSTANDING;
our %QUOTED;
our %WEAK_REFS;
sub capture_unroll {
my ($from, $captures, $indent) = @_;
join(
'',
map {
/^([\@\%\$])/
or die "capture key should start with \@, \% or \$: $_";
(' ' x $indent).qq{my ${_} = ${1}{${from}->{${\perlstring $_}}};\n};
} keys %$captures
);
}
sub inlinify {
my ($code, $args, $extra, $local) = @_;
my $do = 'do { '.($extra||'');
if (my ($code_args, $body) = $code =~ / +my \(([^)]+)\) = \@_;(.*)$/s) {
if ($code_args eq $args) {
$do.$body.' }'
} else {
$do.'my ('.$code_args.') = ('.$args.'); '.$body.' }';
}
} else {
$do.($local ? 'local ' : '').'@_ = ('.$args.'); '.$code.' }';
}
}
sub _unquote_all_outstanding {
return unless %QUOTE_OUTSTANDING;
my ($assembled_code, @assembled_captures, @localize_these) = '';
# we sort the keys in order to make debugging more predictable
foreach my $outstanding (sort keys %QUOTE_OUTSTANDING) {
my ($name, $code, $captures) = @{$QUOTE_OUTSTANDING{$outstanding}};
push @localize_these, $name if $name;
my $make_sub = "{\n";
if (keys %$captures) {
my $ass_cap_count = @assembled_captures;
$make_sub .= capture_unroll("\$_[1][${ass_cap_count}]", $captures, 2);
push @assembled_captures, $captures;
}
my $o_quoted = perlstring $outstanding;
$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"
: " \$Sub::Quote::QUOTED{${o_quoted}}[3] = sub {\n"
);
$make_sub .= $code;
$make_sub .= " }".($name ? '' : ';')."\n";
if ($name) {
$make_sub .= " \$Sub::Quote::QUOTED{${o_quoted}}[3] = \\&${name}\n";
}
$make_sub .= "}\n";
$assembled_code .= $make_sub;
}
my $debug_code = $assembled_code;
if (@localize_these) {
$debug_code =
"# localizing: ".join(', ', @localize_these)."\n"
.$assembled_code;
$assembled_code = join("\n",
(map { "local *${_};" } @localize_these),
'eval '.perlstring($assembled_code).'; die $@ if $@;'
);
} else {
$ENV{SUB_QUOTE_DEBUG} && warn $assembled_code;
}
$assembled_code .= "\n1;";
{
local $@;
unless (_clean_eval $assembled_code, \@assembled_captures) {
die "Eval went very, very wrong:\n\n${debug_code}\n\n$@";
}
}
$ENV{SUB_QUOTE_DEBUG} && warn $debug_code;
%QUOTE_OUTSTANDING = ();
}
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 = pop if ref($_[-1]) eq 'HASH';
undef($captures) if $captures && !keys %$captures;
my $code = pop;
my $name = $_[0];
my $outstanding;
my $deferred = defer_sub +($options->{no_install} ? undef : $name) => sub {
unquote_sub($outstanding);
};
$outstanding = "$deferred";
$QUOTE_OUTSTANDING{$outstanding} = $QUOTED{$outstanding} = [
$name, $code, $captures
];
weaken($WEAK_REFS{$outstanding} = $deferred);
return $deferred;
}
sub quoted_from_sub {
my ($sub) = @_;
$WEAK_REFS{$sub||''} and $QUOTED{$sub||''};
}
sub unquote_sub {
my ($sub) = @_;
_unquote_all_outstanding;
$QUOTED{$sub}[3];
}
1;
=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; $$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. 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. Note that for performance
reasons all quoted subs declared so far will be globally unquoted/parsed in
a single eval. This means that if you have a syntax error in one of your
quoted subs you may find out when some other sub is unquoted.
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 {
'$x' => 1,
'$y' => 2,
};
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 capture_unroll
my $prelude = capture_unroll {
'$x' => 1,
'$y' => 2,
};
Generates a snippet of code which is suitable to be used as a prelude for
L</inlinify>. The keys are the names of the variables and the values are (duh)
the values. Note that references work as values.
SUB_QUOTE
$fatpacked{"Tak.pm"} = <<'TAK';
package Tak;
use Tak::Loop;
use strictures 1;
our $VERSION = '0.001003'; # 0.1.3
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
=head1 SYNOPSIS
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. You'll get more once I
get my laptop's drive into an enclosure and decant the slides.
=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 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
TAK
$fatpacked{"Tak/Client.pm"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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 "Ssyshere\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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'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"} = <<'TAK_STDIONODE';
package Tak::STDIONode;
our $DATA = do { local $/; <DATA> };
1;
__DATA__
TAK_STDIONODE
$fatpacked{"Tak/STDIOSetup.pm"} = <<'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 "Ssyshere\n";
Tak->loop_until($done);
if (our $Next) { goto &$Next }
}
1;
TAK_STDIOSETUP
$fatpacked{"Tak/Script.pm"} = <<'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"} = <<'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"} = <<'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"} = <<'ALIASED';
package aliased;
$VERSION = '0.30';
require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(alias);
use strict;
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);
no strict 'refs';
*{ join q{::} => $callpack, $alias } = 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;
die $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;
}
sub alias {
my ( $package, @import ) = @_;
my $callpack = scalar caller(0);
_load_alias( $package, $callpack, @import );
return $package;
}
1;
__END__
=head1 NAME
aliased - Use shorter versions of class names.
=head1 VERSION
0.30
=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()
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 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"} = <<'OO';
package oo;
use strictures 1;
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;
OO
$fatpacked{"strictures.pm"} = <<'STRICTURES';
package strictures;
use strict;
use warnings FATAL => 'all';
our $VERSION = '1.002002'; # 1.2.2
sub VERSION {
for ($_[1]) {
last unless defined && !ref && int != 1;
die "Major version specified as $_ - this is strictures version 1";
}
# disable this since Foo->VERSION(undef) correctly returns the version
# and that can happen either if our caller passes undef explicitly or
# because the for above autovivified $_[1] - I could make it stop but
# it's pointless since we don't want to blow up if the caller does
# something valid either.
no warnings 'uninitialized';
shift->SUPER::VERSION(@_);
}
sub import {
strict->import;
warnings->import(FATAL => 'all');
my $extra_tests = do {
if (exists $ENV{PERL_STRICTURES_EXTRA}) {
$ENV{PERL_STRICTURES_EXTRA}
} else {
!!($0 =~ /^x?t\/.*(?:load|compile|coverage|use_ok).*\.t$/
and (-e '.git' or -e '.svn'))
}
};
if ($extra_tests) {
if (eval {
require indirect;
require multidimensional;
require bareword::filehandles;
1
}) {
indirect->unimport(':fatal');
multidimensional->unimport;
bareword::filehandles->unimport;
} else {
die "strictures.pm extra testing active but couldn't load modules.
Extra testing is auto-enabled in checkouts only, so if you're the author
of a strictures using module you need to run:
cpan indirect multidimensional bareword::filehandles
but these modules are not required by your users.
Error loading modules was: $@";
}
}
}
1;
__END__
=head1 NAME
strictures - turn on strict and make all warnings fatal
=head1 SYNOPSIS
use strictures 1;
is equivalent to
use strict;
use warnings FATAL => 'all';
except when called from a file where $0 matches:
/^x?t\/.*(?:load|compile|coverage|use_ok).*\.t$/
and when either '.git' or '.svn' is present in the current directory (with
the intention of only forcing extra tests on the author side) - or when the
PERL_STRICTURES_EXTRA environment variable is set, in which case
use strictures 1;
is equivalent to
use strict;
use warnings FATAL => 'all';
no indirect 'fatal';
no multidimensional;
no bareword::filehandles;
Note that _EXTRA may at some point add even more tests, with only a minor
version increase, but any changes to the effect of 'use strictures' in
normal mode will involve a major version bump.
Be aware: THIS MEANS THE EXTRA TEST MODULES ARE REQUIRED FOR AUTHORS OF
STRICTURES USING CODE - but not by end users thereof.
=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 '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, strictures turns on indirect checking only when it thinks it's
running in a compilation (or pod coverage) test - though if this causes
undesired behaviour this can be overridden by setting the
PERL_STRICTURES_EXTRA environment variable.
If additional useful author side checks come to mind, I'll add them to the
_EXTRA code path only - this will result in a minor version increase (i.e.
1.000000 to 1.001000 (1.1.0) or similar). Any fixes only to the mechanism of
this code will result in a subversion increas (i.e. 1.000000 to 1.000001
(1.0.1)).
If the behaviour of 'use strictures' in normal mode changes in any way, that
will constitute a major version increase - and the code already checks
when its version is tested to ensure that
use strictures 1;
will continue to only introduce the current set of strictures even if 2.0 is
installed.
=head1 METHODS
=head2 import
This method does the setup work described above in L</DESCRIPTION>
=head2 VERSION
This method traps the strictures->VERSION(1) call produced by a use line
with a version number on it and does the version check.
=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
=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) 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
s/^ //mg for values %fatpacked;
unshift @INC, sub {
if (my $fat = $fatpacked{$_[1]}) {
open my $fh, '<', \$fat
or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
return $fh;
}
return
};
} # END OF FATPACK CODE
#!/usr/bin/env perl
use Tak::STDIOSetup;
Tak::STDIOSetup->run;