File Coverage

blib/lib/MojoX/Template/PHP.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package MojoX::Template::PHP;
use 5.010;
use Mojo::Base -base;
use Carp 'croak';
use PHP 0.15;
use Mojo::ByteStream;
use Mojo::Exception;
use Mojo::Util qw(decode encode monkey_patch slurp url_unescape);
use File::Temp;
use constant DEBUG =>   # not used ...
    $ENV{MOJO_TEMPLATE_DEBUG} || $ENV{MOJOX_TEMPLATE_PHP_DEBUG} || 0;

use Data::Dumper;
$Data::Dumper::Indent = $Data::Dumper::Sortkeys = 1;

our $VERSION = '0.03';

#has [qw(auto_escape)];
has [qw(code include_file)] => '';
has encoding => 'UTF-8'; # documented, not used
has name => 'template.php';
has template => "";

sub interpret {
    no strict 'refs';  # let callbacks be fully qualified subroutine names

    my $self = shift;
    my $c = shift // {};
    my $log = $c->app->log;
    local $SIG{__DIE__} = sub {
	CORE::die($_[0]) if ref $_[0];
	Mojo::Exception->throw( shift,
		[ $self->template, $self->include_file, $self->code ] );
    };

    PHP::__reset;

    if (DEBUG) {
	$log->debug(" Request: ", Dumper($c->req) );
    }

    my $callbacks = $c && $c->app->config->{'MojoX::Template::PHP'};
    $callbacks ||= {};

    # prepare global variables for the PHP interpreter
    my $variables_order = PHP::eval_return( "ini_get('variables_order')" );
    my $cookie_params = { };
    my $params = $c ? { %{$c->{stash}}, c => $c } : { };

    if ($variables_order =~ /S/) {
	$params->{_SERVER} = $self->_server_params($c);
	$params->{_ENV} = \%ENV;
    } elsif ($variables_order =~ /E/) {
	$params->{_ENV} = \%ENV;
    }
    if ($variables_order =~ /C/) {
	$cookie_params = $self->_cookie_params($c);
	$params->{_COOKIE} = $cookie_params;
    }

    $params->{_FILES} = $self->_files_params($c);

    $self->_set_get_post_request_params( $c, $params, $variables_order );

    # XXX - should we always set $HTTP_RAW_POST_DATA?
    my $input = $c->req->body;
    if (my $len = length($input)) {
	PHP::set_php_input( "$input" );
	$params->{HTTP_RAW_POST_DATA} = "$input";
    }

    # hook to make adjustments to  %$params
    if ($callbacks && $callbacks->{php_var_preprocessor}) {
	$callbacks->{php_var_preprocessor}->($params);
    }

    if (DEBUG) {
	$log->debug("Super globals for request " . $self->include_file . ":"
		    . Data::Dumper::Dumper({_GET => $params->{_GET},
					    _POST => $params->{_POST},
					    _REQUEST => $params->{_REQUEST},
					    _FILES => $params->{_FILES},
					    _SERVER => $params->{_SERVER} }));
    }

    while (my ($param_name, $param_value) = each %$params) {
	next if 'CODE' eq ref $param_value;
	PHP::assign_global($param_name, $param_value);
    }
    $c && $c->stash( 'php_params', $params );


    my $OUTPUT;
    my $ERROR = "";
    PHP::options(
	stdout => sub {
	    $OUTPUT .= $_[0];
	} );
    PHP::options(
	stderr => sub {
	    $ERROR .= $_[0];
	    if ($callbacks && $callbacks->{php_stderr_processor}) {
		$callbacks->{php_stderr_processor}->($_[0]);
	    }
	} );
    PHP::options(
	header => sub {
	    my ($keyval, $replace) = @_;
	    my ($key,$val) = split /: /, $keyval, 2;
	    my $keep = 1;
	    if ($callbacks && $callbacks->{php_header_processor}) {
		$keep &&= $callbacks->{php_header_processor}
				    ->($key, $val, $replace);
	    }
	    return if !$keep;

	    if ($replace) {
		$c->res->headers->header($key,$val);
	    } else {
		$c->res->headers->add($key,$val);
	    }
	    if ($key =~ /^[Ss]tatus$/) {
		my ($code) = $val =~ /^\s*(\d+)/;
		if ($code) {
		    $c->res->code($code);
		} else {
		    $log->error("Unrecognized Status header: '"
					. $keyval . "' from PHP");
		}
	    }
	} );

    if (my $ipath = $c->stash("__php_include_path")) {
	PHP::set_include_path( $ipath );
	$log->info("include path: $ipath") if DEBUG;
    }

    if ($self->include_file) {
	if (DEBUG) {
	    $log->info("executing " . $self->include_file . " in PHP engine");
	}
	eval { PHP::include( $self->include_file ) };
    } else {
	my $len = length($self->code);
	if (DEBUG) {
	    if ($len < 1000) {
		$log->info("executing code:\n\n" . $self->code
			   . "\nin PHP engine");
	    } else {
		$log->info("executing $len bytes of code in PHP engine");
	    }
	}
	eval { PHP::eval( "?>" . $self->code ); };
    }

    if ($@) {
	if (length($OUTPUT || "") < 1000 || DEBUG) {
	    $log->error("Output from PHP engine: (" . $self->name .
			"):\n\n" . ($OUTPUT // "") . "\n");
	} else {
	    $log->error("Output from PHP engine (" . $self->name . "): "
			. length($OUTPUT) . " bytes");
	}
	$log->error("PHP error from template " . $self->name . ": $@");

	# when does $@ indicate a serious (server) error,
	# and when can it be ignored? The value of $@ is often
        # something like "PHP error: PHP::eval failed at
	# .../i686-linux/PHP.pm line 25.", which sometimes just
	# means that WordPress called exit()

	if (!$OUTPUT  && $@ !~ /PHP::eval failed at /) {
	    # maybe we are changing the response code to 500 too much
	    $log->info( "changing response code from "
				. ($c->res->code || "") . " to 500" );
	    $OUTPUT = $@;
	    $c->res->code(500);
	}

	undef $@;
    }
    if ($ERROR) {
	$log->warn("Error from PHP: $ERROR");
    }

    my $output = $OUTPUT;

    if ($callbacks && $callbacks->{php_output_postprocessor}) {
	$callbacks->{php_output_postprocessor}->(
	    \$output, $c && $c->res->headers, $c);
    }
    if ($c->res->headers->header('Location')) {

	# this is disappointing. if the $output string is empty,
	# Mojo will automatically sets a 404 status code?
	if ("" eq ($output // "")) {
	    $output = chr(0);
	}
	if (!$c->res->code) {
	    $c->res->code(302);
	} elsif (500 == $c->res->code) {
	    $log->info("changing response code from 500 to 302 because there's a location header");
	    $c->res->code(302);
	    $log->info("output is\n\n" . $output);
	    $log->info("active exception msg is: " . ($@ || ""));
	    undef $@;
	}
    }

    return $output unless $@;
    return Mojo::Exception->new( $@, [$self->template, $self->code] );
}

sub _get_upload_metadata {
    my ($self, $upload) = @_;

    my ($temp_fh, $tempname) = File::Temp::tempfile( UNLINK => 1 );
    print $temp_fh $upload->slurp;
    close $temp_fh;
    PHP::_spoof_rfc1867( $tempname || "" );

    return {
	name => $upload->name,
	type => $upload->headers->content_type,
	size => $upload->size,
	filename => $upload->filename,
	tmp_name => $tempname,
	error => 0
    };
}

sub _files_params {
    my ($self, $c) = @_;
    my $_files = {};
    my $uploads = $c->req->uploads;

    if ($uploads) {

	foreach my $upload (@$uploads) {

	    DEBUG && $c->app->log->debug("\n--------\nUPLOAD:\n---------\n"
			    . Data::Dumper::Dumper($upload)
			    . "\n-------------------\n");

	    my $metadata = $self->_get_upload_metadata($upload);
	    if ($metadata->{name} =~ s/\[\]//) {
		my $name = $metadata->{name};
		$metadata->{name} = $metadata->{filename};
		if ($_files->{$name} && !ref $_files->{$name}) {
		    # upload of foo[] overwrites upload of foo
		    delete $_files->{$name};
		}
		for my $attrib (qw(name size type tmp_name error)) {
		    push @{$_files->{$name}{$attrib}},
			    $metadata->{$attrib};
		}
	    } elsif ($metadata->{name} =~ s/\[(.*?)\]//) {
		# XXX -- need test in t/20-uploads.t for this branch
		my $index = $1;
		my $name = $metadata->{name};
		$metadata->{name} = delete $metadata->{filename};
		$_files->{$name}{$index} = $metadata;
	    } else {
		my $name = $metadata->{name};
		$metadata->{name} = delete $metadata->{filename};
		$_files->{$name} = $metadata;
	    }
	}
#	$_files = _files_params_000($self, $c);
    }
    if (DEBUG && keys %$_files) {
	$c->app->log->debug("\$_FILES => " . Data::Dumper::Dumper($_files));
    }
    return $_files;
}

sub _cookie_params {
    my ($self, $c) = @_;
    if (@{$c->req->cookies}) {
	$DB::single = 'cookies!';
    }

    # Mojo: $c->req->cookies is [], in Catalyst it is {}
    my $p = {
	map {;
	     $_->name => url_unescape $_->value
	} @{$c->req->cookies} };
    return $p;
}

sub _server_params {
    use Socket;
    use Sys::Hostname;
    my ($self, $c) = @_;

    my $tx = $c->tx;
    my $req = $c->req;
    my $headers = $req->headers;

    # see  Mojolicious::Plugin::CGI
    return {
	CONTENT_LENGTH => $headers->content_length || 0,
	CONTENT_TYPE => $headers->content_type || 0,
	GATEWAY_INTERFACE => 'PHP/5.x',
	HTTP_COOKIE => $headers->cookie || '',
	HTTP_HOST => $headers->host || '',
	HTTP_REFERER => $headers->referrer || '',
	HTTP_USER_AGENT => $headers->user_agent || '',
	HTTPS => $req->is_secure ? 'YES' : 'NO',
	PATH_INFO => $req->{__old_path} || $req->url->path->to_string,
	QUERY_STRING => $req->url->query->to_string,
	REMOTE_ADDR => $tx->remote_address,
	REMOTE_HOST => gethostbyaddr( inet_aton( $tx->remote_address ), AF_INET ) || '',
	REMOTE_PORT => $tx->remote_port,
	REQUEST_METHOD => $req->method,
	REQUEST_URI => $req->url->to_string,
	SERVER_NAME => hostname,
	SERVER_PORT => $tx->local_port,
	SERVER_PROTOCOL => $req->is_secure ? 'HTTPS' : 'HTTP',
	SERVER_SOFTWARE => __PACKAGE__
    };
}

sub _mojoparams_to_phpparams {
    my ($query, @order) = @_;
    my $existing_params = {};
    foreach my $name ($query->param) {
	my @p = $query->param($name);
	$existing_params->{$name} = @p > 1 ? [ @p ] : $p[0];
    }

    # XXX - what if parameter value is a Mojo::Upload ? Do we still
    #       save it in the $_GET/$_POST array?


    # The conventional ways to parse input parameters with Perl (CGI/Catalyst)
    # are different from the way that PHP parses the input, and we may need
    # to translate the Perl-style parameters to PHP-style. Some examples:
    #
    # 1. foo=first&foo=second&foo=last
    #
    #    In Perl, value for the parameter 'foo' is an array ref with 3 values
    #    In PHP, value for param 'foo' is 'last', whatever the last value was
    #    See also example #5
    #
    # 2. foo[bar]=value1&foo[baz]=value2
    #
    #    In Perl, this creates scalar parameters 'foo[bar]' and 'foo[baz]'
    #    In PHP, this creates the parameter 'foo' with an associative array
    #            value ('bar'=>'value1', 'baz'=>'value2')
    #
    # 3. foo[bar]=value1&foo=value2&foo[baz]=value3
    #
    #    In Perl, this creates parameters 'foo[bar]', 'foo', and 'foo[baz]'
    #    In PHP, this create the parameter 'foo' with an associative array
    #            with value ('baz'=>'value3'). The values associated with
    #            'foo[bar]' and 'foo' are lost.
    #
    # 4. foo[2][bar]=value1&foo[2][baz]=value2
    #
    #    In Perl, this creates parameters 'foo[2][bar]' and 'foo[2][baz]'
    #    In PHP, this creates a 2-level hash 'foo'
    #
    # 5. foo[]=123&foo[]=234&foo[]=345
    #    In Perl, parameter 'foo[]' assigned to array ref [123,234,345]
    #    In PHP, parameter 'foo' is an array with elem (123,234,345)
    #
    # For a given set of Perl-parsed parameter input, this function returns
    # a hashref that resembles what the same parameters would look like
    # to PHP.

    my $new_params = {};
    foreach my $pp (@order) {
	my $p = $pp;
	if ($p =~ s/\[(.+)\]$//) {
	    my $key = $1;
	    s/%(..)/chr hex $1/ge for $p, $pp, $key;

	    if ($key ne '' && $new_params->{$p}
		    && ref($new_params->{$p} ne 'HASH')) {
		$new_params->{$p} = {};
	    }

	    # XXX - how to generalize this from 2 to n level deep hash?
	    if ($key =~ /\]\[/) {
		my ($key1, $key2) = split /\]\[/, $key;
		$new_params->{$p}{$key1}{$key2} = $existing_params->{$pp};
	    } else {
		$new_params->{$p}{$key} = $existing_params->{$pp};
	    }
	} elsif ($p =~ s/\[\]$//) {
	    # expect $existing_params->{$pp} to already be an array ref
	    $p =~ s/%(..)/chr hex $1/ge;
	    $new_params->{$p} = $existing_params->{$pp};
	} else {
	    $p =~ s/%(..)/chr hex $1/ge;
	    $new_params->{$p} = $existing_params->{$p};
	    if ('ARRAY' eq ref $new_params->{$p}) {
		$new_params->{$p} = $new_params->{$p}[-1];
	    }
	}
    }
    return $new_params;
}

sub _set_get_post_request_params {
    my ($self, $c, $params, $var_order) = @_;
    my $order = PHP::eval_return( 'ini_get("request_order")' ) || $var_order;
    $params->{$_} = {} for qw(_GET _POST _REQUEST);
    if ($var_order =~ /G/) {
	my $query = $c->req->url && $c->req->url->query;
	if ($query) {
	    $query =~ s/%(5[BD])/chr hex $1/ge;
	    my @order = map { s/=.*//; $_ } split /&/, $query;
	    $params->{_GET} = _mojoparams_to_phpparams(
		 $c->req->url->query, @order );
	}
    }

    if ($var_order =~ /P/ && $c->req->method eq 'POST') {
	my $order = [ $c->req->body_params->param ];
	$params->{_POST} = _mojoparams_to_phpparams(
	    $c->req->body_params, @$order );
    }

    $params->{_REQUEST} = {};
    foreach my $reqvar (split //, uc $order) {
	if ($reqvar eq 'C') {
	    $params->{_REQUEST} = { %{$params->{_REQUEST}},
				    %{$params->{_COOKIE}} };
	} elsif ($reqvar eq 'G') {
	    $params->{_REQUEST} = { %{$params->{_REQUEST}},
				    %{$params->{_GET}} };
	} elsif ($reqvar eq 'P') {
	    $params->{_REQUEST} = { %{$params->{_REQUEST}},
				    %{$params->{_POST}} };
	}
    }
    return;
}

sub render {
    my $self = shift;
    my $c = pop if @_ && ref $_[-1];
    $self->code( join '', @_ );
    $self->include_file('');
    return $self->interpret($c);
}

sub render_file {
    my ($self, $path) = (shift, shift);
    $self->name($path) unless defined $self->{name};
    $self->include_file($path);
    return $self->interpret(@_);
}

unless (caller) {
    my $mt = MojoX::Template::PHP->new;
    my $output = $mt->render(<<'EOF');

    Simple

        Time:


EOF
    say $output;

    open my $fh, '>/tmp/test.php' or die;
    print $fh <<'EOF';

HeLlO WoRlD!

EOF
    close $fh;
    $output = $mt->render_file( '/tmp/test.php' );
    say $output;
    unlink '/tmp/test.php';
}

1;

=encoding utf8

=head1 NAME

MojoX::Template::PHP - PHP processing engine for MojoX::Plugin::PHP

=head1 VERSION

0.03

=head1 SYNOPSIS

    use MojoX::Template::PHP;
    my $mt = MojoX::Template::PHP->new;
    my $output = $mt->render(<<'EOF');

        Simple
        Time:



    EOF
    say $output;

    my $output = $mt->render_file( '/path/to/some/template.php' );
    say $output;

=head1 DESCRIPTION

L is a way to use PHP as a templating
system for your Mojolicious application.

=over 4

=item 1. You can put a Mojolicious wrapper around some decent
PHP application (say, WordPress)

=item 2. You are on a development project with Perl and PHP
programmers, and you want to use Mojolicious as a backend
without scaring the PHP developers.

=back

=head1 ATTRIBUTES

L implements the following attributes:

=head2 code

    my $code = $mt->code;
    $mt = $mt->code($code);

Inline PHP code for template. The L<"interpret"> method
will check the L<"include_file"> attribute first, and then
this attribute to decide what to pass to the PHP interpreter.

=head2 encoding

    my $encoding = $mt->encoding;
    $mt = $mt->encoding( $charset );

Encoding used for template files.

=head2 include_file

    my $file = $mt->include_file;
    $mt = $mt->include_file( $path );

PHP template file to be interpreted. The L<"interpret"> method
will check this attribute, and then the L<"code"> attribute
to decide what to pass to the PHP interpreter.

=head2 name

    my $name = $mt->name;
    $mt = $mt->name('foo.php');

Name of the template currently being processed. Defaults to
C. This value should not contain quotes or
newline characters, or error messages might end up being wrong.

=head2 template

    my $template = $mt->template;
    $mt = $mt->template( $template_name );

Should contain the name of the template currently being processed,
but I don't think it is ever set to anything now. This value will
appear in exception messages.

=head1 METHODS

L inherits all methods from
L, and the following new ones:

=head2 interpret

    my $output = $mt->interpret($c)

Interpret template code. Starts the PHP engine and evaluates the
template code with it. See L<"CONFIG"/MojoX::Plugin::PHP> for
information about various callbacks that can be used to change
and extend the behavior of the PHP templating engine.

=head2 render

    my $output = $mt->render($template);

Render a PHP template.

=head2 render_file

    my $output = $mt->render_file( $php_file_path );

Render template file.

=cut

#=head1 DEBUGGING
#
#You can set either the C or
#C environment variable to enable
#some diagnostics information printed to C.

=head1 SEE ALSO

L, L, L,
L

=head1 AUTHOR

Marty O'Brien [e-mail]

=head1 COPYRIGHT

Copyright 2013, Marty O'Brien. All rights reserved.

This library 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 Sortware Foundation; or the Artistic License.

See http://dev.perl.org/licenses for more information.

=cut