package Dancer::Plugin::FakeCGI;
use strict;
use warnings;
use Dancer::Plugin;
use Dancer::Config;
use Dancer ':syntax';
use Cwd;
use Carp;
use Test::TinyMocker;
use IO::Capture::Stdout;
use CGI::Compile;
=encoding utf8
=head1 NAME
Dancer::Plugin::FakeCGI - run CGI methods or Perl-files under Dancer
=head1 SYNOPSIS
=head1 DESCRIPTION
Supports to run CGI perl files on CGI methods under Dancer.
=head1 CONFIGURATION
plugins:
FakeCGI:
cgi-dir: 'cgi-bin'
cgi-package: 'lib/CGI'
=over
=item C<cgi-dir> - for setting directory where is placed Perl CGI file, standart is 'cgi-bin'
=item C<cgi-package> - for setting INC library where is CGI packages, standart is nothing.
=back
=head1 TODO
Emulation of this CGI methods: header(), cookie()
=head1 METHODS
=cut
our $VERSION = '0.22';
# Own handles
my $capture = undef;
my $settings = undef;
my %handle_require = ();
my %handle_file = ();
my %handle_mock = ();
# Must first initialize faked Apache.pm and after that CGI
BEGIN {
my %old_ENV = %ENV;
$ENV{MOD_PERL} = 1;
$ENV{MOD_PERL_API_VERSION} = 1;
my ($pack, $filename) = caller;
my $dir = $filename;
$dir =~ s/\.pm//;
unshift(@INC, $dir);
# Import fake Apache
require Apache;
Apache->import;
# Setting callbacks
Apache::_set_callback_func('read', \&_apache_read);
Apache::_set_callback_func('args', \&_apache_args);
# Import CGI
require CGI;
CGI->import('header');
%ENV = %old_ENV;
shift(@INC);
}
# Loading setting
sub _load_settings {
my $first = !defined($settings) ? 1 : 0;
$settings = plugin_setting() || {};
unshift(@INC, path(setting('confdir'), $settings->{'cgi-package'})) if ($first && $settings->{'cgi-package'});
}
# Faked method for Apache->read is a built-in function, and so can do magic.
# You can accomplish something similar with your own functions, though, by declaring a function prototype:
sub _apache_read {
my $buf = \$_[0];
shift;
my ($len, $offset) = @_;
no strict 'refs';
$$buf = substr(request->body(), $offset, $len);
return length($$buf);
}
# Faked method for Apache->args
sub _apache_args {
return "";
my %all_params = params();
my @a = ();
while (my ($k, $d) = each %all_params) {
push(@a, $k . "=" . ($d || ""));
}
return join("&", @a);
}
#
my $dancer_version = (exists &dancer_version) ? int(dancer_version()) : 1;
my ($logger);
if ($dancer_version == 1) {
require Dancer::Config;
Dancer::Config->import();
# $logger = sub { Dancer::Logger->can($_[0])->($_[1]) };
} else {
# $logger = sub { log @_ };
}
# Method for loading module
sub _load_package {
my $package = shift;
my $pack = caller;
unless (exists($handle_require{$package})) {
my ($eval_result, $eval_error) = _eval("package $pack;require $package @_;1;");
croak("Problem with require $package: $eval_error") unless ($eval_result);
$handle_require{$package} = 1;
return $eval_result;
}
return 1;
}
# Method for compile files
sub _compile_file {
my $file = shift;
my $timer = undef;
if (setting('use_timer')) {
$timer = Dancer::Timer->new();
}
my $sub = undef;
unless (exists($handle_require{$file})) {
# Change to current dir where is cgi-bin
my $currWorkDir = &Cwd::cwd();
#my $dir = dirname($file);
my $dir = path(setting('confdir'), ($settings->{'cgi-bin'} || 'cgi-bin'));
chdir($dir);
$sub = CGI::Compile->compile($file);
chdir($currWorkDir);
$handle_require{$file} = $sub;
} else {
$sub = $handle_require{$file};
}
debug("Loading $file in " . $timer->to_string . " seconds") if ($timer);
return $sub;
}
# Eval function
sub _eval {
my ($code, @args) = @_;
# Work around oddities surrounding resetting of $@ by immediately
# storing it.
my ($sigdie, $eval_result, $eval_error);
{
local ($@, $!, $SIG{__DIE__}); # isolate eval
$eval_result = eval $code; ## no critic (BuiltinFunctions::ProhibitStringyEval)
$eval_error = $@;
$sigdie = $SIG{__DIE__} || undef;
}
# make sure that $code got a chance to set $SIG{__DIE__}
$SIG{__DIE__} = $sigdie if defined $sigdie;
return ($eval_result, $eval_error);
}
# Retype header function
sub _cgi_header {
# Must be returned one space character !!!
return " ";
# old CGI
my @p = @_;
shift(@p) if (@p && ref($p[0]));
my (@header);
#return "" if $self->{'.header_printed'}++ and $HEADERS_ONCE;
my ($type, $status, $cookie, $target, $expires, $nph, $charset, $attachment, $p3p, @other) = rearrange([
['TYPE', 'CONTENT_TYPE', 'CONTENT-TYPE'],
'STATUS', ['COOKIE', 'COOKIES'],
'TARGET', 'EXPIRES', 'NPH', 'CHARSET', 'ATTACHMENT', 'P3P'
],
@p
);
#$nph ||= $NPH;
#$type ||= 'text/html' unless defined($type);
content_type $type if defined $type;
# sets if $charset is given, gets if not
#$charset = $self->charset( $charset );
charset($charset) if defined $charset;
# rearrange() was designed for the HTML portion, so we
# need to fix it up a little.
for (@other) {
# Don't use \s because of perl bug 21951
next unless my ($header, $value) = /([^ \r\n\t=]+)=\"?(.+?)\"?$/s;
#($_ = $header) =~ s/^(\w)(.*)/"\u$1\L$2" . ': '.$self->unescapeHTML($value)/e;
}
$type .= "; charset=$charset"
if $type ne ''
and $type !~ /\bcharset\b/
and defined $charset
and $charset ne '';
# Maybe future compatibility. Maybe not.
my $protocol = $ENV{SERVER_PROTOCOL} || 'HTTP/1.0';
push(@header, $protocol . ' ' . ($status || '200 OK')) if $nph;
#push(@header,"Server: " . &server_software()) if $nph;
#push(@header, "Status: $status") if $status;
status($status) if ($status);
push(@header, "Window-Target: $target") if $target;
if ($p3p) {
$p3p = join ' ', @$p3p if ref($p3p) eq 'ARRAY';
push(@header, qq(P3P: policyref="/w3c/p3p.xml", CP="$p3p"));
}
# push all the cookies -- there may be several
if ($cookie) {
# my (@cookie) = ref($cookie) && ref($cookie) eq 'ARRAY' ? @{$cookie} : $cookie;
# for (@cookie) {
# #my $cs = UNIVERSAL::isa($_, 'CGI::Cookie') ? $_->as_string : $_;
# push(@header, "Set-Cookie: $cs") if $cs ne '';
# }
}
# if the user indicates an expiration time, then we need
# both an Expires and a Date header (so that the browser is
# uses OUR clock)
push(@header, "Expires: " . expires($expires, 'http'))
if $expires;
push(@header, "Date: " . expires(0, 'http')) if $expires || $cookie || $nph;
#push(@header, "Pragma: no-cache") if $self->cache();
#push(@header, "Content-Disposition: attachment; filename=\"$attachment\"") if $attachment;
push(@header, map { ucfirst $_ } @other);
#push(@header, "Content-Type: $type") if $type ne '';
content_type $type if $type ne '';
#my $header = join($CRLF, @header) . "${CRLF}${CRLF}";
#if (($MOD_PERL >= 1) && !$nph) {
# $self->r->send_cgi_header($header);
# return '';
#}
#return $header;
#
}
# Retype cookie function
sub _cgi_cookie {
}
# what we run on before hook
hook before => sub {
my $route_handler = shift;
$capture = IO::Capture::Stdout->new();
};
# what we run on after hook
hook after => sub {
undef $capture;
};
#
sub _key_fake_cgi_mock {
return join("::", @_);
}
# Function run before faking
sub _fake_before {
_load_settings() if (!$settings);
#mock 'CGI' => method 'header' => \&_cgi_header;
#mock 'CGI' => method 'header' => should {return " ";};
my $key = _key_fake_cgi_mock('CGI', 'header');
fake_cgi_mock({
package => 'CGI',
method => 'header',
func => sub { return " "; }
}) unless (exists($handle_mock{$key}));
# Mocking header
while (my ($k, $d) = each %handle_mock) {
mock($d->{package}, $d->{method}, $d->{func});
}
$capture->start(); # STDOUT Output captured
CGI::initialize_globals() if defined &CGI::initialize_globals; # Initialize CGI
Dancer::Factory::Hook->instance->execute_hooks('fake_cgi_before', $capture);
}
# Function run after faking
sub _fake_after {
$capture->stop(); # STDOUT output sent to wherever it was before 'start'
# Unmocking CGI methods
#unmock 'CGI' => methods ['header'];
while (my ($k, $d) = each %handle_mock) {
unmock($d->{package}, $d->{method});
delete($handle_mock{$k}) unless ($d->{not_destroy});
}
Dancer::Factory::Hook->instance->execute_hooks('fake_cgi_after', $capture);
}
=head2 fake_cgi_mock
Array of Hashref of methods which will be mocked.
=head3 HASHREF of params
=over
=item package => name of package where is method, when not defined, than we use C<CGI>
=item method => method in specified package which we want to mocked
=item func => code reference of function which we want to run instead specieified function
=item not_destroy => 1 for not unmocking back after fast_cgi_* function ended.
=back
Standart of method which we automatically mocked is CGI->header.
=cut
register fake_cgi_mock => sub {
_load_settings() if (!$settings);
# { package =>, method=>, func=>, not_destroy=>}
foreach my $rh (@_) {
next if (!$rh->{func} || ref($rh->{func}) ne "CODE");
next if (!$rh->{method}); # TODO: test if given method exists in package
$rh->{package} ||= "CGI";
$rh->{not_destroy} ||= 0;
my $key = _key_fake_cgi_mock($rh->{package}, $rh->{method});
$handle_mock{$key} = $rh;
#CGI->import($rh->{method}) if ($rh->{package} eq "CGI");
}
};
=head2 fake_cgi_method
Method for runned specified CGI method-function and return values of runned function.
=head3 PARAMS
=over
=item 1. Package name where is method, which we run. Automatically load this package to memory in first run.
=item 2. Method name which we run.
=item 3. Arguments for given method
=back
=cut
register fake_cgi_method => sub {
my $package = shift;
my $method = shift;
my @args = @_;
unless (defined($method)) {
croak("If not defined method in package, use 'fake_cgi_file'");
return;
}
_load_settings() if (!$settings);
return if ($package && !_load_package($package));
unless ($package->can($method)) {
croak("Not existed method '$method' in package '$package'");
return;
}
_fake_before($package);
my $timer = undef;
if (setting('use_timer')) {
$timer = Dancer::Timer->new();
}
my $ret;
{
no strict 'refs';
$ret = &{(defined($package) ? ($package . "::") : "") . $method}(@args || undef);
}
debug("Running method $method in package $package in " . $timer->to_string . " seconds") if ($timer);
_fake_after();
return $ret;
};
# Return filename
sub _get_file_name {
my $name = shift;
_load_settings() if (!$settings);
unless (defined($name)) {
croak("Not defined filename");
return undef;
}
my $dir = path(setting('confdir'), ($settings->{'cgi-bin'} || 'cgi-bin'));
my $filename = $dir . "/" . $name;
if (!-s $filename) {
croak("Can't read file $name in $dir");
return undef;
}
return $filename;
}
=head2 fake_cgi_file
Method for runned specified Perl CGI file and returned exit value
=head3 PARAMS
=over
=item Perl CGI filename and first in first run we compiled this file into memory
=back
=cut
register fake_cgi_file => sub {
my $file = shift;
my $fname = _get_file_name($file) || return;
my $sub = _compile_file($fname);
_fake_before();
my $timer = undef;
if (setting('use_timer')) {
$timer = Dancer::Timer->new();
}
my $ret = &{$sub}() if (ref($sub));
debug("Running $file in " . $timer->to_string . " seconds") if ($timer);
_fake_after();
return $ret;
};
=head2 fake_cgi_as_string
=head3 TYPES
=over
=item Return captured strings from CGI, which will be printed to STDOUT
=item If first arguments is reference to scallar, than captured strings will be added to this reference and returned size of captured string.
=back
=cut
register fake_cgi_as_string => sub {
if (@_ == 1 && ref($_[0]) eq "SCALAR") {
my $str = $_[0];
$$str = "";
my $len = 0;
while (my $line = $capture->read) {
$len += length($line);
$$str .= $line;
}
return $len;
}
my $ret = "";
while (my $line = $capture->read) {
$ret .= $line;
}
return $ret;
};
=head2 fake_cgi_compile
Load packages into memory or Compiled files into memory
=head3 PARAMS is array of HASHREF
=over
=item filename => compile Perl filename into memory
=item package => load package into memory
=back
=cut
register fake_cgi_compile => sub {
foreach my $rh (@_) {
if (ref($rh) ne "HASH") {
croak("Must be hash");
} elsif (exists($rh->{filename})) {
my $fname = _get_file_name($rh->{filename});
_compile_file($fname) if ($fname);
} elsif (exists($rh->{package})) {
_load_package($rh->{package});
} else {
croak("Nothing defined");
}
}
};
=head2 fake_cgi_capture
Return handle of IO::Capture or undef, if not initialized
=cut
register fake_cgi_capture => sub { return $capture; };
=head1 HOOKS
This plugin uses Dancer's hooks support to allow you to register code that
should execute at given times.
=head3 TYPES
=over
=item fake_cgi_before : hook which will be called before run CGI method or Perl CGI file
=item fake_cgi_after : hook which will be called after runned CGI method or Perl CGI file
=back
In both functions was as first arguments reference to C<IO::Capture::Stdout>
=head3 EXAMPLE
hook 'fake_cgi_before' => sub {
my $capture = shift;
# do something with the new DB handle here
};
=cut
Dancer::Factory::Hook->instance->install_hooks(qw(
fake_cgi_before
fake_cgi_after
));
#register_hook(qw());
register_plugin(for_versions => ['1', '2']);
1; # End of Dancer::Plugin::FakeCGI
__END__
=head1 AUTHOR
Igor Bujna, C<< <igor.bujna@post.cz> >>
=head1 CONTRIBUTING
=head1 ACKNOWLEDGEMENTS
=head1 BUGS
=head1 SUPPORT
=head1 LICENSE AND COPYRIGHT
Copyright 2010-12 Igor Bujna.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See http://dev.perl.org/licenses/ for more information.
=head1 SEE ALSO
L<Dancer>
L<IO::Capture::Stdout>
L<CGI::Compile>
L<Test::TinyMocker>
=cut