← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:02:26 2013

Filename/usr/lib/perl5/Template/Plugins.pm
StatementsExecuted 30 statements in 1.43ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11125µs25µsTemplate::Plugins::::_initTemplate::Plugins::_init
11121µs27µsTemplate::Plugins::::BEGIN@26Template::Plugins::BEGIN@26
11115µs97µsTemplate::Plugins::::BEGIN@28Template::Plugins::BEGIN@28
11115µs50µsTemplate::Plugins::::BEGIN@29Template::Plugins::BEGIN@29
11113µs33µsTemplate::Plugins::::BEGIN@27Template::Plugins::BEGIN@27
0000s0sTemplate::Plugins::::__ANON__[:239]Template::Plugins::__ANON__[:239]
0000s0sTemplate::Plugins::::_dumpTemplate::Plugins::_dump
0000s0sTemplate::Plugins::::_loadTemplate::Plugins::_load
0000s0sTemplate::Plugins::::fetchTemplate::Plugins::fetch
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1#============================================================= -*-Perl-*-
2#
3# Template::Plugins
4#
5# DESCRIPTION
6# Plugin provider which handles the loading of plugin modules and
7# instantiation of plugin objects.
8#
9# AUTHORS
10# Andy Wardley <abw@wardley.org>
11#
12# COPYRIGHT
13# Copyright (C) 1996-2006 Andy Wardley. All Rights Reserved.
14# Copyright (C) 1998-2000 Canon Research Centre Europe Ltd.
15#
16# This module is free software; you can redistribute it and/or
17# modify it under the same terms as Perl itself.
18#
19# REVISION
20# $Id: Plugins.pm 1179 2008-12-09 19:29:21Z abw $
21#
22#============================================================================
23
24package Template::Plugins;
25
26330µs233µs
# spent 27µs (21+6) within Template::Plugins::BEGIN@26 which was called: # once (21µs+6µs) by Template::Config::load at line 26
use strict;
# spent 27µs making 1 call to Template::Plugins::BEGIN@26 # spent 6µs making 1 call to strict::import
27355µs253µs
# spent 33µs (13+20) within Template::Plugins::BEGIN@27 which was called: # once (13µs+20µs) by Template::Config::load at line 27
use warnings;
# spent 33µs making 1 call to Template::Plugins::BEGIN@27 # spent 20µs making 1 call to warnings::import
28339µs2179µs
# spent 97µs (15+82) within Template::Plugins::BEGIN@28 which was called: # once (15µs+82µs) by Template::Config::load at line 28
use base 'Template::Base';
# spent 97µs making 1 call to Template::Plugins::BEGIN@28 # spent 82µs making 1 call to base::import
2931.23ms284µs
# spent 50µs (15+35) within Template::Plugins::BEGIN@29 which was called: # once (15µs+35µs) by Template::Config::load at line 29
use Template::Constants;
# spent 50µs making 1 call to Template::Plugins::BEGIN@29 # spent 35µs making 1 call to Exporter::import
30
3111µsour $VERSION = 2.77;
321900nsour $DEBUG = 0 unless defined $DEBUG;
3312µsour $PLUGIN_BASE = 'Template::Plugin';
34128µsour $STD_PLUGINS = {
35 'assert' => 'Template::Plugin::Assert',
36 'autoformat' => 'Template::Plugin::Autoformat',
37 'cgi' => 'Template::Plugin::CGI',
38 'datafile' => 'Template::Plugin::Datafile',
39 'date' => 'Template::Plugin::Date',
40 'debug' => 'Template::Plugin::Debug',
41 'directory' => 'Template::Plugin::Directory',
42 'dbi' => 'Template::Plugin::DBI',
43 'dumper' => 'Template::Plugin::Dumper',
44 'file' => 'Template::Plugin::File',
45 'format' => 'Template::Plugin::Format',
46 'html' => 'Template::Plugin::HTML',
47 'image' => 'Template::Plugin::Image',
48 'iterator' => 'Template::Plugin::Iterator',
49 'latex' => 'Template::Plugin::Latex',
50 'pod' => 'Template::Plugin::Pod',
51 'scalar' => 'Template::Plugin::Scalar',
52 'table' => 'Template::Plugin::Table',
53 'url' => 'Template::Plugin::URL',
54 'view' => 'Template::Plugin::View',
55 'wrap' => 'Template::Plugin::Wrap',
56 'xml' => 'Template::Plugin::XML',
57 'xmlstyle' => 'Template::Plugin::XML::Style',
58};
59
60
61#========================================================================
62# -- PUBLIC METHODS --
63#========================================================================
64
65#------------------------------------------------------------------------
66# fetch($name, \@args, $context)
67#
68# General purpose method for requesting instantiation of a plugin
69# object. The name of the plugin is passed as the first parameter.
70# The internal FACTORY lookup table is consulted to retrieve the
71# appropriate factory object or class name. If undefined, the _load()
72# method is called to attempt to load the module and return a factory
73# class/object which is then cached for subsequent use. A reference
74# to the calling context should be passed as the third parameter.
75# This is passed to the _load() class method. The new() method is
76# then called against the factory class name or prototype object to
77# instantiate a new plugin object, passing any arguments specified by
78# list reference as the second parameter. e.g. where $factory is the
79# class name 'MyClass', the new() method is called as a class method,
80# $factory->new(...), equivalent to MyClass->new(...) . Where
81# $factory is a prototype object, the new() method is called as an
82# object method, $myobject->new(...). This latter approach allows
83# plugins to act as Singletons, cache shared data, etc.
84#
85# Returns a reference to a plugin, (undef, STATUS_DECLINE) to decline
86# the request or ($error, STATUS_ERROR) on error.
87#------------------------------------------------------------------------
88
89sub fetch {
90 my ($self, $name, $args, $context) = @_;
91 my ($factory, $plugin, $error);
92
93 $self->debug("fetch($name, ",
94 defined $args ? ('[ ', join(', ', @$args), ' ]') : '<no args>', ', ',
95 defined $context ? $context : '<no context>',
96 ')') if $self->{ DEBUG };
97
98 # NOTE:
99 # the $context ref gets passed as the first parameter to all regular
100 # plugins, but not to those loaded via LOAD_PERL; to hack around
101 # this until we have a better implementation, we pass the $args
102 # reference to _load() and let it unshift the first args in the
103 # LOAD_PERL case
104
105 $args ||= [ ];
106 unshift @$args, $context;
107
108 $factory = $self->{ FACTORY }->{ $name } ||= do {
109 ($factory, $error) = $self->_load($name, $context);
110 return ($factory, $error) if $error; ## RETURN
111 $factory;
112 };
113
114 # call the new() method on the factory object or class name
115 eval {
116 if (ref $factory eq 'CODE') {
117 defined( $plugin = &$factory(@$args) )
118 || die "$name plugin failed\n";
119 }
120 else {
121 defined( $plugin = $factory->new(@$args) )
122 || die "$name plugin failed: ", $factory->error(), "\n";
123 }
124 };
125 if ($error = $@) {
126# chomp $error;
127 return $self->{ TOLERANT }
128 ? (undef, Template::Constants::STATUS_DECLINED)
129 : ($error, Template::Constants::STATUS_ERROR);
130 }
131
132 return $plugin;
133}
134
- -
137#========================================================================
138# -- PRIVATE METHODS --
139#========================================================================
140
141#------------------------------------------------------------------------
142# _init(\%config)
143#
144# Private initialisation method.
145#------------------------------------------------------------------------
146
147
# spent 25µs within Template::Plugins::_init which was called: # once (25µs+0s) by Template::Base::new at line 65 of Template/Base.pm
sub _init {
1481900ns my ($self, $params) = @_;
14912µs my ($pbase, $plugins, $factory) =
150 @$params{ qw( PLUGIN_BASE PLUGINS PLUGIN_FACTORY ) };
151
1521600ns $plugins ||= { };
153
154 # update PLUGIN_BASE to an array ref if necessary
1551200ns $pbase = [ ] unless defined $pbase;
15611µs $pbase = [ $pbase ] unless ref($pbase) eq 'ARRAY';
157
158 # add default plugin base (Template::Plugin) if set
15911µs push(@$pbase, $PLUGIN_BASE) if $PLUGIN_BASE;
160
1611900ns $self->{ PLUGIN_BASE } = $pbase;
162113µs $self->{ PLUGINS } = { %$STD_PLUGINS, %$plugins };
1631800ns $self->{ TOLERANT } = $params->{ TOLERANT } || 0;
16411µs $self->{ LOAD_PERL } = $params->{ LOAD_PERL } || 0;
1651800ns $self->{ FACTORY } = $factory || { };
16611µs $self->{ DEBUG } = ( $params->{ DEBUG } || 0 )
167 & Template::Constants::DEBUG_PLUGINS;
168
16915µs return $self;
170}
171
- -
174#------------------------------------------------------------------------
175# _load($name, $context)
176#
177# Private method which attempts to load a plugin module and determine the
178# correct factory name or object by calling the load() class method in
179# the loaded module.
180#------------------------------------------------------------------------
181
182sub _load {
183 my ($self, $name, $context) = @_;
184 my ($factory, $module, $base, $pkg, $file, $ok, $error);
185
186 if ($module = $self->{ PLUGINS }->{ $name } || $self->{ PLUGINS }->{ lc $name }) {
187 # plugin module name is explicitly stated in PLUGIN_NAME
188 $pkg = $module;
189 ($file = $module) =~ s|::|/|g;
190 $file =~ s|::|/|g;
191 $self->debug("loading $module.pm (PLUGIN_NAME)")
192 if $self->{ DEBUG };
193 $ok = eval { require "$file.pm" };
194 $error = $@;
195 }
196 else {
197 # try each of the PLUGIN_BASE values to build module name
198 ($module = $name) =~ s/\./::/g;
199
200 foreach $base (@{ $self->{ PLUGIN_BASE } }) {
201 $pkg = $base . '::' . $module;
202 ($file = $pkg) =~ s|::|/|g;
203
204 $self->debug("loading $file.pm (PLUGIN_BASE)")
205 if $self->{ DEBUG };
206
207 $ok = eval { require "$file.pm" };
208 last unless $@;
209
210 $error .= "$@\n"
211 unless ($@ =~ /^Can\'t locate $file\.pm/);
212 }
213 }
214
215 if ($ok) {
216 $self->debug("calling $pkg->load()") if $self->{ DEBUG };
217
218 $factory = eval { $pkg->load($context) };
219 $error = '';
220 if ($@ || ! $factory) {
221 $error = $@ || 'load() returned a false value';
222 }
223 }
224 elsif ($self->{ LOAD_PERL }) {
225 # fallback - is it a regular Perl module?
226 ($file = $module) =~ s|::|/|g;
227 eval { require "$file.pm" };
228 if ($@) {
229 $error = $@;
230 }
231 else {
232 # this is a regular Perl module so the new() constructor
233 # isn't expecting a $context reference as the first argument;
234 # so we construct a closure which removes it before calling
235 # $module->new(@_);
236 $factory = sub {
237 shift;
238 $module->new(@_);
239 };
240 $error = '';
241 }
242 }
243
244 if ($factory) {
245 $self->debug("$name => $factory") if $self->{ DEBUG };
246 return $factory;
247 }
248 elsif ($error) {
249 return $self->{ TOLERANT }
250 ? (undef, Template::Constants::STATUS_DECLINED)
251 : ($error, Template::Constants::STATUS_ERROR);
252 }
253 else {
254 return (undef, Template::Constants::STATUS_DECLINED);
255 }
256}
257
258
259#------------------------------------------------------------------------
260# _dump()
261#
262# Debug method which constructs and returns text representing the current
263# state of the object.
264#------------------------------------------------------------------------
265
266sub _dump {
267 my $self = shift;
268 my $output = "[Template::Plugins] {\n";
269 my $format = " %-16s => %s\n";
270 my $key;
271
272 foreach $key (qw( TOLERANT LOAD_PERL )) {
273 $output .= sprintf($format, $key, $self->{ $key });
274 }
275
276 local $" = ', ';
277 my $fkeys = join(", ", keys %{$self->{ FACTORY }});
278 my $plugins = $self->{ PLUGINS };
279 $plugins = join('', map {
280 sprintf(" $format", $_, $plugins->{ $_ });
281 } keys %$plugins);
282 $plugins = "{\n$plugins }";
283
284 $output .= sprintf($format, 'PLUGIN_BASE', "[ @{ $self->{ PLUGIN_BASE } } ]");
285 $output .= sprintf($format, 'PLUGINS', $plugins);
286 $output .= sprintf($format, 'FACTORY', $fkeys);
287 $output .= '}';
288 return $output;
289}
290
291
292114µs1;
293
294__END__
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.