I'm hacking on Request Tracker, which is written in perl and uses Mason
for the web interface. I'm trying to make a customized page, that involves an autohandler, an html page, and pulls in some methods in other comps. I have a simple class that I want to use to track a few things that I need for my parts of the interface. Right now all it
tracks is a database handle.
package RTx::FooBar::Web;
use strict;
use warnings;
use RTx::FooBar::Handle;
sub new
{
my $proto = shift;
$RT::Logger->debug("creating new");
my $class = ref($proto) || $proto;
my $self = {};
bless( $self, $class);
my $handle = RTx::FooBar::Handle->new();
$handle->Connect();
$self->{cfHandle} = $handle;
return $self;
}
sub DESTROY {
my $self = shift;
$RT::Logger->debug("destroy");
delete $self->{cfHandle};
}
sub CFHandle
{
my $self = shift;
return $self->{cfHandle};
}
1;
I tried sticking that into the session so I could use it wherever I needed
it in the web interface. So I try to use it in one web page - the autohandler does:
% $m->call_next;
<%INIT>
$RT::Logger->debug("my autohandler");
use RTx::FooBar::Web;
$session{cfWeb} ||= RTx::FooBar::Web->new();
</%INIT>
The thing that's bugging me right now (other than the fact that it's not
working) is that the logging in the "new" method prints out once, but the
logging in the DESTROY method prints out 56 times. And each time, the
debug in RTx::FooBar::Handle->DESTROY prints out as well, indicating that
$self->{cfHandle} wasn't removed. Can anybody suggest why this might be
happening? Is it because session is a tied hash?
*Update* I'm no longer using $session, and it's STILL destroying my handle 56 times after creating it once.
Just a guess here - $session is re-creating your objects from an externalized version (perhaps via Storable or the like). So it gets the object back without calling new so no logging. Not sure why it would be getting destroyed every time tho.
It looks like $session is in fact a tied hash, to an Apache::Session or something implementing the same interface (the docs talk about db backing for sessions).
If you want to have a global persistent object (i.e., not tied to a single request) then give it a fully-qualified name, e.g., $RTx::FooBar::Web::TheObject ||= RTx::FooBar::Web->new(); or use something like Cache::MemoryCache. Alternately, set up your own global variable in the MasonAllowGlobals setting, although you might need to get into RT's config files to change that.
Related
I'm working with WWW::Mechanize to automate web-based back office clicking I need to do to get my test e-commerce orders into the state I need them to be to test changes I have made to a particular part of a long, multi-part workflow. To process a lot of orders in a batch, I need to click the Home link often. To make that shorter, I hacked a method into WWW::Mechanize at run time like this (based on an example in Mastering Perl by brian d foy):
{ # Shortcut to go back to the home page by calling $mech->go_home
# I know I'll get a warning and do not want it!
no warnings 'once';
my $homeLink = $mech->find_link( text => 'Home' )->url_abs();
$homeLink =~ s/system=0/system=1/;
*WWW::Mechanize::go_home = sub {
my ($self) = #_;
return $self->get($homeLink);
};
}
This works great, and does not hurt anyone because the script I'm using it in is only used by me and is not part of the larger system.
But now I wonder if it is possible to actually only tell one $mech object that is has this method, while another WWW::Mechanize object that might be created later (to, say, do some cross-referencing without mixing up the other one that has an active session to my back office) cannot use that method.
I'm not sure if that is possible at all, since, if I understand the way objects work in Perl, the -> operator tells it to look for the subroutine go_home inside the package WWW::Mechanize and pass the $mech as the first argument to it. Please correct me if this understanding is wrong.
I've experimented by adding a sort of hard-coded check that only lets the original $mech object use the function.
my $onlyThisMechMayAccessThisMethod = "$mech";
my $homeLink = $mech->find_link( text => 'Home' )->url_abs();
$homeLink =~ s/system=0/system=1/;
*WWW::Mechanize::go_home = sub {
my ($self) = #_;
return undef unless $self eq $onlyThisMechMayAccessThisMethod;
return $self->get($homeLink);
};
Since "$mech" contains the address of where the data is stored (e.g. WWW::Mechanize=HASH(0x2fa25e8)), another object will look differently when stringified this way.
I am not convinced however that this is the way to go. So my question is: Is there a better way to only let one object of the WWW::Mechanize class have this method? I'm also glad about other suggestions regarding this code.
This is just
$mech->follow_link(text => 'Home')
and I don't think it's special enough to warrant a method of its own, or to need restricting to an exclusive club of objects.
It's also worth noting that there is no need to mess with typeglobs to declare a subroutine in a different package. You just have to write, for example
sub WWW::Mechanize::go_home {
my ($self) = #_;
return $self->get($homeLink);
};
But the general solution is to subclass WWW::Mechanize and declare as members only those objects you want to have the new method.
File MyMechanize.pm
package MyMechanize;
use strict;
use warnings;
use parent 'WWW::Mechanize';
sub go_home {
my $self = shift;
my $homeLink = $self->find_link(text => 'Home')->url_abs;
$homeLink =~ s/system=0/system=1/;
return $self->get($homeLink);
}
1;
File test.pl
use strict;
use warnings;
use MyMechanize;
my $mech = MyMechanize->new;
$mech->get('http://mydomain.com/path/to/site/page.html')
$mech->go_home;
When you run perl -e "Bla->new", you get this well-known error:
Can't locate object method "new" via package "Bla"
(perhaps you forgot to load "Bla"?)
Happened in a Perl server process the other day due to an oversight of mine. There are multiple scripts, and most of them have the proper use statements in place. But there was one script that was doing Bla->new in sub blub at line 123 but missing a use Bla at the top, and when it was hit by a click without any of the other scripts using Bla having been loaded by the server process before, then bang!
Testing the script in isolation would be the obvious way to safeguard against this particular mistake, but alas the code is dependent upon a humungous environment. Do you know of another way to safeguard against this oversight?
Here's one example how PPI (despite its merits) is limited in its view on Perl:
use strict;
use HTTP::Request::Common;
my $req = GET 'http://www.example.com';
$req->headers->push_header( Bla => time );
my $au=Auweia->new;
__END__
PPI::Token::Symbol '$req'
PPI::Token::Operator '->'
PPI::Token::Word 'headers'
PPI::Token::Operator '->'
PPI::Token::Word 'push_header'
PPI::Token::Symbol '$au'
PPI::Token::Operator '='
PPI::Token::Word 'Auweia'
PPI::Token::Operator '->'
PPI::Token::Word 'new'
Setting the header and assigning the Auweia->new parse the same. So I'm not sure how you can build upon such a shaky foundation. I think the problem is that Auweia could also be a subroutine; perl.exe cannot tell until runtime.
Further Update
Okay, from #Schwern's instructive comments below I learnt that PPI is just a tokenizer, and you can build upon it if you accept its limitations.
Testing is the only answer worth the effort. If the code contains mistakes like forgetting to load a class, it probably contains other mistakes. Whatever the obstacles, make it testable. Otherwise you're patching a sieve.
That said, you have two options. You can use Class::Autouse which will try to load a module if it isn't already loaded. It's handy, but because it affects the entire process it can have unintended effects.
Or you can use PPI to scan your code and find all the class method calls. PPI::Dumper is very handy to understand how PPI sees Perl.
use strict;
use warnings;
use PPI;
use PPI::Dumper;
my $file = shift;
my $doc = PPI::Document->new($file);
# How PPI sees a class method call.
# PPI::Token::Word 'Class'
# PPI::Token::Operator '->'
# PPI::Token::Word 'method'
$doc->find( sub {
my($node, $class) = #_;
# First we want a word
return 0 unless $class->isa("PPI::Token::Word");
# It's not a class, it's actually a method call.
return 0 if $class->method_call;
my $class_name = $class->literal;
# Next to it is a -> operator
my $op = $class->snext_sibling or return 0;
return 0 unless $op->isa("PPI::Token::Operator") and $op->content eq '->';
# And then another word which PPI identifies as a method call.
my $method = $op->snext_sibling or return 0;
return 0 unless $method->isa("PPI::Token::Word") and $method->method_call;
my $method_name = $method->literal;
printf "$class->$method_name seen at %s line %d.\n", $file, $class->line_number;
});
You don't say what server enviroment you're running under, but from what you say it sounds like you could do with preloading all your modules in advance before executing any individual pages. Not only would this prevent the problems you're describing (where every script has to remember to load all the modules it uses) but it would also save you memory.
In pre-forking servers (as is commonly used with mod_perl and Apache) you really want to load as much of your code before your server forks for the first time so that the code is stored once in copy-on-write shared memory rather than mulitple times in each child process when it is loaded on demand.
For information on pre-loading in Apache, see the section of Practical mod_perl
Is there a way to use Log::Log4perl to make a smart self-logging module that logs its operations to a file even in the absence of the calling script not initializing Log4perl? As far as I can tell from the documentation, the only way to use Log4perl is to initialize it in the running script from a configuration, then modules implementing Log4perl calls log themselves based on the caller's Log4perl config.
Instead, I'd like the modules to provide a default initialization config for Log4perl. This would provide the default file appender for the module's category. Then, I could override this behavior by initing Log4perl in the caller with a different config if needed, and everything would hopefully just work.
Is this sort of defensive logging behavior possible or am I going to need to rely on initing Log4perl in every .pl script that calls the module I want logged?
I do this in a custom Log role in Moose (irrelevant complicated code removed):
package MyApp::Role::Log;
use Moose::Role;
use Log::Log4perl;
my #methods = qw(
log trace debug info warn error fatal
is_trace is_debug is_info is_warn is_error is_fatal
logexit logwarn error_warn logdie error_die
logcarp logcluck logcroak logconfess
);
has _logger => (
is => 'ro',
isa => 'Log::Log4perl::Logger',
lazy_build => 1,
handles => \#methods,
);
around $_ => sub {
my $orig = shift;
my $this = shift;
# one level for this method itself
# two levels for Class:;MOP::Method::Wrapped (the "around" wrapper)
# one level for Moose::Meta::Method::Delegation (the "handles" wrapper)
local $Log::Log4perl::caller_depth;
$Log::Log4perl::caller_depth += 4;
my $return = $this->$orig(#_);
$Log::Log4perl::caller_depth -= 4;
return $return;
} foreach #methods;
method _build__logger => sub {
my $this = shift;
my $loggerName = ref($this);
Log::Log4perl->easy_init() if not Log::Log4perl::initialized();
return Log::Log4perl->get_logger($loggerName)
};
As you can see, the log object is self-initializing -- if Log::Log4perl->init has not been called, then easy_init is called. You could easily modify this to allow each module to customize its logger -- I do so with optional role parameters, with ref($this) as the default fallback.
PS. You may also want to look at MooseX::Log::Log4perl, which is where I started before I used the logger role above. Someday when I get around to it I will submit some much-needed patches to that MX module to incorporate some features I have added.
The short answer is to call Log::Log4perl::initialized(); at some point and if it is false, set up some default logging.
The tricky part is "some point."
You can't do it in BEGIN {}, because then the main script's will stomp your initialisation even though you created unnessary files. You don't want to do it before each call to get_logger() because that is wasteful. So you should do it during the module's initialisation, say sub new or sub init.
I've been trying to switch from using PerlSetEnv to using custom configuration directives. I have my configuration module with a copy of set_val from the docs:
sub set_val
{
local our ($key, $self, $parms, $arg) = #_;
$self->{$key} = $arg;
unless ($parms->path)
{
local our $srv_cfg = Apache2::Module::get_config($self, $parms->server);
$srv_cfg->{$key} = $arg;
}
}
...which is called by every custom directive sub. Then I have in my .conf:
PerlLoadModule MyModule::ServerConfig
MyCustomDirective 'hello'
This works fine in that httpd -t okays the file's syntax. The problem is that I can't seem to get at the value from the config file from within a BEGIN block, which I need to do.
I've tried tinkering with all sorts of things:
BEGIN
{
use Apache2::CmdParms ();
# use Apache2::Directive ();
use Apache2::Module ();
# use Apache2::ServerUtil ();
# use Apache2::RequestUtil ();
use Data::Dump;
warn ddx(Apache2::Module::get_config('MyModule::ServerConfig', Apache2::CmdParms->server));
# warn ddx(Apache2::Directive->as_hash);
# warn Apache2::ServerUtil->dir_config('MyCustomDirective);
# warn Apache2::CmdParms->server->server_hostname();
}
...but to no avail. Most of my efforts (trying to access CmdParms->server for instance) result in Parent: child process exited with status 3221225477 -- Restarting and an automatic restart of Apache as it says. If I pass ServerUtil->server to get_config(), the server stays alive but the warning only prints out '1'.
I read somewhere that this is because you can't get at anything request-related within a BEGIN block, because requests vary. It kind of makes sense, except that with PerlOptions +GlobalRequest I have been able to see $ENV within a BEGIN block, so why wouldn't I be able to see my own directives, just as dependent as they are on how the request happens? Especially confusing is that if I try to pass Apache2::RequestUtil->request->per\_dir\_config() to get_config(), it says Global $r object is not available. If that's true in a BEGIN block, how is it I can get at $ENV?
Try add what you want to import function to other module and use this module in code where you usually put BEGIN block. It should work same. May be it helps.
Partly, Dump isn't being used correctly. This works better:
use Data::Dump qw(pp);
warn pp(Apache2::Module::get_config('MyModule::ServerConfig', Apache2::ServerUtil->server));
However, it doesn't show any directives that appear within <Directory> blocks.
In my particular case, though, I don't need that functionality, on second thought; that just happens to be where I had stuck them.
I'm trying to get some code called after each request completes using Catalyst. Basically, I want to run some code as part of finalize. Supposedly Catalyst::Plugin::Observe will do this, but it appears completely broken (just loading the plugin breaks Catalyst).
I'm trying to fix the Observe plugin, but that's proving stubborn.
So, is there a better way to do get some cleanup code called at the end of each request?
(Note: This is in a model, not a controller, so I can't just use sub end { ... })
You can actually just add the code directly to your "MyApp" class:
package MyApp;
use Catalyst ...;
...
sub finalize {
my $c = shift;
$c->NEXT::finalize(#_);
# do your thing
}
This is how all plugins work; they are just methods that become part of your app.
I do agree that making "finalize" generate an event to observe is cleaner... but this is what we have to work with for now :) Join #catalyst on irc.perl.org, and we can discuss further. (I am jrockway, as you may guess.)
Edited to reply to:
(Note: This is in a model, not a controller, so I can't just use sub end { ... })
You do know that you have $c in end, right?
package Your::Model;
sub cleanup {
my $self = shift;
...
}
package Your::Controller;
sub end :Private {
my ($self, $c) = #_;
$c->model('Your::Model')->cleanup( ... )
}
Or you can do it from MyApp::finalize, as I suggested above.
The real question is, why does your model need to know about the request cycle? That sounds like awfully tight coupling.