Getting the body of an http POST request, using mod-perl 2 - perl

I am writing a quick script to munge a submitted file, and return that content to the user.
My test code looks like this:
#!/path/to/bin/perl
use strict;
use warnings;
use utf8;
use Apache2::RequestRec;
use Apache2::RequestIO;
my ( $xmlin, $accepts ) = (q{}, q{});
my $format = 'json';
# read the posted content
while (
Apache2::RequestIO::read($xmlin, 1024)
) {};
{
no warnings;
$accepts = $Apache2::RequestRec::headers_in{'Accepts'};
}
if ($accepts) {
for ($accepts) {
/application\/xml/i && do {
$format = 'xml';
last;
};
/text\/plain/i && do {
$format = 'text';
last;
};
} ## end for ($accepts)
} ## end if ($accepts)
print "format: $format; xml: $xmlin\n";
This code fails to compile with Undefined subroutine &Apache2::RequestIO::read
If I comment out the while loop, the code runs fine.
Unfortunately the Apache2::RequestIO code is pulled in via Apache2::XSLoader::load __PACKAGE__; so I can't check the actual code.... but I don't understand why this doesn't work
(and yes, I've also tried $r->read(...), to no avail)

I think I have a good idea of why your code is not working.
The module Apache2::RequestIO added new functionality to Apache2::RequestRec.
In other words to add new methods/functions to the Apache2::RequestRec namespace.
I would first change Apache2::RequestIO::read to Apache2::RequestRec::read.
If that does not work move use a handler.
I have code that works which does a similar the thing
In your httpd.conf
PerlSwitches -I/path/to/module_dir
PerlLoadModule ModuleName
PerlResponseHandler ModuleName
ModuleName.pm
package ModuleName;
use strict;
use warnings;
use Apache2::RequestIO();
use Apache2::RequestRec();
use Apache2::Const -compile => qw(OK);
sub handler {
my ($r) = #_;
{
use bytes;
my $content = '';
my $offset = 0;
my $cnt = 0;
do {
$cnt = $r->read($content,8192,$offset);
$offset += $cnt;
} while($cnt == 8192);
}
return Apache2::Const::HTTP_OK;
}

I also use Apache2::RequestIO to read the body:
sub body {
my $self = shift;
return $self->{ body } if defined $self->{ body };
$self->apr->read( $self->{ body }, $self->headers_in->get( 'Content-Length' ) );
$self->{ body };
}
In this case you should subclass original Apache2::Request. Especially pay attention to our #ISA = qw(Apache2::Request);
I do not know why, but standard body method return me:
$self->body # {}
$self->body_status # Missing parser
when Content-Type is application/json. So I work around that in such way. Then parse body myself:
sub content {
my $self = shift;
return $self->{ content } if defined $self->{ content };
my $content_type = $self->headers_in->get('Content-Type');
$content_type =~ s/^(.*?);.*$/$1/;
return unless exists $self->{ $content_type };
return $self->{ content } = $self->{ $content_type }( $self->body, $self );
}
where:
use JSON;
sub new {
my ($proto, $r) = #_;
my $self = $proto->SUPER::new($r);
$self->{ 'application/json' } = sub {
decode_json shift;
};
return $self;
}

Related

Is it possible to register a function to preprocess log messages with Log::Log4perl?

In this example:
$logger->debug({
filter => \&Data::Dumper::Dumper,
value => $ref
});
I can pretty print my references instead of ARRAY(0xFFDFKDJ). But it's too boring to type that long code every time. I just want:
$logger->preprocessor({
filter => \&Data::Dumper::Dumper,
value => $ref
});
$logger->debug( $ref, $ref2 );
$logger->info( $array );
And $ref, $ref2, and $array will be dumped by Data::Dumper.
It there a way to do this?
UPD
With help of your answers I do the patch
Now you just:
log4perl.appender.A1.layout=FallbackLayout
log4perl.appender.A1.layout.chain=PatternLayout
log4perl.appender.A1.layout.chain.ConversionPattern=%m%n
log4perl.appender.A1.warp_message = sub { $#_ = 2 if #_ > 3; \
return #_; }
# OR
log4perl.appender.A1.warp_message = main::warp_my_message
sub warp_my_message {
my( #chunks ) = #_;
use Data::Dump qw/ pp /;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
}
UPD2
Or you can use this small module
log4perl.appender.SomeAPP.warp_message = Preprocess::Messages::msg_filter
log4perl.appender.SomeAPP.layout = Preprocess::Messages
package Preprocess::Messages;
sub msg_filter {
my #chunks = #_;
for my $msg ( #chunks ) {
$msg = pp $msg if ref $msg;
}
return #chunks;
};
sub render {
my $self = shift;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
$_[-1] += 1; # increase level of the caller
return $layout->render( join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #{ shift() }, #_ );
}
sub new {
my $class = shift;
$class = ref ($class) || $class;
return bless {}, $class;
}
1;
Yes, of course you can set 'warp_message = 0' and combine msg_filter and render together.
log4perl.appender.SomeAPP.warp_message = 0
log4perl.appender.SomeAPP.layout = Preprocess::Messages
sub render {
my($self, $message, $category, $priority, $caller_level) = #_;
my $layout = Log::Log4perl::Layout::PatternLayout->new(
'%d %P %p> %c %F:%L %M%n %m{indent=2}%n%n'
);
for my $item ( #{ $message } ) {
$item = pp $item if ref $item;
}
$message = join $Log::Log4perl::JOIN_MSG_ARRAY_CHAR, #$message;
return $layout->render( $message, $category, $priority, $caller_level+1 );
}
The easy way: use warp_message
The easiest way to do this is to create a custom appender and set the warp_message parameter so you can get the original references that were passed to the logger:
package DumpAppender;
use strict;
use warnings;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
bless {}, $_[0];
}
sub log {
my($self, %params) = #_;
print ref($_) ? Dumper($_) : $_ for #{ $params{message} };
print "\n";
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG,Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.layout=NoopLayout
log4perl.appender.Dump.warp_message=0
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
This is a string, but this is a reference: {'foo' => 'bar'}
Unfortunately, if you take this approach, you're stuck writing your own code to handle layouts, open files, etc. I wouldn't take this approach except for very simple projects that only need to print to screen.
A better way: composite appender
A better approach is to write your own composite appender. A composite appender forwards messages on to another appender after manipulating them somehow, e.g. filtering or caching them. With this approach, you can write only the code for dumping the references and let an existing appender do the heavy lifting.
The following shows how to write a composite appender. Some of this is explained in the docs for Log::Log4perl::Appender, but I copied much of it from Mike Schilli's Log::Log4perl::Appender::Limit:
package DumpAppender;
use strict;
use warnings;
our #ISA = qw(Log::Log4perl::Appender);
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Terse = 1;
sub new {
my ($class, %options) = #_;
my $self = {
appender => undef,
%options
};
# Pass back the appender to be limited as a dependency to the configuration
# file parser.
push #{ $options{l4p_depends_on} }, $self->{appender};
# Run our post_init method in the configurator after all appenders have been
# defined to make sure the appenders we're connecting to really exist.
push #{ $options{l4p_post_config_subs} }, sub { $self->post_init() };
bless $self, $class;
}
sub log {
my ($self, %params) = #_;
# Adjust call stack so messages are reported with the correct caller and
# file
local $Log::Log4perl::caller_depth = $Log::Log4perl::caller_depth + 2;
# Dump all references with Data::Dumper
$_ = ref($_) ? Dumper($_) : $_ for #{ $params{message} };
$self->{app}->SUPER::log(
\%params,
$params{log4p_category},
$params{log4p_level}
);
}
sub post_init {
my ($self) = #_;
if(! exists $self->{appender}) {
die "No appender defined for " . __PACKAGE__;
}
my $appenders = Log::Log4perl->appenders();
my $appender = Log::Log4perl->appenders()->{$self->{appender}};
if(! defined $appender) {
die "Appender $self->{appender} not defined (yet) when " .
__PACKAGE__ . " needed it";
}
$self->{app} = $appender;
}
package main;
use strict;
use warnings;
use Log::Log4perl;
Log::Log4perl->init(\q{
log4perl.rootLogger=DEBUG, Dump
log4perl.appender.Dump=DumpAppender
log4perl.appender.Dump.appender=SCREEN
log4perl.appender.SCREEN=Log::Log4perl::Appender::Screen
log4perl.appender.SCREEN.layout=PatternLayout
log4perl.appender.SCREEN.layout.ConversionPattern=%d %p %m%n
});
my $logger = Log::Log4perl->get_logger;
$logger->debug(
'This is a string, but this is a reference: ',
{ foo => 'bar' },
);
Output:
2015/09/14 13:38:47 DEBUG This is a string, but this is a reference: {'foo' => 'bar'}
Note that you have to take some extra steps if you initialize Log::Log4perl via the API instead of via a file. This is documented in the composite appenders section of the Log::Log4perl::Appender documentation.

Accessing __DATA__ from super class

I have a super class called Response :
package Response;
use strict;
use warnings;
use HTML::Template;
sub response {
my ( $class, $request ) = #_;
return $request->new_response( $class->status, $class->headers, $class->body );
}
sub body {
my $class = shift;
my $template = HTML::Template->new( 'filehandle' => eval("$class::DATA") );
return $template->output() . $class;
}
sub status {
return 200;
}
sub headers {
return [ 'Content-Type' => 'text/html' ];
}
1;
__DATA__
Default content
and a subclass called URIError :
package URIError;
use strict;
use warnings;
use Response;
our #ISA = qw(Response);
1;
__DATA__
Invalid URI
When URIError->response is called, line
my $template = HTML::Template->new( 'filehandle' => eval("$class::DATA") );
in Response class does not takes DATA section content from URIError class.
What's the syntax to achieve this ?
Your code will work if you change the body method like this. There is no need for eval: all you have to do is disable strict 'refs' and dereference the string "${class}::DATA"
sub body {
my $class = shift;
my $data_fh = do {
no strict 'refs';
*{"${class}::DATA"};
};
my $template = HTML::Template->new( filehandle => $data_fh );
$template->output . $class;
}

How to clean-up HTTP::Async if still in use

I am using Perl library HTTP::Async as follows:
use strict;
use warnings;
use HTTP::Async;
use Time::HiRes;
...
my $async = HTTP::Async->new( ... );
my $request = HTTP::Request->new( GET => $url );
my $start = [Time::HiRes::gettimeofday()];
my $id = $async->add($request);
my $response = undef;
while (!$response) {
$response = $async->wait_for_next_response(1);
last if Time::HiRes::tv_interval($start) > TIME_OUT;
}
...
When while loop timeout and script ends, I experience the the following error message:
HTTP::Async object destroyed but still in use at script.pl line 0
HTTP::Async INTERNAL ERROR: 'id_opts' not empty at script.pl line 0
What are my options? How can I "clean-up" HTTP::Async object if still in use, but not needed anymore?
I would suggest that you remove incomplete requests, but the module does not provide any interface to do so.
Option 1: Add removal functionality.
Add the following to your script:
BEGIN {
require HTTP::Async;
package HTTP::Async;
if (!defined(&remove)) {
*remove = sub {
my ($self, $id) = #_;
my $hashref = $self->{in_progress}{$id}
or return undef;
my $s = $hashref->{handle};
$self->_io_select->remove($s);
delete $self->{fileno_to_id}{ $s->fileno };
delete $self->{in_progress}{$id};
delete $self->{id_opts}{$id};
return $hashref->{request};
};
}
if (!defined(&remove_all)) {
*remove_all = sub {
my ($self) = #_;
return map $self->remove($_), keys %{ $self->{in_progress} };
};
}
}
You should contact the author and see if he can add this feature. $id is the value returned by add.
Option 2: Silence all warnings from the destructor.
If you're ok with not servicing all the requests, there's no harm in silencing the warnings. You can do so as follows:
use Sub::ScopeFinalizer qw( scope_finalizer );
my $async = ...;
my $anchor = scope_finalizer {
local $SIG{__WARN__} = sub { };
$async = undef;
};
...
Note that this will silence all warnings that occur during the object's destruction, so I don't like this as much.
It's not too hard to subclass HTTP::Async for a more general solution. I use this to be able to abort all pending requests:
package HTTP::Async::WithFlush;
use strict;
use warnings;
use base 'HTTP::Async';
use Time::HiRes qw(time);
sub _flush_to_send {
my $self = shift;
for my $request (#{ $self->{to_send} }) {
delete $self->{id_opts}->{$request->[1]};
}
$self->{to_send} = [];
}
sub _flush_in_progress {
my $self = shift;
# cause all transfers to time out
for my $id (keys %{ $self->{in_progress} }) {
$self->{in_progress}->{$id}->{finish_by} = time - 1;
}
$self->_process_in_progress;
}
sub _flush_to_return {
my $self = shift;
while($self->_next_response(-1)) { }
}
sub flush_pending_requests {
my $self = shift;
$self->_flush_to_send;
$self->_flush_in_progress;
$self->_flush_to_return;
return;
}
1;
This is (maybe) easier on using the module internals than the code by #ikegami.

In Perl, how do I pass a function as argument of another function?

I wrote the following Perl Class:
package Menu;
use strict;
my #MENU_ITEMS;
my $HEADER = "Pick one of the options below\n";
my $INPUT_REQUEST = "Type your selection: ";
sub new {
my $self = {};
$self->{ITEM} = undef;
$self->{HEADER} = undef;
$self->{INPUT_REQUEST} = undef;
bless($self);
return $self;
}
sub setHeader {
my $self = shift;
if(#_) { $self->{HEADER} = shift }
$HEADER = $self->{HEADER}."\n";
}
sub setInputRequest {
my $self = shift;
if(#_) { $self->{INPUT_REQUEST} = shift }
$INPUT_REQUEST = $self->{INPUT_REQUEST}." ";
}
sub addItem {
my $self = shift;
if(#_) { $self->{ITEM} = shift }
push(#MENU_ITEMS, $self->{ITEM});
}
sub getMenu {
my $formatted_menu .= $HEADER;
my $it=1;
foreach(#MENU_ITEMS) {
$formatted_menu.=$it.". ".$_."\n";
$it++
}
$formatted_menu.=$INPUT_REQUEST;
return $formatted_menu;
}
1;
If I call the following perl script:
#!/usr/bin/perl
use strict;
use Menu;
my $menu = Menu->new();
$menu->addItem("First Option");
$menu->addItem("Second Option");
print $menu->getMenu;
I'll get the following output:
Pick one of the options below
1. First Option
2. Second Option
Type your selection:
I'd like to modify given class in a way that I can pass a second argument to the method addItem()
something like:
$menu->addItem("First Option", &firstOptionFunction());
and if and only if First Option is selected, then $firstOptionFunction is executed.
Is there any way to achieve such behavior in Perl?
Thanks!
You would want to pass a reference to the subroutine.
$menu->addItem("First Option", \&firstOptionFunction);
And your addItem method might look like this:
sub addItem { ## your logic may vary
my ( $self, $option, $code ) = #_;
if ( $option eq 'First Option' ) {
$code->();
}
$self->{ITEM} = $option;
push #MENU_ITEMS, $option;
return;
}
As you mentioned in the comments, you might want to not pass the subroutine as a reference, but rather store it somewhere else. Something like this might work:
sub new {
my $class = shift;
my $self = bless {}, $class;
$self->{f_o_code} = \&firstOptionFunction; ## use a better name than f_o_code
return $self;
}
## add your other methods
sub addItem { ## your logic may vary
my ( $self, $option ) = #_;
if ( $option eq 'First Option' ) {
$self->{f_o_code}->();
}
$self->{ITEM} = $option;
push #MENU_ITEMS, $option;
return;
} ## call like $menu->addItem( 'First Option' );

How can I use a code ref as a callback in Perl?

I have the following code in my class :
sub new {
my $class = shift;
my %args = #_;
my $self = {};
bless( $self, $class );
if ( exists $args{callback} ) {
$self->{callback} = $args{callback};
}
if ( exists $args{dir} ) {
$self->{dir} = $args{dir};
}
return $self;
}
sub test {
my $self = shift;
my $arg = shift;
&$self->{callback}($arg);
}
and a script containing the following code :
use strict;
use warnings;
use MyPackage;
my $callback = sub {
my $arg = shift;
print $arg;
};
my $obj = MyPackage->new(callback => $callback);
but I receive the following error:
Not a CODE reference ...
What am I missing? Printing ref($self->{callback}) shows CODE. It works if I use $self->{callback}->($arg), but I would like to use another way of invoking the code ref.
The ampersand is binding just to $self and not the whole thing. You can do curlies around the part that returns the reference:
&{$self->{callback}}($arg);
But the
$self->{callback}->($arg);
is generally considered cleaner, why don't you want to use it?