File Coverage

blib/lib/Acme/Pony/Pink.pm

Criterion	Covered	Total	%
statement	32	69	46.3
branch	0	16	0.0
condition	0	4	0.0
subroutine	11	17	64.7
pod	2	2	100.0
total	45	108	41.6

package Acme::Pony::Pink;

use 5.010;
use autodie;
use strict;
no warnings;
use utf8;

BEGIN {
	$Acme::Pony::Pink::AUTHORITY = 'cpan:TOBYINK';
	$Acme::Pony::Pink::VERSION   = '0.003';
}

use Carp qw;
use MIME::Base64 qw;
use List::MoreUtils qw;

use Config;
use constant _path_to_perl => $Config{perlpath};

sub new
{
	shift;
}

sub _image
{
	state $image = do {
		local $/ = ;
		decode_base64($/);
	};
	return $image;
}

sub _find_shebang
{
	my ($class, $lines) = @_;

	my $idx = firstidx { /^\#\!.*\bperl\b/ } @$lines;
	return if $idx < 0; # no shebang

	# look for code before shebang... that's not a real shebang
	for (0 .. $idx)
	{
		next if $lines->[$_] =~ m{^\s*#};
		next if $lines->[$_] =~ m{^\s*$};
		return;
	}

	return $lines->[$idx];
}

sub _filehandle
{
	my ($class, $args, $mode) = @_;
	return unless @$args;
	$mode //= '<';

	my $arg = shift @$args;
	my $fh;

	if (ref $arg eq 'SCALAR')
		{ open $fh, $mode, \$arg }
	elsif (!ref $arg)
		{ open $fh, $mode, $arg }
	else
		{ $fh = $arg }

	return $fh;
}

sub ponify
{
	my $class = shift;
	local $/ = "\n";

	my $fh_in  = $class->_filehandle(\@_, '<') or croak "must supply input handle";
	my $fh_out = $class->_filehandle(\@_, '>') || \*STDOUT;

	my @lines = <$fh_in>;
	unshift @lines, sprintf("#!%s\n", $class->_path_to_perl)
		unless $class->_find_shebang(\@lines);

	print {$fh_out} $class->_image;
	print {$fh_out} qq(\n\n);
	print {$fh_out} @lines;
	return;
}

=head1 NAME

Acme::Pony::Pink - make your script look like a pink pony

=head1 SYNOPSIS

 my $converter = Acme::Pony::Pink->new;
 $converter->ponify('myscript.pl' => 'myscript.gif');

myscript.gif is now a small picture of a pink pony, and you can run the
original script using:

 perl -x myscript.gif

=head1 DESCRIPTION

This module turns a Perl script into a picture of a pink pony.

The picture is executable via C<< perl -x >>.

=head2 Unconstrutive Constructor

=over

=item C<< new >>

Returns the invocant.

=back

=head2 Method

=over

=item C<< ponify($input, $output) >>

The input is a Perl script; the output is a GIF file. (No, the "F" in "GIF"
does not stand for "file".)

Input and output may be filehandles, file names, or scalar references if you
just want to play with strings. The input source is required; the default
output destination is STDOUT.

=back

=head1 BUGS

Please report any bugs to someone who cares.

=head1 SEE ALSO

L,
L.

=head1 AUTHOR

Toby Inkster [e-mail].

=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.

=cut

__PACKAGE__
__DATA__