Commits

Toby Inkster committed 88f23e9

initial release

Comments (0)

Files changed (13)

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

examples/syntax.pl

+#!/usr/bin/perl
+
+use 5.010;
+use strict;
+use syntax qw(function perform);
+
+fun announce ($str)
+{
+	chomp $str;
+	say ">>> $str";
+}
+
+perform { announce ($_) } wherever 1;
+perform { announce ($_) } wherever undef;
+perform { announce ($_) } wherever 2;
+perform { announce ($_) } wherever 3;

lib/PerlX/Perform.pm

+package PerlX::Perform;
+
+use 5.010;
+use common::sense;
+use utf8;
+
+use Scalar::Util qw/blessed/;
+
+our @EXPORT;
+BEGIN {
+	$PerlX::Perform::AUTHORITY = 'cpan:TOBYINK';
+	$PerlX::Perform::VERSION   = '0.001';
+	
+	@EXPORT = qw/perform wherever/;
+}
+
+use parent qw/Exporter/;
+
+sub perform (&;$)
+{
+	my ($coderef, $thing) = @_;
+	if (defined $thing)
+	{
+		$_ = $thing;
+		@_ = ();
+		goto $coderef;
+	}
+	if (@_ == 1)
+	{
+		return PerlX::Perform::Manifesto->new($coderef);
+	}
+	return;
+}
+
+sub wherever ($;@)
+{
+	my $thing = shift;
+	if (@_ and !ref $_[0] and $_[0] eq 'perform')
+	{
+		shift;
+	}
+	if (@_ and blessed $_[0] and $_[0]->isa('PerlX::Perform::Manifesto'))
+	{
+		my $manifesto = shift;
+		@_ = ($thing);
+		goto $manifesto;
+	}
+	elsif (@_ and ref $_[0] eq 'CODE')
+	{
+		my $manifesto = &perform(shift);
+		@_ = ($thing);
+		goto $manifesto;
+	}
+	return $thing;
+}
+
+package PerlX::Perform::Manifesto;
+
+use 5.010;
+use common::sense;
+use utf8;
+
+use Scalar::Util qw/blessed/;
+
+sub new
+{
+	my ($class, $code) = @_;
+	
+	if (blessed $code and $code->isa(__PACKAGE__))
+	{
+		return $code;
+	}
+	
+	bless sub {
+			my $thing = shift;
+			return unless defined $thing;
+			$_ = $thing;
+			@_ = ();
+			goto $code;
+		}, $class;
+}
+
+__FILE__
+__END__
+
+=head1 NAME
+
+PerlX::Perform - syntactic sugar for if (defined ...) { ... }
+
+=head1 SYNOPSIS
+
+ my $foo = function_that_might_return_undef();
+ perform { say $_ } wherever $foo;
+ 
+ my $bar = function_that_might_return_undef();
+ wherever $bar, perform { say $_ };
+
+=head1 DESCRIPTION
+
+Executes some code if a given scalar is defined. Within the code block,
+the scalar is available as C<< $_ >>.
+
+Note that there is no comma before C<wherever> here:
+
+ my $foo = function_that_might_return_undef();
+ perform { say $_ } wherever $foo;
+
+But there is one before C<perform> here:
+
+ my $bar = function_that_might_return_undef();
+ wherever $bar, perform { say $_ };
+
+=head2 Gory Details
+
+The implementation is pure Perl. The closest it gets to trickery is
+that the two functions defined by this package use prototypes.
+
+=head3 perform
+
+C<perform> is a function can be called in two ways:
+
+=over 
+
+=item * with a single coderef argument
+
+In this case, C<perform> returns a blessed version of that coderef; a
+so-called Manifesto object.
+
+=item * with a coderef argument followed by a scalar
+
+Generates the Manifesto object, and executes the Manifesto on the
+scalar, returning the result.
+
+Or rather, it has the effective result of doing the above. But it inlines
+the logic from PerlX::Perform::Manifesto.
+
+=back
+
+=head3 wherever
+
+C<wherever> is a function can be called in three ways:
+
+=over 
+
+=item * with a single scalar argument
+
+In this case, C<wherever> passes through the argument unchanged.
+
+=item * with a scalar argument and a Manifesto
+
+In this case, C<wherever> executes the Manifesto with the scalar argument.
+
+=item * with a scalar argument and a coderef
+
+In this case, C<wherever> turns the coderef into a Manifesto and
+executes it with the scalar argument.
+
+=back
+
+This means that it's possible to do this:
+
+ my $manifesto = perform { say $_ };
+ wherever $foo, $manifesto;
+ wherever $bar, $manifesto;
+
+And indeed C<wherever> does allow a little additional syntactic sugar
+by skipping over the string "perform" if it is used as the second
+parameter. Thus you can write:
+
+ my $manifesto = perform { say $_ };
+ wherever $foo, perform => $manifesto;
+ wherever $bar, perform => $manifesto;
+
+But because PerlX::Perform::Manifesto passes through any
+already-blessed coderefs, this will work too:
+
+ my $manifesto = perform { say $_ };
+ wherever $foo, &perform($manifesto);
+ wherever $bar, &perform($manifesto);
+
+=head2 Tail Calls
+
+Both C<perform> and C<wherever> make extensive use of C<goto> in order to
+conceal their usage on the call stack.
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Perform>.
+
+=head1 SEE ALSO
+
+I can't see any similar modules on CPAN to link to here.
+
+That probably means that this one was a bad idea too.
+
+=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.
+

lib/Syntax/Feature/Perform.pm

+package Syntax::Feature::Perform;
+
+use 5.010;
+use common::sense;
+use utf8;
+
+use PerlX::Perform qw//;
+
+sub install
+{
+	my ($class, %args) = @_;
+	my $into = delete $args{into};
+	
+	foreach my $f (qw/perform wherever/)
+	{
+		no strict 'refs';
+		*{"$into\::$f"} = \&{"PerlX::Perform::$f"};
+	}
+}
+
+__FILE__
+__END__
+
+=head1 NAME
+
+Syntax::Feature::Perform - use syntax qw/perform/
+
+=head1 DESCRIPTION
+
+Tiny shim between L<PerlX::Perform> and L<syntax>.
+
+=head1 BUGS
+
+Please report any bugs to
+L<http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Perform>.
+
+=head1 SEE ALSO
+
+L<PerlX::Perform>, L<syntax>.
+
+=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.
+
+# 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/PerlX-Perform/> .
+@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-06"^^xsd:date ;
+	:revision       "0.001"^^xsd:string ;
+	:file-release   <http://backpan.cpan.org/authors/id/T/TO/TOBYINK/PerlX-Perform-0.001.tar.gz> ;
+	rdfs:label      "Initial release" .
+
+# 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/PerlX-Perform/project>
+	a               :Project ;
+	:programming-language "Perl" ;
+	:name           "PerlX-Perform" ;
+	:shortdesc      "syntactic sugar for if (defined ...) { ... }" ;
+	:homepage       <https://metacpan.org/release/PerlX-Perform> ;
+	:download-page  <https://metacpan.org/release/PerlX-Perform> ;
+	:bug-database   <http://rt.cpan.org/Dist/Display.html?Queue=PerlX-Perform> ;
+	:repository     [ a :HgRepository ; :browse <https://bitbucket.org/tobyink/p5-perlx-perform> ] ;
+	:created        "2012-02-06"^^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" .
+

meta/makefile.ttl

+# This file provides instructions for packaging.
+
+@prefix : <http://purl.org/NET/cpan-uri/terms#> .
+
+<http://purl.org/NET/cpan-uri/dist/PerlX-Perform/project>
+	:perl_version_from
+		_:main;
+	:version_from
+		_:main;
+	:readme_from
+		_:main;
+	:test_requires
+		"Test::More 0.61";
+	:requires
+		"common::sense",
+		"Exporter",
+		"parent",
+		"Scalar::Util",
+		"utf8".
+
+_:main <http://www.semanticdesktop.org/ontologies/2007/03/22/nfo#fileName> "lib/PerlX/Perform.pm" .
+
+use Test::More tests => 1;
+BEGIN { use_ok('PerlX::Perform') };
+
+use Test::More tests => 15;
+use PerlX::Perform;
+
+my %p;
+
+isa_ok
+	perform { 1 },
+	'PerlX::Perform::Manifesto';
+
+perform { $p{should_pass}++ } wherever 1;
+ok $p{should_pass}, 'Things should be executed if scalar is defined';
+
+perform { $p{zero}++ } wherever 0;
+ok $p{zero}, 'Zero is still defined';
+
+perform { $p{should_fail}++ } wherever undef;
+ok !$p{should_fail}, 'Things should not be executed if scalar is undefined';
+
+wherever 1, perform { $p{should_pass_2}++ };
+ok $p{should_pass_2}, 'Things should be executed if scalar is defined (wherever first)';
+
+wherever undef, perform { $p{should_fail_2}++ };
+ok !$p{should_fail_2}, 'Things should not be executed if scalar is undefined (wherever first)';
+
+wherever 1, sub { $p{should_pass_3}++ };
+ok $p{should_pass_3}, 'Things should be executed if scalar is defined (wherever first, plain coderef)';
+
+wherever undef, sub { $p{should_fail_3}++ };
+ok !$p{should_fail_3}, 'Things should not be executed if scalar is undefined (wherever first, plain coderef)';
+
+wherever 1, perform => perform { $p{should_pass_4}++ };
+ok $p{should_pass_4}, 'Things should be executed if scalar is defined (wherever first, skip then plain coderef)';
+
+wherever undef, perform => perform { $p{should_fail_4}++ };
+ok !$p{should_fail_4}, 'Things should not be executed if scalar is undefined (wherever first, skip then plain coderef)';
+
+perform { is $_, 123 } wherever 123;
+
+perform { is ref($_), 'HASH' } wherever {};
+
+perform { is(((caller(0))[0]), 'main') } wherever 2;
+
+wherever 2, perform { is(((caller(0))[0]), 'main') };
+
+perform { $p{no_wherever}++ } 1;
+ok $p{no_wherever}, 'Wherever is actually optional';
+
+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();
+

xt/02pod_coverage.t

+use Test::More;
+use Test::Pod::Coverage;
+
+my @modules = qw(PerlX::Perform);
+pod_coverage_ok($_, "$_ is covered")
+	foreach @modules;
+done_testing(scalar @modules);
+

xt/03meta_uptodate.t

+use Test::More tests => 1;
+use Test::RDF::DOAP::Version;
+doap_version_ok('PerlX-Perform', 'PerlX::Perform');
+
+use Test::EOL;
+all_perl_files_ok();