view release on metacpan or  search on metacpan

lib/Markup/Perl.pm  view on Meta::CPAN

package Markup::Perl; # $Id: Perl.pm,v 1.3 2006/09/04 15:30:15 michael Exp $
our $VERSION = '0.5';
use strict;
use warnings;
use CGI;
use CGI::Carp qw(fatalsToBrowser set_message);

my %headers = (-type=>'text/html', -cookie=>[], -charset=>'UTF-8'); # defaults
my $output = '';
my $print_start = ";\nprint substr(<<'mupl_EOS', 0, -1);\n";
my $print_end   = "\nmupl_EOS\n";
my $in_file = $0;

BEGIN { # catch prints into a variable, and dump at the end
	{	package Buffer;
		sub TIEHANDLE { my ($class, $b) = @_; bless $b => $class;              }
		sub PRINT	  { my $b = shift; $$b .= join '', @_;                     }
		sub PRINTF	  { my $b = shift; my $fm = shift; $$b .= sprintf($fm, @_);}
	} tie *STDOUT=>"Buffer", \$output;
	
	set_message(sub{ # for pretty CGI::Carp output
		my $message = shift;
		$message =~ s!&lt;SCRIPT&gt;!$in_file!g;
		$output = qq{\n\n<p style="font:14px arial;border:2px dotted #966;padding:10px">
		<em>There was an error with "$in_file"</em><br />$message</p>};
	});
}

sub import { # when we are used
	my ($package, undef, $line) = caller();
	$line or die "can't invoke from command-line\n";
	
	open SCRIPT, "<$0" or die qq(can't open calling file "$0": $!);
	for (1..$line) { <SCRIPT> } # go past lines up to the one that uses us
	
	run(do{ local $/;  <SCRIPT> });
	exit;
} 

sub run { # transform and eval mupl text
	$_ = shift or return;
	
	my $code = $print_start;
	s/<perl>(<!\[CDATA\[)?/$print_end/g;
	s/(\]\]>)?<\/perl>/$print_start/g;
	$code .= ${^TAINT}? (/(.+)/s, $1) : $_; # untaint
	$code .= $print_end;
	eval $code; $@ and die "can't run code: $@";
}

sub src { # get and run mupl text in some other file
	my $path = shift or return '';
	my $tmp = $in_file = $path;
	(open SRC, "<$path" and flock(SRC, 1)) or croak qq(can't get src "$path": $!);
	my $src = do{ local $/; <SRC> };
	close SRC;
	run $src;
	$in_file = $tmp;
}

sub param  { my ($v) = @_; return wantarray? @{[CGI::param($v)]} : CGI::param($v) }
sub header { my ($n, $v) = @_; $headers{"-$n"} = $v }
sub cookie {
	(@_ == 1)?
		  return CGI::cookie(shift)
		: push @{$headers{-cookie}}, CGI::cookie(map{$_=>shift} qw(-name -value -expires -path -domain -secure));
}

END {
	{ no warnings 'untie'; untie *STDOUT } # disconnect from the Buffer
	use bytes ();
	binmode(STDOUT);
	print CGI::header(%headers, 'Content-length'=>bytes::length $output), $output;
}

1;