← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:46 2015

Filename/mnt/catalyst/koha/C4/Context.pm
StatementsExecuted 380 statements in 20.6ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11119.1ms30.9msC4::Context::::BEGIN@100C4::Context::BEGIN@100
1118.31ms9.98msC4::Context::::BEGIN@102C4::Context::BEGIN@102
1118.03ms18.4msC4::Context::::BEGIN@101C4::Context::BEGIN@101
1115.51ms6.26msC4::Context::::BEGIN@105C4::Context::BEGIN@105
1113.50ms53.4msC4::Context::::BEGIN@106C4::Context::BEGIN@106
1113.41ms8.63msC4::Context::::BEGIN@103C4::Context::BEGIN@103
1112.51ms3.29msC4::Context::::BEGIN@104C4::Context::BEGIN@104
1112.19ms32.1msC4::Context::::BEGIN@107C4::Context::BEGIN@107
1111.79ms3.36msC4::Context::::BEGIN@21C4::Context::BEGIN@21
1111.29ms1.96msC4::Context::::KOHAVERSIONC4::Context::KOHAVERSION
111718µs737µsC4::Context::::BEGIN@19C4::Context::BEGIN@19
111599µs599µsC4::Context::::CORE:ftdirC4::Context::CORE:ftdir (opcode)
772186µs37.0msC4::Context::::preferenceC4::Context::preference
111144µs36.0msC4::Context::::_new_dbhC4::Context::_new_dbh
149498µs36.1msC4::Context::::dbhC4::Context::dbh
37373791µs49.6msC4::Context::::importC4::Context::import
1312469µs136µsC4::Context::::configC4::Context::config
131167µs67µsC4::Context::::_common_configC4::Context::_common_config
22262µs59.9msC4::Context::::newC4::Context::new
11131µs40µsC4::Context::::AUTOLOADC4::Context::AUTOLOAD
11119µs19µsC4::Context::::set_userenvC4::Context::set_userenv
21115µs59.8msC4::Context::::read_config_fileC4::Context::read_config_file
21113µs13µsC4::Context::::CORE:ftsizeC4::Context::CORE:ftsize (opcode)
11111µs17µsC4::Context::::BEGIN@20C4::Context::BEGIN@20
1119µs24µsC4::Context::::BEGIN@1220C4::Context::BEGIN@1220
1118µs35µsC4::Context::::BEGIN@108C4::Context::BEGIN@108
2227µs7µsC4::Context::::ismemcachedC4::Context::ismemcached
1116µs6µsC4::Context::::BEGIN@22C4::Context::BEGIN@22
1116µs6µsC4::Context::::_new_userenvC4::Context::_new_userenv
1116µs30µsC4::Context::::BEGIN@191C4::Context::BEGIN@191
2116µs6µsC4::Context::::userenvC4::Context::userenv
2113µs3µsC4::Context::::db_scheme2dbiC4::Context::db_scheme2dbi
1113µs3µsC4::Context::::set_contextC4::Context::set_context
1110s0sC4::Context::::CORE:substC4::Context::CORE:subst (opcode)
0000s0sC4::Context::::IsSuperLibrarianC4::Context::IsSuperLibrarian
0000s0sC4::Context::::ModZebrationsC4::Context::ModZebrations
0000s0sC4::Context::::ZconnC4::Context::Zconn
0000s0sC4::Context::::_new_ZconnC4::Context::_new_Zconn
0000s0sC4::Context::::_new_marcfromkohafieldC4::Context::_new_marcfromkohafield
0000s0sC4::Context::::_new_queryparserC4::Context::_new_queryparser
0000s0sC4::Context::::_new_stopwordsC4::Context::_new_stopwords
0000s0sC4::Context::::_unset_userenvC4::Context::_unset_userenv
0000s0sC4::Context::::boolean_preferenceC4::Context::boolean_preference
0000s0sC4::Context::::clear_syspref_cacheC4::Context::clear_syspref_cache
0000s0sC4::Context::::disable_syspref_cacheC4::Context::disable_syspref_cache
0000s0sC4::Context::::enable_syspref_cacheC4::Context::enable_syspref_cache
0000s0sC4::Context::::final_linear_versionC4::Context::final_linear_version
0000s0sC4::Context::::get_shelves_userenvC4::Context::get_shelves_userenv
0000s0sC4::Context::::get_versionsC4::Context::get_versions
0000s0sC4::Context::::handle_errorsC4::Context::handle_errors
0000s0sC4::Context::::marcfromkohafieldC4::Context::marcfromkohafield
0000s0sC4::Context::::memcachedC4::Context::memcached
0000s0sC4::Context::::new_dbhC4::Context::new_dbh
0000s0sC4::Context::::queryparserC4::Context::queryparser
0000s0sC4::Context::::restore_contextC4::Context::restore_context
0000s0sC4::Context::::restore_dbhC4::Context::restore_dbh
0000s0sC4::Context::::set_dbhC4::Context::set_dbh
0000s0sC4::Context::::set_preferenceC4::Context::set_preference
0000s0sC4::Context::::set_shelves_userenvC4::Context::set_shelves_userenv
0000s0sC4::Context::::stopwordsC4::Context::stopwords
0000s0sC4::Context::::tzC4::Context::tz
0000s0sC4::Context::::zebraconfigC4::Context::zebraconfig
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package C4::Context;
2# Copyright 2002 Katipo Communications
3#
4# This file is part of Koha.
5#
6# Koha is free software; you can redistribute it and/or modify it under the
7# terms of the GNU General Public License as published by the Free Software
8# Foundation; either version 2 of the License, or (at your option) any later
9# version.
10#
11# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
12# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
14#
15# You should have received a copy of the GNU General Public License along
16# with Koha; if not, write to the Free Software Foundation, Inc.,
17# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
18
19252µs2755µs
# spent 737µs (718+19) within C4::Context::BEGIN@19 which was called: # once (718µs+19µs) by main::BEGIN@72 at line 19
use strict;
# spent 737µs making 1 call to C4::Context::BEGIN@19 # spent 19µs making 1 call to strict::import
20239µs224µs
# spent 17µs (11+7) within C4::Context::BEGIN@20 which was called: # once (11µs+7µs) by main::BEGIN@72 at line 20
use warnings;
# spent 17µs making 1 call to C4::Context::BEGIN@20 # spent 7µs making 1 call to warnings::import
2121.66ms23.46ms
# spent 3.36ms (1.79+1.58) within C4::Context::BEGIN@21 which was called: # once (1.79ms+1.58ms) by main::BEGIN@72 at line 21
use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached);
# spent 3.36ms making 1 call to C4::Context::BEGIN@21 # spent 99µs making 1 call to vars::import
22
# spent 6µs within C4::Context::BEGIN@22 which was called: # once (6µs+0s) by main::BEGIN@72 at line 98
BEGIN {
231700ns if ($ENV{'HTTP_USER_AGENT'}) {
24 require CGI::Carp;
25 # FIXME for future reference, CGI::Carp doc says
26 # "Note that fatalsToBrowser does not work with mod_perl version 2.0 and higher."
27 import CGI::Carp qw(fatalsToBrowser);
28 sub handle_errors {
29 my $msg = shift;
30 my $debug_level;
31 eval {C4::Context->dbh();};
32 if ($@){
33 $debug_level = 1;
34 }
35 else {
36 $debug_level = C4::Context->preference("DebugLevel");
37 }
38
39 print q(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
40 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
41 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
42 <head><title>Koha Error</title></head>
43 <body>
44 );
45 if ($debug_level eq "2"){
46 # debug 2 , print extra info too.
47 my %versions = get_versions();
48
49 # a little example table with various version info";
50 print "
51 <h1>Koha error</h1>
52 <p>The following fatal error has occurred:</p>
53 <pre><code>$msg</code></pre>
54 <table>
55 <tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
56 <tr><th>Koha</th><td> $versions{kohaVersion}</td></tr>
57 <tr><th>Koha DB</th><td> $versions{kohaDbVersion}</td></tr>
58 <tr><th>MySQL</th><td> $versions{mysqlVersion}</td></tr>
59 <tr><th>OS</th><td> $versions{osVersion}</td></tr>
60 <tr><th>Perl</th><td> $versions{perlVersion}</td></tr>
61 </table>";
62
63 } elsif ($debug_level eq "1"){
64 print "
65 <h1>Koha error</h1>
66 <p>The following fatal error has occurred:</p>
67 <pre><code>$msg</code></pre>";
68 } else {
69 print "<p>production mode - trapped fatal error</p>";
70 }
71 print "</body></html>";
72 }
73 #CGI::Carp::set_message(\&handle_errors);
74 ## give a stack backtrace if KOHA_BACKTRACES is set
75 ## can't rely on DebugLevel for this, as we're not yet connected
76 if ($ENV{KOHA_BACKTRACES}) {
77 $main::SIG{__DIE__} = \&CGI::Carp::confess;
78 }
79 } # else there is no browser to send fatals to!
80
81 # Check if there are memcached servers set
821400ns $servers = $ENV{'MEMCACHED_SERVERS'};
831100ns if ($servers) {
84 # Load required libraries and create the memcached object
85 require Cache::Memcached;
86 $memcached = Cache::Memcached->new({
87 servers => [ $servers ],
88 debug => 0,
89 compress_threshold => 10_000,
90 expire_time => 600,
91 namespace => $ENV{'MEMCACHED_NAMESPACE'} || 'koha'
92 });
93 # Verify memcached available (set a variable and test the output)
94 $ismemcached = $memcached->set('ismemcached','1');
95 }
96
97111µs $VERSION = '3.07.00.049';
98127µs16µs}
# spent 6µs making 1 call to C4::Context::BEGIN@22
99
10021.15ms231.0ms
# spent 30.9ms (19.1+11.9) within C4::Context::BEGIN@100 which was called: # once (19.1ms+11.9ms) by main::BEGIN@72 at line 100
use DBI;
# spent 30.9ms making 1 call to C4::Context::BEGIN@100 # spent 26µs making 1 call to Exporter::import
10121.30ms118.4ms
# spent 18.4ms (8.03+10.4) within C4::Context::BEGIN@101 which was called: # once (8.03ms+10.4ms) by main::BEGIN@72 at line 101
use ZOOM;
# spent 18.4ms making 1 call to C4::Context::BEGIN@101
10221.71ms210.00ms
# spent 9.98ms (8.31+1.67) within C4::Context::BEGIN@102 which was called: # once (8.31ms+1.67ms) by main::BEGIN@72 at line 102
use XML::Simple;
# spent 9.98ms making 1 call to C4::Context::BEGIN@102 # spent 20µs making 1 call to XML::Simple::import
10323.53ms28.66ms
# spent 8.63ms (3.41+5.22) within C4::Context::BEGIN@103 which was called: # once (3.41ms+5.22ms) by main::BEGIN@72 at line 103
use C4::Boolean;
# spent 8.63ms making 1 call to C4::Context::BEGIN@103 # spent 24µs making 1 call to Exporter::import
10422.63ms23.39ms
# spent 3.29ms (2.51+785µs) within C4::Context::BEGIN@104 which was called: # once (2.51ms+785µs) by main::BEGIN@72 at line 104
use C4::Debug;
# spent 3.29ms making 1 call to C4::Context::BEGIN@104 # spent 102µs making 1 call to Exporter::import
1052816µs16.26ms
# spent 6.26ms (5.51+755µs) within C4::Context::BEGIN@105 which was called: # once (5.51ms+755µs) by main::BEGIN@72 at line 105
use POSIX ();
# spent 6.26ms making 1 call to C4::Context::BEGIN@105
10621.03ms153.4ms
# spent 53.4ms (3.50+49.9) within C4::Context::BEGIN@106 which was called: # once (3.50ms+49.9ms) by main::BEGIN@72 at line 106
use DateTime::TimeZone;
# spent 53.4ms making 1 call to C4::Context::BEGIN@106
1072783µs232.1ms
# spent 32.1ms (2.19+29.9) within C4::Context::BEGIN@107 which was called: # once (2.19ms+29.9ms) by main::BEGIN@72 at line 107
use Module::Load::Conditional qw(can_load);
# spent 32.1ms making 1 call to C4::Context::BEGIN@107 # spent 35µs making 1 call to Exporter::import
108257µs262µs
# spent 35µs (8+27) within C4::Context::BEGIN@108 which was called: # once (8µs+27µs) by main::BEGIN@72 at line 108
use Carp;
# spent 35µs making 1 call to C4::Context::BEGIN@108 # spent 27µs making 1 call to Exporter::import
109
110=head1 NAME
111
112C4::Context - Maintain and manipulate the context of a Koha script
113
114=head1 SYNOPSIS
115
116 use C4::Context;
117
118 use C4::Context("/path/to/koha-conf.xml");
119
120 $config_value = C4::Context->config("config_variable");
121
122 $koha_preference = C4::Context->preference("preference");
123
124 $db_handle = C4::Context->dbh;
125
126 $Zconn = C4::Context->Zconn;
127
128 $stopwordhash = C4::Context->stopwords;
129
130=head1 DESCRIPTION
131
132When a Koha script runs, it makes use of a certain number of things:
133configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
134databases, and so forth. These things make up the I<context> in which
135the script runs.
136
137This module takes care of setting up the context for a script:
138figuring out which configuration file to load, and loading it, opening
139a connection to the right database, and so forth.
140
141Most scripts will only use one context. They can simply have
142
143 use C4::Context;
144
145at the top.
146
147Other scripts may need to use several contexts. For instance, if a
148library has two databases, one for a certain collection, and the other
149for everything else, it might be necessary for a script to use two
150different contexts to search both databases. Such scripts should use
151the C<&set_context> and C<&restore_context> functions, below.
152
153By default, C4::Context reads the configuration from
154F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
155environment variable to the pathname of a configuration file to use.
156
157=head1 METHODS
158
159=cut
160
161#'
162# In addition to what is said in the POD above, a Context object is a
163# reference-to-hash with the following fields:
164#
165# config
166# A reference-to-hash whose keys and values are the
167# configuration variables and values specified in the config
168# file (/etc/koha/koha-conf.xml).
169# dbh
170# A handle to the appropriate database for this context.
171# dbh_stack
172# Used by &set_dbh and &restore_dbh to hold other database
173# handles for this context.
174# Zconn
175# A connection object for the Zebra server
176
177# Koha's main configuration file koha-conf.xml
178# is searched for according to this priority list:
179#
180# 1. Path supplied via use C4::Context '/path/to/koha-conf.xml'
181# 2. Path supplied in KOHA_CONF environment variable.
182# 3. Path supplied in INSTALLED_CONFIG_FNAME, as long
183# as value has changed from its default of
184# '__KOHA_CONF_DIR__/koha-conf.xml', as happens
185# when Koha is installed in 'standard' or 'single'
186# mode.
187# 4. Path supplied in CONFIG_FNAME.
188#
189# The first entry that refers to a readable file is used.
190
19122.07ms253µs
# spent 30µs (6+24) within C4::Context::BEGIN@191 which was called: # once (6µs+24µs) by main::BEGIN@72 at line 191
use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
# spent 30µs making 1 call to C4::Context::BEGIN@191 # spent 24µs making 1 call to constant::import
192 # Default config file, if none is specified
193
1941700nsmy $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml';
195 # path to config file set by installer
196 # __KOHA_CONF_DIR__ is set by rewrite-confg.PL
197 # when Koha is installed in 'standard' or 'single'
198 # mode. If Koha was installed in 'dev' mode,
199 # __KOHA_CONF_DIR__ is *not* rewritten; instead
200 # developers should set the KOHA_CONF environment variable
201
2021200ns$context = undef; # Initially, no context is set
2031700ns@context_stack = (); # Initially, no saved contexts
204
205
206=head2 KOHAVERSION
207
208returns the kohaversion stored in kohaversion.pl file
209
210=cut
211
212
# spent 1.96ms (1.29+667µs) within C4::Context::KOHAVERSION which was called: # once (1.29ms+667µs) by C4::Auth::check_api_auth at line 1170 of C4/Auth.pm
sub KOHAVERSION {
21318µs140µs my $cgidir = C4::Context->intranetdir;
# spent 40µs making 1 call to C4::Context::AUTOLOAD
214
215 # Apparently the GIT code does not run out of a CGI-BIN subdirectory
216 # but distribution code does? (Stan, 1jan08)
2171609µs1599µs if(-d $cgidir . "/cgi-bin"){
# spent 599µs making 1 call to C4::Context::CORE:ftdir
218 my $cgidir .= "/cgi-bin";
219 }
220
22111.10ms do $cgidir."/kohaversion.pl" || die "NO $cgidir/kohaversion.pl";
22215µs13µs return kohaversion();
# spent 3µs making 1 call to C4::Context::kohaversion
223}
224
225=head2 final_linear_version
226
227Returns the version number of the final update to run in updatedatabase.pl.
228This number is equal to the version in kohaversion.pl
229
230=cut
231
232sub final_linear_version {
233 return KOHAVERSION;
234}
235
236=head2 read_config_file
237
238Reads the specified Koha config file.
239
240Returns an object containing the configuration variables. The object's
241structure is a bit complex to the uninitiated ... take a look at the
242koha-conf.xml file as well as the XML::Simple documentation for details. Or,
243here are a few examples that may give you what you need:
244
245The simple elements nested within the <config> element:
246
247 my $pass = $koha->{'config'}->{'pass'};
248
249The <listen> elements:
250
251 my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};
252
253The elements nested within the <server> element:
254
255 my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};
256
257Returns undef in case of error.
258
259=cut
260
261
# spent 59.8ms (15µs+59.8) within C4::Context::read_config_file which was called 2 times, avg 29.9ms/call: # 2 times (15µs+59.8ms) by C4::Context::new at line 387, avg 29.9ms/call
sub read_config_file { # Pass argument naming config file to read
262210µs259.8ms my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
# spent 59.8ms making 2 calls to XML::Simple::XMLin, avg 29.9ms/call
263
2642700ns if ($ismemcached) {
265 $memcached->set('kohaconf',$koha);
266 }
267
26828µs return $koha; # Return value: ref-to-hash holding the configuration
269}
270
271=head2 ismemcached
272
273Returns the value of the $ismemcached variable (0/1)
274
275=cut
276
277
# spent 7µs within C4::Context::ismemcached which was called 2 times, avg 4µs/call: # once (4µs+0s) by C4::Reserves::BEGIN@27 at line 142 of C4/Biblio.pm # once (3µs+0s) by C4::Templates::BEGIN@35 at line 29 of C4/Languages.pm
sub ismemcached {
278215µs return $ismemcached;
279}
280
281=head2 memcached
282
283If $ismemcached is true, returns the $memcache variable.
284Returns undef otherwise
285
286=cut
287
288sub memcached {
289 if ($ismemcached) {
290 return $memcached;
291 } else {
292 return;
293 }
294}
295
296# db_scheme2dbi
297# Translates the full text name of a database into de appropiate dbi name
298#
299
# spent 3µs within C4::Context::db_scheme2dbi which was called 2 times, avg 2µs/call: # 2 times (3µs+0s) by C4::Context::new at line 404, avg 2µs/call
sub db_scheme2dbi {
3002600ns my $name = shift;
301 # for instance, we support only mysql, so don't care checking
30224µs return "mysql";
303 for ($name) {
304# FIXME - Should have other databases.
305 if (/mysql/) { return("mysql"); }
306 if (/Postgres|Pg|PostgresSQL/) { return("Pg"); }
307 if (/oracle/) { return("Oracle"); }
308 }
309 return; # Just in case
310}
311
312
# spent 49.6ms (91µs+49.5) within C4::Context::import which was called 37 times, avg 1.34ms/call: # once (9µs+49.5ms) by main::BEGIN@72 at line 72 of svc/members/upsert # once (3µs+0s) by C4::Circulation::BEGIN@25 at line 25 of C4/Circulation.pm # once (3µs+0s) by C4::Members::Attributes::BEGIN@24 at line 24 of C4/Members/Attributes.pm # once (3µs+0s) by C4::Auth::BEGIN@28 at line 28 of C4/Auth.pm # once (3µs+0s) by Koha::Calendar::BEGIN@9 at line 9 of Koha/Calendar.pm # once (3µs+0s) by C4::Accounts::BEGIN@23 at line 23 of C4/Accounts.pm # once (3µs+0s) by C4::Koha::BEGIN@26 at line 26 of C4/Koha.pm # once (3µs+0s) by C4::Log::BEGIN@27 at line 27 of C4/Log.pm # once (3µs+0s) by C4::Charset::BEGIN@25 at line 25 of C4/Charset.pm # once (3µs+0s) by C4::Languages::BEGIN@25 at line 25 of C4/Languages.pm # once (2µs+0s) by C4::Branch::BEGIN@22 at line 22 of C4/Branch.pm # once (2µs+0s) by C4::Linker::BEGIN@48 at line 48 of C4/Linker.pm # once (2µs+0s) by C4::Stats::BEGIN@24 at line 24 of C4/Stats.pm # once (2µs+0s) by Koha::Borrower::Debarments::BEGIN@22 at line 22 of Koha/Borrower/Debarments.pm # once (2µs+0s) by C4::Items::BEGIN@25 at line 25 of C4/Items.pm # once (2µs+0s) by Koha::DateUtils::BEGIN@24 at line 24 of Koha/DateUtils.pm # once (2µs+0s) by C4::ItemCirculationAlertPreference::BEGIN@22 at line 22 of C4/ItemCirculationAlertPreference.pm # once (2µs+0s) by C4::Output::BEGIN@33 at line 33 of C4/Output.pm # once (2µs+0s) by C4::NewsChannels::BEGIN@23 at line 23 of C4/NewsChannels.pm # once (2µs+0s) by C4::OAI::Sets::BEGIN@33 at line 33 of C4/OAI/Sets.pm # once (2µs+0s) by C4::Auth_with_cas::BEGIN@24 at line 24 of C4/Auth_with_cas.pm # once (2µs+0s) by C4::Members::Messaging::BEGIN@22 at line 22 of C4/Members/Messaging.pm # once (2µs+0s) by C4::ClassSource::BEGIN@24 at line 24 of C4/ClassSource.pm # once (2µs+0s) by C4::Templates::BEGIN@37 at line 37 of C4/Templates.pm # once (2µs+0s) by C4::Overdues::BEGIN@27 at line 27 of C4/Overdues.pm # once (2µs+0s) by C4::Members::BEGIN@25 at line 25 of C4/Members.pm # once (2µs+0s) by C4::VirtualShelves::BEGIN@24 at line 24 of C4/VirtualShelves.pm # once (2µs+0s) by C4::SQLHelper::BEGIN@24 at line 24 of C4/SQLHelper.pm # once (2µs+0s) by C4::Budgets::BEGIN@22 at line 22 of C4/Budgets.pm # once (2µs+0s) by C4::SMS::BEGIN@38 at line 38 of C4/SMS.pm # once (2µs+0s) by C4::Members::AttributeTypes::BEGIN@22 at line 22 of C4/Members/AttributeTypes.pm # once (2µs+0s) by C4::Reserves::BEGIN@26 at line 26 of C4/Reserves.pm # once (2µs+0s) by C4::ClassSortRoutine::BEGIN@25 at line 25 of C4/ClassSortRoutine.pm # once (2µs+0s) by C4::ItemType::BEGIN@23 at line 23 of C4/ItemType.pm # once (2µs+0s) by C4::Message::BEGIN@24 at line 24 of C4/Message.pm # once (1µs+0s) by C4::Category::BEGIN@23 at line 23 of C4/Category.pm # once (1µs+0s) by C4::Dates::BEGIN@25 at line 25 of C4/Dates.pm
sub import {
313 # Create the default context ($C4::Context::Context)
314 # the first time the module is called
315 # (a config file can be optionaly passed)
316
317 # default context allready exists?
31837212µs return if $context;
319
320 # no ? so load it!
3211500ns my ($pkg,$config_file) = @_ ;
32211µs149.5ms my $new_ctx = __PACKAGE__->new($config_file);
# spent 49.5ms making 1 call to C4::Context::new
3231300ns return unless $new_ctx;
324
325 # if successfully loaded, use it by default
32612µs13µs $new_ctx->set_context;
# spent 3µs making 1 call to C4::Context::set_context
32712µs 1;
328}
329
330=head2 new
331
332 $context = new C4::Context;
333 $context = new C4::Context("/path/to/koha-conf.xml");
334
335Allocates a new context. Initializes the context from the specified
336file, which defaults to either the file given by the C<$KOHA_CONF>
337environment variable, or F</etc/koha/koha-conf.xml>.
338
339It saves the koha-conf.xml values in the declared memcached server(s)
340if currently available and uses those values until them expire and
341re-reads them.
342
343C<&new> does not set this context as the new default context; for
344that, use C<&set_context>.
345
346=cut
347
348#'
349# Revision History:
350# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
351
# spent 59.9ms (62µs+59.9) within C4::Context::new which was called 2 times, avg 30.0ms/call: # once (30µs+49.5ms) by C4::Context::import at line 322 # once (31µs+10.4ms) by C4::Auth::BEGIN@39 at line 39 of C4/Auth_with_cas.pm
sub new {
35221µs my $class = shift;
3532300ns my $conf_fname = shift; # Config file to load
35421µs my $self = {};
355
356 # check that the specified config file exists and is not empty
35721µs undef $conf_fname unless
358 (defined $conf_fname && -s $conf_fname);
359 # Figure out a good config file to load if none was specified.
36021µs if (!defined($conf_fname))
361 {
362 # If the $KOHA_CONF environment variable is set, use
363 # that. Otherwise, use the built-in default.
364228µs213µs if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) {
# spent 13µs making 2 calls to C4::Context::CORE:ftsize, avg 7µs/call
365 $conf_fname = $ENV{"KOHA_CONF"};
366 } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) {
367 # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above
368 # regex to anything else -- don't want installer to rewrite it
369 $conf_fname = $INSTALLED_CONFIG_FNAME;
370 } elsif (-s CONFIG_FNAME) {
371 $conf_fname = CONFIG_FNAME;
372 } else {
373 warn "unable to locate Koha configuration file koha-conf.xml";
374 return;
375 }
376 }
377
37822µs if ($ismemcached) {
379 # retreive from memcached
380 $self = $memcached->get('kohaconf');
381 if (not defined $self) {
382 # not in memcached yet
383 $self = read_config_file($conf_fname);
384 }
385 } else {
386 # non-memcached env, read from file
38724µs259.8ms $self = read_config_file($conf_fname);
# spent 59.8ms making 2 calls to C4::Context::read_config_file, avg 29.9ms/call
388 }
389
39022µs $self->{"config_file"} = $conf_fname;
39121µs warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
3922600ns return if !defined($self->{"config"});
393
3942700ns $self->{"dbh"} = undef; # Database handle
3952700ns $self->{"Zconn"} = undef; # Zebra Connections
39622µs $self->{"stopwords"} = undef; # stopwords list
3972600ns $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
3982900ns $self->{"userenv"} = undef; # User env
39921µs $self->{"activeuser"} = undef; # current active user
40021µs $self->{"shelves"} = undef;
40121µs $self->{tz} = undef; # local timezone object
402
40323µs bless $self, $class;
404211µs419µs $self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
# spent 15µs making 2 calls to C4::Context::config, avg 8µs/call # spent 3µs making 2 calls to C4::Context::db_scheme2dbi, avg 2µs/call
40527µs return $self;
406}
407
408=head2 set_context
409
410 $context = new C4::Context;
411 $context->set_context();
412or
413 set_context C4::Context $context;
414
415 ...
416 restore_context C4::Context;
417
418In some cases, it might be necessary for a script to use multiple
419contexts. C<&set_context> saves the current context on a stack, then
420sets the context to C<$context>, which will be used in future
421operations. To restore the previous context, use C<&restore_context>.
422
423=cut
424
425#'
426sub set_context
427
# spent 3µs within C4::Context::set_context which was called: # once (3µs+0s) by C4::Context::import at line 326
{
4281300ns my $self = shift;
4291200ns my $new_context; # The context to set
430
431 # Figure out whether this is a class or instance method call.
432 #
433 # We're going to make the assumption that control got here
434 # through valid means, i.e., that the caller used an instance
435 # or class method call, and that control got here through the
436 # usual inheritance mechanisms. The caller can, of course,
437 # break this assumption by playing silly buggers, but that's
438 # harder to do than doing it properly, and harder to check
439 # for.
4401800ns if (ref($self) eq "")
441 {
442 # Class method. The new context is the next argument.
443 $new_context = shift;
444 } else {
445 # Instance method. The new context is $self.
4461300ns $new_context = $self;
447 }
448
449 # Save the old context, if any, on the stack
4501500ns push @context_stack, $context if defined($context);
451
452 # Set the new context
45312µs $context = $new_context;
454}
455
456=head2 restore_context
457
458 &restore_context;
459
460Restores the context set by C<&set_context>.
461
462=cut
463
464#'
465sub restore_context
466{
467 my $self = shift;
468
469 if ($#context_stack < 0)
470 {
471 # Stack underflow.
472 die "Context stack underflow";
473 }
474
475 # Pop the old context and set it.
476 $context = pop @context_stack;
477
478 # FIXME - Should this return something, like maybe the context
479 # that was current when this was called?
480}
481
482=head2 config
483
484 $value = C4::Context->config("config_variable");
485
486 $value = C4::Context->config_variable;
487
488Returns the value of a variable specified in the configuration file
489from which the current context was created.
490
491The second form is more compact, but of course may conflict with
492method names. If there is a configuration variable called "new", then
493C<C4::Config-E<gt>new> will not return it.
494
495=cut
496
497
# spent 67µs within C4::Context::_common_config which was called 13 times, avg 5µs/call: # 13 times (67µs+0s) by C4::Context::config at line 511, avg 5µs/call
sub _common_config {
498136µs my $var = shift;
499133µs my $term = shift;
5001327µs return if !defined($context->{$term});
501 # Presumably $self->{$term} might be
502 # undefined if the config file given to &new
503 # didn't exist, and the caller didn't bother
504 # to check the return value.
505
506 # Return the value of the requested config variable
5071259µs return $context->{$term}->{$var};
508}
509
510
# spent 136µs (69+67) within C4::Context::config which was called 13 times, avg 10µs/call: # 2 times (9µs+6µs) by C4::Context::new at line 404, avg 8µs/call # once (9µs+20µs) by C4::Auth::haspermission at line 1748 of C4/Auth.pm # once (10µs+6µs) by C4::Members::BEGIN@35 at line 31 of C4/SQLHelper.pm # once (8µs+7µs) by C4::Auth::BEGIN@39 at line 55 of C4/Auth.pm # once (5µs+5µs) by C4::Auth::BEGIN@29 at line 208 of C4/Templates.pm # once (5µs+4µs) by C4::Context::AUTOLOAD at line 668 # once (4µs+4µs) by C4::Context::_new_dbh at line 799 # once (4µs+3µs) by C4::Context::_new_dbh at line 807 # once (4µs+2µs) by C4::Context::_new_dbh at line 809 # once (3µs+3µs) by C4::Context::_new_dbh at line 805 # once (3µs+3µs) by C4::Context::_new_dbh at line 806 # once (4µs+2µs) by C4::Context::_new_dbh at line 808
sub config {
5111374µs1367µs return _common_config($_[1],'config');
# spent 67µs making 13 calls to C4::Context::_common_config, avg 5µs/call
512}
513sub zebraconfig {
514 return _common_config($_[1],'server');
515}
516sub ModZebrations {
517 return _common_config($_[1],'serverinfo');
518}
519
520=head2 preference
521
522 $sys_preference = C4::Context->preference('some_variable');
523
524Looks up the value of the given system preference in the
525systempreferences table of the Koha database, and returns it. If the
526variable is not set or does not exist, undef is returned.
527
528In case of an error, this may return 0.
529
530Note: It is impossible to tell the difference between system
531preferences which do not exist, and those whose values are set to NULL
532with this method.
533
534=cut
535
536# FIXME: running this under mod_perl will require a means of
537# flushing the caching mechanism.
538
5391200nsmy %sysprefs;
5401200nsmy $use_syspref_cache = 1;
541
542
# spent 37.0ms (186µs+36.8) within C4::Context::preference which was called 7 times, avg 5.29ms/call: # once (56µs+36.2ms) by C4::Auth::BEGIN@39 at line 56 of C4/Auth.pm # once (30µs+164µs) by C4::Auth::BEGIN@39 at line 52 of C4/Auth_with_cas.pm # once (26µs+141µs) by C4::Auth::_timeout_syspref at line 618 of C4/Auth.pm # once (30µs+125µs) by C4::Auth::BEGIN@39 at line 57 of C4/Auth.pm # once (22µs+99µs) by C4::Auth::get_session at line 1503 of C4/Auth.pm # once (19µs+84µs) by C4::Auth::check_api_auth at line 1166 of C4/Auth.pm # once (4µs+0s) by C4::Auth::check_api_auth at line 1172 of C4/Auth.pm
sub preference {
54374µs my $self = shift;
54472µs my $var = shift; # The system preference to return
545
546713µs if ($use_syspref_cache && exists $sysprefs{lc $var}) {
547 return $sysprefs{lc $var};
548 }
549
550613µs636.1ms my $dbh = C4::Context->dbh or return 0;
# spent 36.1ms making 6 calls to C4::Context::dbh, avg 6.01ms/call
551
5526800ns my $value;
5536114µs if ( defined $ENV{"OVERRIDE_SYSPREF_$var"} ) {
554 $value = $ENV{"OVERRIDE_SYSPREF_$var"};
555 } else {
556 # Look up systempreferences.variable==$var
55762µs my $sql = q{
558 SELECT value
559 FROM systempreferences
560 WHERE variable = ?
561 LIMIT 1
562 };
5636487µs181.26ms $value = $dbh->selectrow_array( $sql, {}, lc $var );
# spent 713µs making 6 calls to DBI::db::selectrow_array, avg 119µs/call # spent 286µs making 6 calls to DBI::db::prepare, avg 48µs/call # spent 261µs making 6 calls to DBD::mysql::db::prepare, avg 43µs/call
564 }
565
566611µs1832µs $sysprefs{lc $var} = $value;
# spent 23µs making 12 calls to DBI::common::DESTROY, avg 2µs/call # spent 9µs making 6 calls to DBD::_mem::common::DESTROY, avg 2µs/call
567624µs return $value;
568}
569
570sub boolean_preference {
571 my $self = shift;
572 my $var = shift; # The system preference to return
573 my $it = preference($self, $var);
574 return defined($it)? C4::Boolean::true_p($it): undef;
575}
576
577=head2 enable_syspref_cache
578
579 C4::Context->enable_syspref_cache();
580
581Enable the in-memory syspref cache used by C4::Context. This is the
582default behavior.
583
584=cut
585
586sub enable_syspref_cache {
587 my ($self) = @_;
588 $use_syspref_cache = 1;
589}
590
591=head2 disable_syspref_cache
592
593 C4::Context->disable_syspref_cache();
594
595Disable the in-memory syspref cache used by C4::Context. This should be
596used with Plack and other persistent environments.
597
598=cut
599
600sub disable_syspref_cache {
601 my ($self) = @_;
602 $use_syspref_cache = 0;
603 $self->clear_syspref_cache();
604}
605
606=head2 clear_syspref_cache
607
608 C4::Context->clear_syspref_cache();
609
610cleans the internal cache of sysprefs. Please call this method if
611you update the systempreferences table. Otherwise, your new changes
612will not be seen by this process.
613
614=cut
615
616sub clear_syspref_cache {
617 %sysprefs = ();
618}
619
620=head2 set_preference
621
622 C4::Context->set_preference( $variable, $value );
623
624This updates a preference's value both in the systempreferences table and in
625the sysprefs cache.
626
627=cut
628
629sub set_preference {
630 my $self = shift;
631 my $var = lc(shift);
632 my $value = shift;
633
634 my $dbh = C4::Context->dbh or return 0;
635
636 my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var );
637
638 $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
639
640 my $sth = $dbh->prepare( "
641 INSERT INTO systempreferences
642 ( variable, value )
643 VALUES( ?, ? )
644 ON DUPLICATE KEY UPDATE value = VALUES(value)
645 " );
646
647 if($sth->execute( $var, $value )) {
648 $sysprefs{$var} = $value;
649 }
650 $sth->finish;
651}
652
653# AUTOLOAD
654# This implements C4::Config->foo, and simply returns
655# C4::Context->config("foo"), as described in the documentation for
656# &config, above.
657
658# FIXME - Perhaps this should be extended to check &config first, and
659# then &preference if that fails. OTOH, AUTOLOAD could lead to crappy
660# code, so it'd probably be best to delete it altogether so as not to
661# encourage people to use it.
662sub AUTOLOAD
663
# spent 40µs (31+10) within C4::Context::AUTOLOAD which was called: # once (31µs+10µs) by C4::Context::KOHAVERSION at line 213
{
6641500ns my $self = shift;
665
666125µs10s $AUTOLOAD =~ s/.*:://; # Chop off the package name,
# spent 0s making 1 call to C4::Context::CORE:subst
667 # leaving only the function name.
66815µs110µs return $self->config($AUTOLOAD);
# spent 10µs making 1 call to C4::Context::config
669}
670
671=head2 Zconn
672
673 $Zconn = C4::Context->Zconn
674
675Returns a connection to the Zebra database for the current
676context. If no connection has yet been made, this method
677creates one and connects.
678
679C<$self>
680
681C<$server> one of the servers defined in the koha-conf.xml file
682
683C<$async> whether this is a asynchronous connection
684
685C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
686
687
688=cut
689
690sub Zconn {
691 my $self=shift;
692 my $server=shift;
693 my $async=shift;
694 my $auth=shift;
695 my $piggyback=shift;
696 my $syntax=shift;
697# commented out because this makes plack act funny on OPAC searches.
698# if ( defined($context->{"Zconn"}->{$server}) && (0 == $context->{"Zconn"}->{$server}->errcode()) ) {
699# return $context->{"Zconn"}->{$server};
700 # No connection object or it died. Create one.
701# }else {
702 # release resources if we're closing a connection and making a new one
703 # FIXME: this needs to be smarter -- an error due to a malformed query or
704 # a missing index does not necessarily require us to close the connection
705 # and make a new one, particularly for a batch job. However, at
706 # first glance it does not look like there's a way to easily check
707 # the basic health of a ZOOM::Connection
708 $context->{"Zconn"}->{$server}->destroy() if defined($context->{"Zconn"}->{$server});
709 $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
710 $context->{ Zconn }->{$server}->option(
711 preferredRecordSyntax => C4::Context->preference("marcflavour") );
712 return $context->{"Zconn"}->{$server};
713# }
714}
715
716=head2 _new_Zconn
717
718$context->{"Zconn"} = &_new_Zconn($server,$async);
719
720Internal function. Creates a new database connection from the data given in the current context and returns it.
721
722C<$server> one of the servers defined in the koha-conf.xml file
723
724C<$async> whether this is a asynchronous connection
725
726C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
727
728=cut
729
730sub _new_Zconn {
731 my ($server,$async,$auth,$piggyback,$syntax) = @_;
732
733 my $tried=0; # first attempt
734 my $Zconn; # connection object
735 $server = "biblioserver" unless $server;
736 $syntax = "usmarc" unless $syntax;
737
738 my $host = $context->{'listen'}->{$server}->{'content'};
739 my $servername = $context->{"config"}->{$server};
740 my $user = $context->{"serverinfo"}->{$server}->{"user"};
741 my $password = $context->{"serverinfo"}->{$server}->{"password"};
742 $auth = 1 if($user && $password);
743 retry:
744 eval {
745 # set options
746 my $o = new ZOOM::Options();
747 $o->option(user=>$user) if $auth;
748 $o->option(password=>$password) if $auth;
749 $o->option(async => 1) if $async;
750 $o->option(count => $piggyback) if $piggyback;
751 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
752 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
753 $o->option(preferredRecordSyntax => $syntax);
754 $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief'
755 $o->option(databaseName => ($servername?$servername:"biblios"));
756
757 # create a new connection object
758 $Zconn= create ZOOM::Connection($o);
759
760 # forge to server
761 $Zconn->connect($host, 0);
762
763 # check for errors and warn
764 if ($Zconn->errcode() !=0) {
765 warn "something wrong with the connection: ". $Zconn->errmsg();
766 }
767
768 };
769# if ($@) {
770# # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues
771# # Also, I'm skeptical about whether it's the best approach
772# warn "problem with Zebra";
773# if ( C4::Context->preference("ManageZebra") ) {
774# if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra
775# $tried=1;
776# warn "trying to restart Zebra";
777# my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log");
778# goto "retry";
779# } else {
780# warn "Error ", $@->code(), ": ", $@->message(), "\n";
781# $Zconn="error";
782# return $Zconn;
783# }
784# }
785# }
786 return $Zconn;
787}
788
789# _new_dbh
790# Internal helper function (not a method!). This creates a new
791# database connection from the data given in the current context, and
792# returns it.
793sub _new_dbh
794
# spent 36.0ms (144µs+35.9) within C4::Context::_new_dbh which was called: # once (144µs+35.9ms) by C4::Context::dbh at line 878
{
795
796 ## $context
797 ## correct name for db_scheme
7981200ns my $db_driver;
79913µs18µs if ($context->config("db_scheme")){
# spent 8µs making 1 call to C4::Context::config
800 $db_driver=$context->{db_driver};
801 }else{
802 $db_driver="mysql";
803 }
804
80513µs17µs my $db_name = $context->config("database");
# spent 7µs making 1 call to C4::Context::config
80612µs16µs my $db_host = $context->config("hostname");
# spent 6µs making 1 call to C4::Context::config
80712µs17µs my $db_port = $context->config("port") || '';
# spent 7µs making 1 call to C4::Context::config
80812µs16µs my $db_user = $context->config("user");
# spent 6µs making 1 call to C4::Context::config
80912µs17µs my $db_passwd = $context->config("pass");
# spent 7µs making 1 call to C4::Context::config
810 # MJR added or die here, as we can't work without dbh
811113µs135.7ms my $dbh = DBI->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
# spent 35.7ms making 1 call to DBI::connect
812 $db_user, $db_passwd, {'RaiseError' => $ENV{DEBUG}?1:0 }) or die $DBI::errstr;
813
814 # Check for the existence of a systempreference table; if we don't have this, we don't
815 # have a valid database and should not set RaiseError in order to allow the installer
816 # to run; installer will not run otherwise since we raise all db errors
817
81811µs26µs eval {
# spent 6µs making 2 calls to DBI::common::STORE, avg 3µs/call
819136µs29µs local $dbh->{PrintError} = 0;
# spent 7µs making 1 call to DBI::common::FETCH # spent 2µs making 1 call to DBI::common::STORE
820117µs24µs local $dbh->{RaiseError} = 1;
# spent 2µs making 1 call to DBI::common::FETCH # spent 2µs making 1 call to DBI::common::STORE
8211124µs193µs $dbh->do(qq{SELECT * FROM systempreferences WHERE 1 = 0 });
# spent 93µs making 1 call to DBI::db::do
822 };
823
8241400ns if ($@) {
825 $dbh->{RaiseError} = 0;
826 }
827
82819µs12µs if ( $db_driver eq 'mysql' ) {
# spent 2µs making 1 call to DBI::common::STORE
829 $dbh->{mysql_auto_reconnect} = 1;
830 }
831
83211µs my $tz = $ENV{TZ};
8331800ns if ( $db_driver eq 'mysql' ) {
834 # Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config.
835 # this is better than modifying my.cnf (and forcing all communications to be in utf8)
83617µs11µs $dbh->{'mysql_enable_utf8'}=1; #enable
# spent 1µs making 1 call to DBI::common::STORE
837176µs170µs $dbh->do("set NAMES 'utf8'");
# spent 70µs making 1 call to DBI::db::do
8381600ns ($tz) and $dbh->do(qq(SET time_zone = "$tz"));
839 }
840 elsif ( $db_driver eq 'Pg' ) {
841 $dbh->do( "set client_encoding = 'UTF8';" );
842 ($tz) and $dbh->do(qq(SET TIME ZONE = "$tz"));
843 }
84418µs return $dbh;
845}
846
847=head2 dbh
848
849 $dbh = C4::Context->dbh;
850
851Returns a database handle connected to the Koha database for the
852current context. If no connection has yet been made, this method
853creates one, and connects to the database.
854
855This database handle is cached for future use: if you call
856C<C4::Context-E<gt>dbh> twice, you will get the same handle both
857times. If you need a second database handle, use C<&new_dbh> and
858possibly C<&set_dbh>.
859
860=cut
861
862#'
863sub dbh
864
# spent 36.1ms (98µs+36.0) within C4::Context::dbh which was called 14 times, avg 2.58ms/call: # 6 times (43µs+36.0ms) by C4::Context::preference at line 550, avg 6.01ms/call # once (15µs+0s) by C4::Auth::haspermission at line 1744 of C4/Auth.pm # once (9µs+0s) by C4::Auth::get_user_subpermissions at line 1689 of C4/Auth.pm # once (9µs+0s) by C4::Auth::getuserflags at line 1631 of C4/Auth.pm # once (6µs+0s) by C4::Auth::check_api_auth at line 1163 of C4/Auth.pm # once (4µs+0s) by main::get_borrower_fields at line 167 of svc/members/upsert # once (4µs+0s) by main::find_borrower at line 209 of svc/members/upsert # once (4µs+0s) by C4::Members::AttributeTypes::GetAttributeTypes at line 79 of C4/Members/AttributeTypes.pm # once (4µs+0s) by C4::Auth::get_session at line 1504 of C4/Auth.pm
{
865145µs my $self = shift;
866144µs my $params = shift;
867142µs my $sth;
868
8691415µs unless ( $params->{new} ) {
8701485µs if ( defined($context->{db_driver}) && $context->{db_driver} eq 'mysql' && $context->{"dbh"} ) {
871 return $context->{"dbh"};
872 } elsif ( defined($context->{"dbh"}) && $context->{"dbh"}->ping() ) {
873 return $context->{"dbh"};
874 }
875 }
876
877 # No database handle or it died . Create one.
87815µs136.0ms $context->{"dbh"} = &_new_dbh();
# spent 36.0ms making 1 call to C4::Context::_new_dbh
879
88017µs return $context->{"dbh"};
881}
882
883=head2 new_dbh
884
885 $dbh = C4::Context->new_dbh;
886
887Creates a new connection to the Koha database for the current context,
888and returns the database handle (a C<DBI::db> object).
889
890The handle is not saved anywhere: this method is strictly a
891convenience function; the point is that it knows which database to
892connect to so that the caller doesn't have to know.
893
894=cut
895
896#'
897sub new_dbh
898{
899 my $self = shift;
900
901 return &_new_dbh();
902}
903
904=head2 set_dbh
905
906 $my_dbh = C4::Connect->new_dbh;
907 C4::Connect->set_dbh($my_dbh);
908 ...
909 C4::Connect->restore_dbh;
910
911C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
912C<&set_context> and C<&restore_context>.
913
914C<&set_dbh> saves the current database handle on a stack, then sets
915the current database handle to C<$my_dbh>.
916
917C<$my_dbh> is assumed to be a good database handle.
918
919=cut
920
921#'
922sub set_dbh
923{
924 my $self = shift;
925 my $new_dbh = shift;
926
927 # Save the current database handle on the handle stack.
928 # We assume that $new_dbh is all good: if the caller wants to
929 # screw himself by passing an invalid handle, that's fine by
930 # us.
931 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
932 $context->{"dbh"} = $new_dbh;
933}
934
935=head2 restore_dbh
936
937 C4::Context->restore_dbh;
938
939Restores the database handle saved by an earlier call to
940C<C4::Context-E<gt>set_dbh>.
941
942=cut
943
944#'
945sub restore_dbh
946{
947 my $self = shift;
948
949 if ($#{$context->{"dbh_stack"}} < 0)
950 {
951 # Stack underflow
952 die "DBH stack underflow";
953 }
954
955 # Pop the old database handle and set it.
956 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
957
958 # FIXME - If it is determined that restore_context should
959 # return something, then this function should, too.
960}
961
962=head2 queryparser
963
964 $queryparser = C4::Context->queryparser
965
966Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
967
968=cut
969
970sub queryparser {
971 my $self = shift;
972 unless (defined $context->{"queryparser"}) {
973 $context->{"queryparser"} = &_new_queryparser();
974 }
975
976 return
977 defined( $context->{"queryparser"} )
978 ? $context->{"queryparser"}->new
979 : undef;
980}
981
982=head2 _new_queryparser
983
984Internal helper function to create a new QueryParser object. QueryParser
985is loaded dynamically so as to keep the lack of the QueryParser library from
986getting in anyone's way.
987
988=cut
989
990sub _new_queryparser {
991 my $qpmodules = {
992 'OpenILS::QueryParser' => undef,
993 'Koha::QueryParser::Driver::PQF' => undef
994 };
995 if ( can_load( 'modules' => $qpmodules ) ) {
996 my $QParser = Koha::QueryParser::Driver::PQF->new();
997 my $config_file = $context->config('queryparser_config');
998 $config_file ||= '/etc/koha/searchengine/queryparser.yaml';
999 if ( $QParser->load_config($config_file) ) {
1000 # TODO: allow indexes to be configured in the database
1001 return $QParser;
1002 }
1003 }
1004 return;
1005}
1006
1007=head2 marcfromkohafield
1008
1009 $dbh = C4::Context->marcfromkohafield;
1010
1011Returns a hash with marcfromkohafield.
1012
1013This hash is cached for future use: if you call
1014C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
1015
1016=cut
1017
1018#'
1019sub marcfromkohafield
1020{
1021 my $retval = {};
1022
1023 # If the hash already exists, return it.
1024 return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
1025
1026 # No hash. Create one.
1027 $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
1028
1029 return $context->{"marcfromkohafield"};
1030}
1031
1032# _new_marcfromkohafield
1033# Internal helper function (not a method!). This creates a new
1034# hash with stopwords
1035sub _new_marcfromkohafield
1036{
1037 my $dbh = C4::Context->dbh;
1038 my $marcfromkohafield;
1039 my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
1040 $sth->execute;
1041 while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
1042 my $retval = {};
1043 $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
1044 }
1045 return $marcfromkohafield;
1046}
1047
1048=head2 stopwords
1049
1050 $dbh = C4::Context->stopwords;
1051
1052Returns a hash with stopwords.
1053
1054This hash is cached for future use: if you call
1055C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
1056
1057=cut
1058
1059#'
1060sub stopwords
1061{
1062 my $retval = {};
1063
1064 # If the hash already exists, return it.
1065 return $context->{"stopwords"} if defined($context->{"stopwords"});
1066
1067 # No hash. Create one.
1068 $context->{"stopwords"} = &_new_stopwords();
1069
1070 return $context->{"stopwords"};
1071}
1072
1073# _new_stopwords
1074# Internal helper function (not a method!). This creates a new
1075# hash with stopwords
1076sub _new_stopwords
1077{
1078 my $dbh = C4::Context->dbh;
1079 my $stopwordlist;
1080 my $sth = $dbh->prepare("select word from stopwords");
1081 $sth->execute;
1082 while (my $stopword = $sth->fetchrow_array) {
1083 $stopwordlist->{$stopword} = uc($stopword);
1084 }
1085 $stopwordlist->{A} = "A" unless $stopwordlist;
1086 return $stopwordlist;
1087}
1088
1089=head2 userenv
1090
1091 C4::Context->userenv;
1092
1093Retrieves a hash for user environment variables.
1094
1095This hash shall be cached for future use: if you call
1096C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1097
1098=cut
1099
1100#'
1101
# spent 6µs within C4::Context::userenv which was called 2 times, avg 3µs/call: # 2 times (6µs+0s) by C4::Members::AttributeTypes::GetAttributeTypes at line 74 of C4/Members/AttributeTypes.pm, avg 3µs/call
sub userenv {
110221µs my $var = $context->{"activeuser"};
110326µs if (defined $var and defined $context->{"userenv"}->{$var}) {
1104 return $context->{"userenv"}->{$var};
1105 } else {
1106 return;
1107 }
1108}
1109
1110=head2 set_userenv
1111
1112 C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname,
1113 $usersurname, $userbranch, $userflags, $emailaddress, $branchprinter,
1114 $persona);
1115
1116Establish a hash of user environment variables.
1117
1118set_userenv is called in Auth.pm
1119
1120=cut
1121
1122#'
1123
# spent 19µs within C4::Context::set_userenv which was called: # once (19µs+0s) by C4::Auth::check_api_auth at line 1198 of C4/Auth.pm
sub set_userenv {
112412µs my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona)= @_;
112512µs my $var=$context->{"activeuser"} || '';
112619µs my $cell = {
1127 "number" => $usernum,
1128 "id" => $userid,
1129 "cardnumber" => $usercnum,
1130 "firstname" => $userfirstname,
1131 "surname" => $usersurname,
1132 #possibly a law problem
1133 "branch" => $userbranch,
1134 "branchname" => $branchname,
1135 "flags" => $userflags,
1136 "emailaddress" => $emailaddress,
1137 "branchprinter" => $branchprinter,
1138 "persona" => $persona,
1139 };
114012µs $context->{userenv}->{$var} = $cell;
114117µs return $cell;
1142}
1143
1144sub set_shelves_userenv {
1145 my ($type, $shelves) = @_ or return;
1146 my $activeuser = $context->{activeuser} or return;
1147 $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
1148 $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
1149 $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
1150}
1151
1152sub get_shelves_userenv {
1153 my $active;
1154 unless ($active = $context->{userenv}->{$context->{activeuser}}) {
1155 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
1156 return;
1157 }
1158 my $totshelves = $active->{totshelves} or undef;
1159 my $pubshelves = $active->{pubshelves} or undef;
1160 my $barshelves = $active->{barshelves} or undef;
1161 return ($totshelves, $pubshelves, $barshelves);
1162}
1163
1164=head2 _new_userenv
1165
1166 C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
1167
1168Builds a hash for user environment variables.
1169
1170This hash shall be cached for future use: if you call
1171C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1172
1173_new_userenv is called in Auth.pm
1174
1175=cut
1176
1177#'
1178sub _new_userenv
1179
# spent 6µs within C4::Context::_new_userenv which was called: # once (6µs+0s) by C4::Auth::check_api_auth at line 1196 of C4/Auth.pm
{
11801300ns shift; # Useless except it compensates for bad calling style
11811800ns my ($sessionID)= @_;
118218µs $context->{"activeuser"}=$sessionID;
1183}
1184
1185=head2 _unset_userenv
1186
1187 C4::Context->_unset_userenv;
1188
1189Destroys the hash for activeuser user environment variables.
1190
1191=cut
1192
1193#'
1194
1195sub _unset_userenv
1196{
1197 my ($sessionID)= @_;
1198 undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1199}
1200
1201
1202=head2 get_versions
1203
1204 C4::Context->get_versions
1205
1206Gets various version info, for core Koha packages, Currently called from carp handle_errors() sub, to send to browser if 'DebugLevel' syspref is set to '2'.
1207
1208=cut
1209
1210#'
1211
1212# A little example sub to show more debugging info for CGI::Carp
1213sub get_versions {
1214 my %versions;
1215 $versions{kohaVersion} = KOHAVERSION();
1216 $versions{kohaDbVersion} = C4::Context->preference('version');
1217 $versions{osVersion} = join(" ", POSIX::uname());
1218 $versions{perlVersion} = $];
1219 {
12202354µs238µs
# spent 24µs (9+15) within C4::Context::BEGIN@1220 which was called: # once (9µs+15µs) by main::BEGIN@72 at line 1220
no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
# spent 24µs making 1 call to C4::Context::BEGIN@1220 # spent 15µs making 1 call to warnings::unimport
1221 $versions{mysqlVersion} = `mysql -V`;
1222 $versions{apacheVersion} = `httpd -v`;
1223 $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
1224 $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
1225 $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
1226 }
1227 return %versions;
1228}
1229
1230
1231=head2 tz
1232
1233 C4::Context->tz
1234
1235 Returns a DateTime::TimeZone object for the system timezone
1236
1237=cut
1238
1239sub tz {
1240 my $self = shift;
1241 if (!defined $context->{tz}) {
1242 $context->{tz} = DateTime::TimeZone->new(name => 'local');
1243 }
1244 return $context->{tz};
1245}
1246
1247
1248=head2 IsSuperLibrarian
1249
1250 C4::Context->IsSuperlibrarian();
1251
1252=cut
1253
1254sub IsSuperLibrarian {
1255 my $userenv = C4::Context->userenv;
1256
1257 unless ( $userenv and exists $userenv->{flags} ) {
1258 # If we reach this without a user environment,
1259 # assume that we're running from a command-line script,
1260 # and act as a superlibrarian.
1261 carp("C4::Context->userenv not defined!");
1262 return 1;
1263 }
1264
1265 return ($userenv->{flags}//0) % 2;
1266}
1267
126814µs1;
1269__END__
 
# spent 599µs within C4::Context::CORE:ftdir which was called: # once (599µs+0s) by C4::Context::KOHAVERSION at line 217
sub C4::Context::CORE:ftdir; # opcode
# spent 13µs within C4::Context::CORE:ftsize which was called 2 times, avg 7µs/call: # 2 times (13µs+0s) by C4::Context::new at line 364, avg 7µs/call
sub C4::Context::CORE:ftsize; # opcode
# spent 0s within C4::Context::CORE:subst which was called: # once (0s+0s) by C4::Context::AUTOLOAD at line 666
sub C4::Context::CORE:subst; # opcode
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.