1. Toby Inkster
  2. p5-capture-attribute

Commits

Toby Inkster  committed 6a23c48

initial version

  • Participants
  • Branches default
  • Tags 0.001

Comments (0)

Files changed (13)

File Makefile.PL

View file
+use inc::Module::Package 'RDF:standard';
+

File examples/wrapping.pl

View file
+use 5.010;
+use Capture::Attribute;
+
+sub Some::Module::foo {
+	print "Hello";
+}
+
+sub CAP :Capture { (shift)->(@_) } # generic wrapper
+
+my $orig = \&Some::Module::foo;
+local *Some::Module::foo = sub { CAP($orig, @_) };
+
+say lc(Some::Module::foo());
+

File lib/Capture/Attribute.pm

View file
+package Capture::Attribute;
+
+use 5.010;
+use strict;
+
+BEGIN {
+	$Capture::Attribute::AUTHORITY = 'cpan:TOBYINK';
+	$Capture::Attribute::VERSION   = '0.001';
+}
+
+use Attribute::Handlers;
+use Capture::Attribute::Return;
+use Capture::Tiny qw//;
+use Carp qw//;
+use Sub::Name qw//;
+
+my @importers;
+sub import
+{
+	my ($class, %args) = @_;
+	my $caller =
+		   $args{-into}
+		|| $args{-package}
+		|| caller;
+	
+	no strict 'refs';
+	push @{"$caller\::ISA"}, __PACKAGE__;
+	push @importers, $caller unless $args{-keep};
+}
+
+my ($make_replacement_coderef, $save_coderef, $saved);
+BEGIN
+{
+	$make_replacement_coderef = sub
+	{
+		my ($orig, $data) = @_;
+
+		if ($data eq 'STDOUT')
+		{
+			return sub
+			{
+				my (@args) = @_;
+				my $wa = wantarray;
+				my $stdout = Capture::Tiny::capture {
+					$wa ? $save_coderef->(1, my @r = $orig->(@args)) : 
+					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
+					do { $orig->(@args); $save_coderef->() } ;
+				};
+				return $stdout;
+			}
+		}
+		elsif ($data eq 'STDERR')
+		{
+			return sub
+			{
+				my (@args) = @_;
+				my $wa = wantarray;
+				my (undef, $stderr) = Capture::Tiny::capture {
+					$wa ? $save_coderef->(1, my @r = $orig->(@args)) : 
+					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
+					do { $orig->(@args); $save_coderef->() } ;
+				};
+				return $stderr;
+			}
+		}
+		elsif ($data eq 'MERGED')
+		{
+			return sub
+			{
+				my (@args) = @_;
+				my $wa = wantarray;
+				my $merged = Capture::Tiny::capture_merged {
+					$wa ? $save_coderef->(1, my @r = $orig->(@args)) : 
+					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
+					do { $orig->(@args); $save_coderef->() } ;
+				};
+				return $merged;
+			}
+		}
+		elsif ($data eq 'STDERR,STDOUT')
+		{
+			return sub
+			{
+				my (@args) = @_;
+				my $wa = wantarray;
+				my @r = Capture::Tiny::capture {
+					$wa ? $save_coderef->(1, my @r = $orig->(@args)) : 
+					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
+					do { $orig->(@args); $save_coderef->() } ;
+				};
+				return wantarray ? reverse(@r[0..1]) : $r[0];
+			}
+		}
+		elsif ($data eq 'STDOUT,STDERR')
+		{
+			return sub
+			{
+				my (@args) = @_;
+				my $wa = wantarray;
+				return Capture::Tiny::capture {
+					$wa ? $save_coderef->(1, my @r = $orig->(@args)) : 
+					defined $wa ? $save_coderef->(0, my $r = $orig->(@args)) :
+					do { $orig->(@args); $save_coderef->() } ;
+				};
+			}
+		}
+
+		return;
+	};
+	
+	$save_coderef = sub
+	{
+		if (not scalar @_)
+		{
+			$saved = Capture::Attribute::Return->new(wasarray => undef);
+			return;
+		}
+		
+		my $context = shift;
+		$saved = Capture::Attribute::Return->new(
+			wasarray => $context,
+			value    => ($context ? \@_ : $_[0]),
+			);
+	}
+}
+
+INIT # runs AFTER attributes have been handled.
+{
+	no strict 'refs';
+	foreach my $caller (@importers)
+	{
+		@{"$caller\::ISA"} = grep { $_ ne __PACKAGE__ } @{"$caller\::ISA"};
+	}
+	no warnings 'once';
+	*return = sub { $saved };
+}
+
+sub Capture :ATTR(CODE,RAWDATA)
+{
+	my (
+		$package,
+		$symbol,
+		$referent,
+		$attr,
+		$data,
+		$phase,
+		$filename,
+		$linenum,
+		) = @_;
+
+	$data = uc($data) || (my $default_data = 'STDOUT');
+
+	my $orig = *{$symbol}{CODE};
+	my $replacement = $make_replacement_coderef->($orig, $data)
+		or Carp::croak "Unrecognised option string: $data";
+
+	{
+		no strict 'refs';
+		no warnings 'redefine';
+		my $subname = sprintf '%s::%s', *{$symbol}{PACKAGE}, *{$symbol}{NAME};
+		*{$subname} = Sub::Name::subname($subname, $replacement);
+	}
+}
+
+__PACKAGE__
+__END__
+
+=head1 NAME
+
+Capture::Attribute - s/return/print/g
+
+=head1 SYNOPSIS
+
+ use Capture::Attribute;
+ 
+ sub foobar :Capture {
+   print "Hello World\n";
+ }
+ 
+ my $result = foobar();
+ $result =~ s/World/Planet/;
+ print "$result";   # says "Hello Planet"
+
+=head1 DESCRIPTION
+
+Sometimes you write a function that needs to build a long string via a
+convoluted series of conditional statements, loops and so on. I tend to
+end up defining a variable C<< $return >> at the top of the code,
+concatenating bits to it as required, and then return it at the end. For
+example:
+
+ sub count_to_10 {
+   my $return = "Listen to me count!\n";
+   foreach (1..10) {
+     $return .= "$_\n";
+     $return .= "Half-way there!\n" if $_==5;
+   }
+   $return .= "All done!\n";
+   return $return;
+ }
+ 
+ Mail::Message->new(
+   To      => 'teacher@example.com',
+   From    => 'student@example.com',
+   Subject => 'I can count!',
+   data    => count_to_ten(),
+   )->send;
+
+Capture::Attribute simplifies this pattern by capturing all output to
+STDOUT, so you can use STDOUT as a place to capture each part of the
+string.
+
+ sub count_to_10 :Capture {
+   say "Listen to me count!";
+   foreach (1..10) {
+     say $_;
+     say "Half-way there!" if $_==5;
+   }
+   say "All done!";
+ }
+ 
+ Mail::Message->new(
+   To      => 'teacher@example.com',
+   From    => 'student@example.com',
+   Subject => 'I can count!',
+   data    => count_to_ten(),
+   )->send;
+
+Doesn't that look nicer?
+
+Within a sub marked with the ":Capture" attribute, all data that would be
+printed is captured instead. When the sub is finished, the return value is
+ignored and the captured text is returned instead.
+
+The C<return> keyword still works just fine for its control flow purpose
+inside a captured sub. The return value just doesn't get returned.
+
+=head2 How does it work?
+
+When you C<< use Capture::Attributes >>, then at BEGIN time (see 
+L<perlmod>) your package will be automatically made into an subclass
+of Capture::Attributes.
+
+At CHECK time (again L<perlmod>), Capture::Attributes will then use
+L<Attribute::Handlers> to wrap each sub marked with the ":Capture"
+attribute with a sub that captures its output via L<Capture::Tiny>,
+and returns the output.
+
+At INIT time (again L<perlmod>), Capture::Attributes then removes
+itself from your package's C<< @ISA >>, thus your package is no longer
+a subclass of Capture::Attributes. (It would be nice if the
+subclassing could be avoided altogether, but alas this seems to be
+the way Attribute::Handlers works.)
+
+=head2 The ":Capture" Attribute
+
+There are actually various options you can use on the ":Capture"
+attribute. They are mostly useless.
+
+=head3 C<< :Capture(STDOUT) >>
+
+This is the default. Captures STDOUT.
+
+=head3 C<< :Capture(STDERR) >>
+
+Captures STDERR instead of STDOUT.
+
+=head3 C<< :Capture(MERGED) >>
+
+Captures both STDOUT and STDERR, merged into one. Because of
+buffering, lines from different handles may interleave differently
+than expected.
+
+=head3 C<< :Capture(STDOUT,STDERR) >>
+
+Capture both STDOUT and STDERR. In scalar context, returns STDOUT.
+In List context returns both.
+
+ sub foo :Capture(STDOUT,STDERR) {
+   print "World\n";
+   warn "Hello\n";
+ }
+ my ($hello, $world) = map { chomp;$_ } foo();
+
+=head3 C<< :Capture(STDERR,STDOUT) >>
+
+Capture both STDOUT and STDERR. In scalar context, returns STDERR.
+In List context returns both.
+
+=head1 CAVEATS
+
+=head2 Subclassing
+
+As mentioned above, Capture::Attributes B<temporarily> installs itself
+as a superclass of your class. If your class has subs named any of
+the following, they may override the Capture::Attributes versions,
+and bad stuff may happen.
+
+=over
+
+=item * C<ATTR>
+
+=item * C<Capture>
+
+=item * C<MODIFY_CODE_ATTRIBUTES>
+
+=item * any sub matching the expresssion C<< /^_ATTR_CODE_/ >>
+
+=back
+
+=head2 Accessing the real return value
+
+ sub quux :Capture
+ {
+   print "foo";
+   return "bar";
+ }
+ 
+ say quux();                              # says "foo"
+ say Capture::Attributes->return->value;  # says "bar"
+
+The C<< Capture::Attributes->return >> class method gives you the
+B<real> return value from the most recently captured sub. This is
+a L<Capture::Attribute::Return> object.
+
+However, this section is listed under CAVEATS for a good reason. The
+fact that a sub happens to use the ":Capture" attribute should be
+considered private to it. The caller shouldn't consider there to be
+any difference between:
+
+ sub foo :Capture { print "foo" }
+
+and
+
+ sub foo { return "foo" }
+
+If the caller of the captured sub goes on to inspect
+C<< Capture::Attributes->return >>, then this assumes an implementation
+detail of the captured sub, which breaks encapsulation.
+
+=head2 Adding a ":Capture" attribute to somebody else's function
+
+So you want to do something like:
+
+ add_attribute(\&Some::Module::function, ':Capture(STDOUT)');
+
+Here's how:
+
+ # Declare a generic wrapper
+ sub CAP :Capture { (shift)->(@_) }
+ 
+ # Wrap Some::Module::function in our wrapper.
+ my $orig = \&Some::Module::function;
+ local *Some::Module::function = sub { CAP($orig, @_) };
+
+Though you are probably better off investigating L<Capture::Tiny>.
+
+=head2 Call stack
+
+Capture::Attribute adds two extra frames to the call stack, and
+L<Capture::Tiny> adds (it seems) two more again. So any code that
+you capture will see them quite clearly in the call stack if they
+decide to look. They'll show up in stack traces, etc.
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=Capture-Attribute>.
+
+=head1 SEE ALSO
+
+L<Capture::Tiny>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

File lib/Capture/Attribute/Return.pm

View file
+package Capture::Attribute::Return;
+
+use 5.010;
+use strict;
+
+BEGIN {
+	$Capture::Attribute::Return::AUTHORITY = 'cpan:TOBYINK';
+	$Capture::Attribute::Return::VERSION   = '0.001';
+}
+
+use Any::Moose;
+
+use overload
+	'@{}' => '_ARRAY',
+	'""'  => '_SCALAR',
+	'${}' => '_SCALAR';
+
+has wasarray => (
+	is        => 'ro',
+	isa       => 'Num|Undef',
+	required  => 1,
+	);
+
+has value => (
+	is        => 'ro',
+	required  => 0,
+	predicate => 'has_value',
+	);
+
+sub _ARRAY
+{
+	my ($self) = @_;
+	return [] if $self->is_void;
+	return $self->wasarray ? $self->value : [ $self->value ];
+}
+
+sub _SCALAR
+{
+	my ($self) = @_;
+	return undef if $self->is_void;
+	$self->wasarray ? do { my @a = @{$self->value}; scalar(@a) } : $self->value;
+}
+
+sub is_list
+{
+	my ($self) = @_;
+	return 1 if $self->wasarray;
+	return;
+}
+
+sub is_scalar
+{
+	my ($self) = @_;
+	my $wasarray = $self->wasarray;
+	return if $wasarray;
+	return 1 if defined $wasarray;
+	return;
+}
+
+sub is_void
+{
+	my ($self) = @_;
+	return if defined $self->wasarray;
+	return 1;
+}
+
+__PACKAGE__
+__END__
+
+=head1 NAME
+
+Capture::Attribute::Return - the result of a "return" statement
+
+=head1 DESCRIPTION
+
+This is an L<Any::Moose> class. Hopefully you'll never need to use it.
+
+=head2 Constructor
+
+=over
+
+=item C<< new(%attributes) >>
+
+=back
+
+=head2 Attributes
+
+=over
+
+=item C<< wasarray >>
+
+Indicates whether the returned value was the result of a function call in
+"wantarray" mode or not. Either true, false or undef. See C<wantarray>
+in L<perlfunc>.
+
+=item C<< value >>
+
+The return value, or if C<wasarray> is true, then a reference to an array
+containing the list of returned values.
+
+=back
+
+
+=head2 Methods
+
+=over
+
+=item C<is_list>, C<is_scalar>, C<is_void>
+
+Slightly nicer than fiddling with checking the definedness and truthiness
+of C<wasarray>.
+
+=back
+
+=head2 Overloads
+
+This class overloads array and scalar dereferencing.
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=Capture-Attribute>.
+
+=head1 SEE ALSO
+
+L<Capture::Attribute>.
+
+=head1 AUTHOR
+
+Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
+
+=head1 COPYRIGHT AND LICENCE
+
+This software is copyright (c) 2012 by Toby Inkster.
+
+This is free software; you can redistribute it and/or modify it under
+the same terms as the Perl 5 programming language system itself.
+
+=head1 DISCLAIMER OF WARRANTIES
+
+THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
+

File meta/changes.ttl

View file
+# This file acts as the project's changelog.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dcs:     <http://ontologi.es/doap-changeset#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix dist:    <http://purl.org/NET/cpan-uri/dist/Capture-Attribute/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+dist:project :release dist:v_0-001 .
+dist:v_0-001
+	a               :Version ;
+	dc:issued       "2012-02-21"^^xsd:date ;
+	:revision       "0.001"^^xsd:string ;
+	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/Capture-Attribute-0.001.tar.gz> ;
+	rdfs:label      "Initial release" .
+

File meta/doap.ttl

View file
+# This file contains general metadata about the project.
+
+@prefix :        <http://usefulinc.com/ns/doap#> .
+@prefix dc:      <http://purl.org/dc/terms/> .
+@prefix foaf:    <http://xmlns.com/foaf/0.1/> .
+@prefix rdfs:    <http://www.w3.org/2000/01/rdf-schema#> .
+@prefix xsd:     <http://www.w3.org/2001/XMLSchema#> .
+
+<http://purl.org/NET/cpan-uri/dist/Capture-Attribute/project>
+	a               :Project ;
+	:programming-language "Perl" ;
+	:name           "Capture-Attribute" ;
+	:shortdesc      "s/return/print/g" ;
+	:homepage       <https://metacpan.org/release/Capture-Attribute> ;
+	:download-page  <https://metacpan.org/release/Capture-Attribute> ;
+	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=Capture-Attribute> ;
+	:created        "2012-02-21"^^xsd:date ;
+	:license        <http://dev.perl.org/licenses/> ;
+	:developer      [ a foaf:Person ; foaf:name "Toby Inkster" ; foaf:mbox <mailto:tobyink@cpan.org> ] .
+
+<http://dev.perl.org/licenses/>
+	dc:title        "the same terms as the perl 5 programming language system itself" .
+

File meta/makefile.ttl

View file
+# This file provides instructions for packaging.
+
+@prefix : <http://purl.org/NET/cpan-uri/terms#> .
+
+<http://purl.org/NET/cpan-uri/dist/Capture-Attribute/project>
+	:perl_version_from _:main ;
+	:version_from _:main ;
+	:readme_from _:main ;
+	:test_requires "Test::More 0.61" ;
+	:requires "Any::Moose", "Attribute::Handlers", "Capture::Tiny", "Sub::Name" .
+
+_:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/Capture/Attribute.pm" .
+

File t/01basic.t

View file
+use Test::More tests => 1;
+BEGIN { use_ok('Capture::Attribute') };
+

File t/02capturing.t

View file
+use Capture::Attribute;
+use Test::More tests => 10;
+
+sub foo :Capture(STDOUT,STDERR)
+{
+	warn qq/Compo\n/;
+	print q/Radish, lettuce - a couple of weeds/;
+	return wantarray ? qw/Mr Bloom/ : q/Mr Bloom/;
+}
+
+my ($o, $e) = foo();
+is $o, q/Radish, lettuce - a couple of weeds/;
+is $e, "Compo\n";
+
+ok(!main->isa('Capture::Attribute'));
+ok(!main->can('return'));
+can_ok 'Capture::Attribute' => 'return';
+
+ok(Capture::Attribute->return->is_list);
+is_deeply(Capture::Attribute->return->value, [qw/Mr Bloom/]);
+
+my $o2 = foo();
+is $o2, q/Radish, lettuce - a couple of weeds/;
+
+ok(Capture::Attribute->return->is_scalar);
+is(Capture::Attribute->return->value, q/Mr Bloom/);
+

File xt/01pod.t

View file
+use Test::More;
+eval "use Test::Pod 1.00";
+plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
+all_pod_files_ok();
+

File xt/02pod_coverage.t

View file
+use Test::More;
+use Test::Pod::Coverage;
+
+my @modules = qw(Capture::Attribute::Return);
+pod_coverage_ok($_, "$_ is covered")
+	foreach @modules;
+done_testing(scalar @modules);
+

File xt/03meta_uptodate.t

View file
+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok('Capture-Attribute', 'Capture::Attribute');
+

File xt/04eol.t

View file
+use Test::EOL;
+all_perl_files_ok();