← Index
Performance Profile   « block view • line view • sub view »
For opac/opac-main.pl
  Run on Fri Jul 18 13:58:34 2008
Reported on Fri Jul 18 13:58:40 2008

FileC4/Context.pm
Statements Executed931
Total Time0.011768 seconds

Subroutines — ordered by inclusive time then name
CallsInclusive
Time		Subroutine
650.01877C4::Context::preference
690.01037C4::Context::dbh
10.00039C4::Context::boolean_preference
10.00032C4::Context::KOHAVERSION
40.00008C4::Context::config
20.00007C4::Context::AUTOLOAD
80.00006C4::Context::userenv
40.00005C4::Context::_common_config
10.00002C4::Context::set_shelves_userenv
10.00002C4::Context::_new_userenv
10.00002C4::Context::get_shelves_userenv
00C4::Context::ModZebrations
00C4::Context::Zconn
00C4::Context::_new_Zconn
00C4::Context::_new_dbh
00C4::Context::_new_marcfromkohafield
00C4::Context::_new_stopwords
00C4::Context::_unset_userenv
00C4::Context::db_scheme2dbi
00C4::Context::get_versions
00C4::Context::handle_errors
00C4::Context::import
00C4::Context::marcfromkohafield
00C4::Context::new
00C4::Context::new_dbh
00C4::Context::read_config_file
00C4::Context::restore_context
00C4::Context::restore_dbh
00C4::Context::set_context
00C4::Context::set_dbh
00C4::Context::set_userenv
00C4::Context::stopwords
00C4::Context::zebraconfig
00XML::SAX::PurePerl::BEGIN
00XML::SAX::PurePerl::Reader::BEGIN

LineStmts.Exclusive
Time		Avg.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 with
16# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
17# Suite 330, Boston, MA 02111-1307 USA
18
19use strict;
20use vars qw($VERSION $AUTOLOAD $context @context_stack $usecache $memd);
21
22BEGIN {
23 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$VERSION = '3.00.00.036';
81# $usecache = preference("usecache");
82 $usecache;
83 if ($usecache) {
84 require Cache::Memcached;
85 Cache::Memcached->import();
86 $memd = new Cache::Memcached(
87 'servers'=>['127.0.0.1:11211'],
88 );
89 }
90}
91
92use DBI;
93use ZOOM;
94use XML::Simple;
95use C4::Boolean;
96use C4::Debug;
97
98=head1 NAME
99
100C4::Context - Maintain and manipulate the context of a Koha script
101
102=head1 SYNOPSIS
103
104 use C4::Context;
105
106 use C4::Context("/path/to/koha-conf.xml");
107
108 $config_value = C4::Context->config("config_variable");
109
110 $koha_preference = C4::Context->preference("preference");
111
112 $db_handle = C4::Context->dbh;
113
114 $Zconn = C4::Context->Zconn;
115
116 $stopwordhash = C4::Context->stopwords;
117
118=head1 DESCRIPTION
119
120When a Koha script runs, it makes use of a certain number of things:
121configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
122databases, and so forth. These things make up the I<context> in which
123the script runs.
124
125This module takes care of setting up the context for a script:
126figuring out which configuration file to load, and loading it, opening
127a connection to the right database, and so forth.
128
129Most scripts will only use one context. They can simply have
130
131 use C4::Context;
132
133at the top.
134
135Other scripts may need to use several contexts. For instance, if a
136library has two databases, one for a certain collection, and the other
137for everything else, it might be necessary for a script to use two
138different contexts to search both databases. Such scripts should use
139the C<&set_context> and C<&restore_context> functions, below.
140
141By default, C4::Context reads the configuration from
142F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
143environment variable to the pathname of a configuration file to use.
144
145=head1 METHODS
146
147=over 2
148
149=cut
150
151#'
152# In addition to what is said in the POD above, a Context object is a
153# reference-to-hash with the following fields:
154#
155# config
156# A reference-to-hash whose keys and values are the
157# configuration variables and values specified in the config
158# file (/etc/koha/koha-conf.xml).
159# dbh
160# A handle to the appropriate database for this context.
161# dbh_stack
162# Used by &set_dbh and &restore_dbh to hold other database
163# handles for this context.
164# Zconn
165# A connection object for the Zebra server
166
167# Koha's main configuration file koha-conf.xml
168# is searched for according to this priority list:
169#
170# 1. Path supplied via use C4::Context '/path/to/koha-conf.xml'
171# 2. Path supplied in KOHA_CONF environment variable.
172# 3. Path supplied in INSTALLED_CONFIG_FNAME, as long
173# as value has changed from its default of
174# '__KOHA_CONF_DIR__/koha-conf.xml', as happens
175# when Koha is installed in 'standard' or 'single'
176# mode.
177# 4. Path supplied in CONFIG_FNAME.
178#
179# The first entry that refers to a readable file is used.
180
181use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
182 # Default config file, if none is specified
183
184my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml';
185 # path to config file set by installer
186 # __KOHA_CONF_DIR__ is set by rewrite-confg.PL
187 # when Koha is installed in 'standard' or 'single'
188 # mode. If Koha was installed in 'dev' mode,
189 # __KOHA_CONF_DIR__ is *not* rewritten; instead
190 # developers should set the KOHA_CONF environment variable
191
192$context = undef; # Initially, no context is set
193@context_stack = (); # Initially, no saved contexts
194
195
196=item KOHAVERSION
197 returns the kohaversion stored in kohaversion.pl file
198
199=cut
200
201
# spent 0.00032s within C4::Context::KOHAVERSION which was called: # 1 times (0.00032s) by C4::Auth::_version_check at line 451 of C4/Auth.pm
sub KOHAVERSION {
20240.000140.00004 my $cgidir = C4::Context->intranetdir ."/cgi-bin";
# spent 0.00004s making 1 calls to C4::Context::AUTOLOAD
203
204 # 2 cases here : on CVS install, $cgidir does not need a /cgi-bin
205 # on a standard install, /cgi-bin need to be added.
206 # test one, then the other
207 # FIXME - is this all really necessary?
20820.000015e-06 unless (opendir(DIR, "$cgidir/cataloguing/value_builder")) {
209 $cgidir = C4::Context->intranetdir;
# spent 0.00003s making 1 calls to C4::Context::AUTOLOAD
210 closedir(DIR);
211 }
212
213 do $cgidir."/kohaversion.pl" || die "NO $cgidir/kohaversion.pl";
214 return kohaversion();
# spent 0.00002s making 1 calls to C4::Context::kohaversion
215}
216=item read_config_file
217
218=over 4
219
220Reads the specified Koha config file.
221
222Returns an object containing the configuration variables. The object's
223structure is a bit complex to the uninitiated ... take a look at the
224koha-conf.xml file as well as the XML::Simple documentation for details. Or,
225here are a few examples that may give you what you need:
226
227The simple elements nested within the <config> element:
228
229 my $pass = $koha->{'config'}->{'pass'};
230
231The <listen> elements:
232
233 my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};
234
235The elements nested within the <server> element:
236
237 my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};
238
239Returns undef in case of error.
240
241=back
242
243=cut
244
245sub read_config_file { # Pass argument naming config file to read
246 my $koha;
247 if ($usecache){
248 $koha = $memd->get("Koha:context:config");
249 if (! $koha){
250 $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo']);
251 $memd->set("Koha:context:config",$koha);
252 }
253 return $koha;
254 }
255 $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo']);
256 return $koha; # Return value: ref-to-hash holding the configuration
257}
258
259# db_scheme2dbi
260# Translates the full text name of a database into de appropiate dbi name
261#
262sub db_scheme2dbi {
263 my $name = shift;
264
265 for ($name) {
266# FIXME - Should have other databases.
267 if (/mysql/i) { return("mysql"); }
268 if (/Postgres|Pg|PostgresSQL/) { return("Pg"); }
269 if (/oracle/i) { return("Oracle"); }
270 }
271 return undef; # Just in case
272}
273
274sub import {
275 my $package = shift;
276 my $conf_fname = shift; # Config file name
277
278 # Create a new context from the given config file name, if
279 # any, then set it as the current context.
280 $context = new C4::Context($conf_fname) unless $context;
281 return undef if !defined($context);
282 $context->set_context;
283}
284
285=item new
286
287 $context = new C4::Context;
288 $context = new C4::Context("/path/to/koha-conf.xml");
289
290Allocates a new context. Initializes the context from the specified
291file, which defaults to either the file given by the C<$KOHA_CONF>
292environment variable, or F</etc/koha/koha-conf.xml>.
293
294C<&new> does not set this context as the new default context; for
295that, use C<&set_context>.
296
297=cut
298
299#'
300# Revision History:
301# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
302sub new {
303 my $class = shift;
304 my $conf_fname = shift; # Config file to load
305 my $self = {};
306
307 # check that the specified config file exists and is not empty
308 undef $conf_fname unless
309 (defined $conf_fname && -s $conf_fname);
310 # Figure out a good config file to load if none was specified.
311 if (!defined($conf_fname))
312 {
313 # If the $KOHA_CONF environment variable is set, use
314 # that. Otherwise, use the built-in default.
315 if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) {
316 $conf_fname = $ENV{"KOHA_CONF"};
317 } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) {
318 # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above
319 # regex to anything else -- don't want installer to rewrite it
320 $conf_fname = $INSTALLED_CONFIG_FNAME;
321 } elsif (-s CONFIG_FNAME) {
322 $conf_fname = CONFIG_FNAME;
323 } else {
324 warn "unable to locate Koha configuration file koha-conf.xml";
325 return undef;
326 }
327 }
328 # Load the desired config file.
329 $self = read_config_file($conf_fname);
330 $self->{"config_file"} = $conf_fname;
331
332 warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
333 return undef if !defined($self->{"config"});
334
335 $self->{"dbh"} = undef; # Database handle
336 $self->{"Zconn"} = undef; # Zebra Connections
337 $self->{"stopwords"} = undef; # stopwords list
338 $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
339 $self->{"userenv"} = undef; # User env
340 $self->{"activeuser"} = undef; # current active user
341 $self->{"shelves"} = undef;
342
343 bless $self, $class;
344 return $self;
345}
346
347=item set_context
348
349 $context = new C4::Context;
350 $context->set_context();
351or
352 set_context C4::Context $context;
353
354 ...
355 restore_context C4::Context;
356
357In some cases, it might be necessary for a script to use multiple
358contexts. C<&set_context> saves the current context on a stack, then
359sets the context to C<$context>, which will be used in future
360operations. To restore the previous context, use C<&restore_context>.
361
362=cut
363
364#'
365sub set_context
366{
367 my $self = shift;
368 my $new_context; # The context to set
369
370 # Figure out whether this is a class or instance method call.
371 #
372 # We're going to make the assumption that control got here
373 # through valid means, i.e., that the caller used an instance
374 # or class method call, and that control got here through the
375 # usual inheritance mechanisms. The caller can, of course,
376 # break this assumption by playing silly buggers, but that's
377 # harder to do than doing it properly, and harder to check
378 # for.
379 if (ref($self) eq "")
380 {
381 # Class method. The new context is the next argument.
382 $new_context = shift;
383 } else {
384 # Instance method. The new context is $self.
385 $new_context = $self;
386 }
387
388 # Save the old context, if any, on the stack
389 push @context_stack, $context if defined($context);
390
391 # Set the new context
392 $context = $new_context;
393}
394
395=item restore_context
396
397 &restore_context;
398
399Restores the context set by C<&set_context>.
400
401=cut
402
403#'
404sub restore_context
405{
406 my $self = shift;
407
408 if ($#context_stack < 0)
409 {
410 # Stack underflow.
411 die "Context stack underflow";
412 }
413
414 # Pop the old context and set it.
415 $context = pop @context_stack;
416
417 # FIXME - Should this return something, like maybe the context
418 # that was current when this was called?
419}
420
421=item config
422
423 $value = C4::Context->config("config_variable");
424
425 $value = C4::Context->config_variable;
426
427Returns the value of a variable specified in the configuration file
428from which the current context was created.
429
430The second form is more compact, but of course may conflict with
431method names. If there is a configuration variable called "new", then
432C<C4::Config-E<gt>new> will not return it.
433
434=cut
435
436
# spent 0.00005s within C4::Context::_common_config which was called 4 times, avg 0.00001s/call: # 4 times (0.00005s) by C4::Context::config at line 450 of C4/Context.pm, avg 0.00001s/call
sub _common_config ($$) {
437160.000021e-06 my $var = shift;
438 my $term = shift;
439 return undef if !defined($context->{$term});
440 # Presumably $self->{$term} might be
441 # undefined if the config file given to &new
442 # didn't exist, and the caller didn't bother
443 # to check the return value.
444
445 # Return the value of the requested config variable
446 return $context->{$term}->{$var};
447}
448
449
# spent 0.00008s within C4::Context::config which was called 4 times, avg 0.00002s/call: # 2 times (0.00003s) by C4::Context::AUTOLOAD at line 518 of C4/Context.pm, avg 0.00002s/call # 1 times (0.00002s) by C4::Output::gettemplate at line 75 of C4/Output.pm # 1 times (0.00002s) by C4::Languages::getTranslatedLanguages at line 126 of C4/Languages.pm
sub config {
45040.000025e-06 return _common_config($_[1],'config');
# spent 0.00005s making 4 calls to C4::Context::_common_config, avg 0.00001s/call
451}
452sub zebraconfig {
453 return _common_config($_[1],'server');
454}
455sub ModZebrations {
456 return _common_config($_[1],'serverinfo');
457}
458
459=item preference
460
461 $sys_preference = C4::Context->preference("some_variable");
462
463Looks up the value of the given system preference in the
464systempreferences table of the Koha database, and returns it. If the
465variable is not set, or in case of error, returns the undefined value.
466
467=cut
468
469#'
470# FIXME - The preferences aren't likely to change over the lifetime of
471# the script (and things might break if they did change), so perhaps
472# this function should cache the results it finds.
473sub preference
474
# spent 0.01877s within C4::Context::preference which was called 65 times, avg 0.00029s/call: # 38 times (0.01029s) by C4::Auth::get_template_and_user at line 297 of C4/Auth.pm, avg 0.00027s/call # 9 times (0.00247s) by C4::Auth::get_template_and_user at line 252 of C4/Auth.pm, avg 0.00027s/call # 4 times (0.00113s) by C4::Output::gettemplate at line 101 of C4/Output.pm, avg 0.00028s/call # 1 times (0.00046s) at line 35 of opac/opac-main.pl # 1 times (0.00027s) by C4::Output::gettemplate at line 81 of C4/Output.pm # 1 times (0.00038s) by C4::Output::themelanguage at line 149 of C4/Output.pm # 1 times (0.00027s) by C4::Output::gettemplate at line 83 of C4/Output.pm # 1 times (0.00027s) by C4::Output::themelanguage at line 167 of C4/Output.pm # 1 times (0.00034s) by C4::Context::boolean_preference at line 499 of C4/Context.pm # 1 times (0.00028s) by C4::Auth::get_template_and_user at line 130 of C4/Auth.pm # 1 times (0.00029s) by C4::Auth::_version_check at line 435 of C4/Auth.pm # 1 times (0.00027s) by C4::Auth::get_template_and_user at line 294 of C4/Auth.pm # 1 times (0.00081s) by C4::Auth::_version_check at line 431 of C4/Auth.pm # 1 times (0.00035s) by C4::Auth::get_session at line 1176 of C4/Auth.pm # 1 times (0.00030s) by C4::Auth::checkauth at line 485 of C4/Auth.pm # 1 times (0.00030s) by C4::Languages::getTranslatedLanguages at line 125 of C4/Languages.pm # 1 times (0.00028s) by C4::Languages::_build_languages_arrayref at line 282 of C4/Languages.pm
{
4755200.001052e-06 my $self = shift;
476 my $var = shift; # The system preference to return
477 my $retval; # Return value
478 if ($usecache) {
479 $retval = $memd->get("Koha:preference:$var");
480 return $retval if $retval;
481 }
482 my $dbh = C4::Context->dbh or return 0;
# spent 0.00969s making 65 calls to C4::Context::dbh, avg 0.00015s/call
483 # Look up systempreferences.variable==$var
48410.004050.00405 $retval = $dbh->selectrow_array(<<EOT);
# spent 0.00721s making 65 calls to DBI::db::selectrow_array, avg 0.00011s/call # spent 0.00378s making 65 calls to DBI::db::prepare, avg 0.00006s/call
485 SELECT value
486 FROM systempreferences
487 WHERE variable='$var'
488 LIMIT 1
489EOT
490 if ($usecache) {
491 $memd->set("Koha:preference:$var", $retval);
492 }
493 return $retval;
494}
495
496
# spent 0.00039s within C4::Context::boolean_preference which was called: # 1 times (0.00039s) by C4::Auth::checkauth at line 735 of C4/Auth.pm
sub boolean_preference ($) {
49740.000025e-06 my $self = shift;
498 my $var = shift; # The system preference to return
499 my $it = preference($self, $var);
# spent 0.00034s making 1 calls to C4::Context::preference
500 return defined($it)? C4::Boolean::true_p($it): undef;
# spent 0.00003s making 1 calls to C4::Boolean::true_p
501}
502
503# AUTOLOAD
504# This implements C4::Config->foo, and simply returns
505# C4::Context->config("foo"), as described in the documentation for
506# &config, above.
507
508# FIXME - Perhaps this should be extended to check &config first, and
509# then &preference if that fails. OTOH, AUTOLOAD could lead to crappy
510# code, so it'd probably be best to delete it altogether so as not to
511# encourage people to use it.
512sub AUTOLOAD
513
# spent 0.00007s within C4::Context::AUTOLOAD which was called 2 times, avg 0.00003s/call: # 1 times (0.00003s) by C4::Context::KOHAVERSION at line 209 of C4/Context.pm # 1 times (0.00004s) by C4::Context::KOHAVERSION at line 202 of C4/Context.pm
{
51460.000024e-06 my $self = shift;
515
516 $AUTOLOAD =~ s/.*:://; # Chop off the package name,
517 # leaving only the function name.
518 return $self->config($AUTOLOAD);
# spent 0.00003s making 2 calls to C4::Context::config, avg 0.00002s/call
519}
520
521=item Zconn
522
523$Zconn = C4::Context->Zconn
524
525Returns a connection to the Zebra database for the current
526context. If no connection has yet been made, this method
527creates one and connects.
528
529C<$self>
530
531C<$server> one of the servers defined in the koha-conf.xml file
532
533C<$async> whether this is a asynchronous connection
534
535C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
536
537
538=cut
539
540sub Zconn {
541 my $self=shift;
542 my $server=shift;
543 my $async=shift;
544 my $auth=shift;
545 my $piggyback=shift;
546 my $syntax=shift;
547 if ( defined($context->{"Zconn"}->{$server}) && (0 == $context->{"Zconn"}->{$server}->errcode()) ) {
548 return $context->{"Zconn"}->{$server};
549 # No connection object or it died. Create one.
550 }else {
551 # release resources if we're closing a connection and making a new one
552 # FIXME: this needs to be smarter -- an error due to a malformed query or
553 # a missing index does not necessarily require us to close the connection
554 # and make a new one, particularly for a batch job. However, at
555 # first glance it does not look like there's a way to easily check
556 # the basic health of a ZOOM::Connection
557 $context->{"Zconn"}->{$server}->destroy() if defined($context->{"Zconn"}->{$server});
558
559 $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
560 return $context->{"Zconn"}->{$server};
561 }
562}
563
564=item _new_Zconn
565
566$context->{"Zconn"} = &_new_Zconn($server,$async);
567
568Internal function. Creates a new database connection from the data given in the current context and returns it.
569
570C<$server> one of the servers defined in the koha-conf.xml file
571
572C<$async> whether this is a asynchronous connection
573
574C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
575
576=cut
577
578sub _new_Zconn {
579 my ($server,$async,$auth,$piggyback,$syntax) = @_;
580
581 my $tried=0; # first attempt
582 my $Zconn; # connection object
583 $server = "biblioserver" unless $server;
584 $syntax = "usmarc" unless $syntax;
585
586 my $host = $context->{'listen'}->{$server}->{'content'};
587 my $servername = $context->{"config"}->{$server};
588 my $user = $context->{"serverinfo"}->{$server}->{"user"};
589 my $password = $context->{"serverinfo"}->{$server}->{"password"};
590 $auth = 1 if($user && $password);
591 retry:
592 eval {
593 # set options
594 my $o = new ZOOM::Options();
595 $o->option(user=>$user) if $auth;
596 $o->option(password=>$password) if $auth;
597 $o->option(async => 1) if $async;
598 $o->option(count => $piggyback) if $piggyback;
599 $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
600 $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
601 $o->option(preferredRecordSyntax => $syntax);
602 $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief'
603 $o->option(databaseName => ($servername?$servername:"biblios"));
604
605 # create a new connection object
606 $Zconn= create ZOOM::Connection($o);
607
608 # forge to server
609 $Zconn->connect($host, 0);
610
611 # check for errors and warn
612 if ($Zconn->errcode() !=0) {
613 warn "something wrong with the connection: ". $Zconn->errmsg();
614 }
615
616 };
617# if ($@) {
618# # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues
619# # Also, I'm skeptical about whether it's the best approach
620# warn "problem with Zebra";
621# if ( C4::Context->preference("ManageZebra") ) {
622# if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra
623# $tried=1;
624# warn "trying to restart Zebra";
625# my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log");
626# goto "retry";
627# } else {
628# warn "Error ", $@->code(), ": ", $@->message(), "\n";
629# $Zconn="error";
630# return $Zconn;
631# }
632# }
633# }
634 return $Zconn;
635}
636
637# _new_dbh
638# Internal helper function (not a method!). This creates a new
639# database connection from the data given in the current context, and
640# returns it.
641sub _new_dbh
642{
643
644### $context
645 ##correct name for db_schme
646 my $db_driver;
647 if ($context->config("db_scheme")){
648 $db_driver=db_scheme2dbi($context->config("db_scheme"));
649 }else{
650 $db_driver="mysql";
651 }
652
653 my $db_name = $context->config("database");
654 my $db_host = $context->config("hostname");
655 my $db_port = $context->config("port");
656 $db_port = "" unless defined $db_port;
657 my $db_user = $context->config("user");
658 my $db_passwd = $context->config("pass");
659 # MJR added or die here, as we can't work without dbh
660 my $dbh= DBI->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
661 $db_user, $db_passwd) or die $DBI::errstr;
662 if ( $db_driver eq 'mysql' ) {
663 # Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config.
664 # this is better than modifying my.cnf (and forcing all communications to be in utf8)
665 $dbh->{'mysql_enable_utf8'}=1; #enable
666 $dbh->do("set NAMES 'utf8'");
667 }
668 elsif ( $db_driver eq 'Pg' ) {
669 $dbh->do( "set client_encoding = 'UTF8';" );
670 }
671 return $dbh;
672}
673
674=item dbh
675
676 $dbh = C4::Context->dbh;
677
678Returns a database handle connected to the Koha database for the
679current context. If no connection has yet been made, this method
680creates one, and connects to the database.
681
682This database handle is cached for future use: if you call
683C<C4::Context-E<gt>dbh> twice, you will get the same handle both
684times. If you need a second database handle, use C<&new_dbh> and
685possibly C<&set_dbh>.
686
687=cut
688
689#'
690sub dbh
691
# spent 0.01037s within C4::Context::dbh which was called 69 times, avg 0.00015s/call: # 65 times (0.00969s) by C4::Context::preference at line 482 of C4/Context.pm, avg 0.00015s/call # 1 times (0.00014s) by C4::Output::themelanguage at line 157 of C4/Output.pm # 1 times (0.00014s) by C4::Auth::get_session at line 1177 of C4/Auth.pm # 1 times (0.00026s) by C4::Auth::checkauth at line 484 of C4/Auth.pm # 1 times (0.00015s) by C4::Languages::getAllLanguages at line 185 of C4/Languages.pm
{
6922070.000147e-07 my $self = shift;
693 my $sth;
694
6951380.005960.00004 if (defined($context->{"dbh"})) {
69610.000280.00028 $sth=$context->{"dbh"}->prepare("select 1");
# spent 0.00403s making 69 calls to DBI::db::prepare, avg 0.00006s/call
697 return $context->{"dbh"} if (defined($sth->execute));
# spent 0.00454s making 69 calls to DBI::st::execute, avg 0.00007s/call
698 }
699
700 # No database handle or it died . Create one.
701 $context->{"dbh"} = &_new_dbh();
702
703 return $context->{"dbh"};
704}
705
706=item new_dbh
707
708 $dbh = C4::Context->new_dbh;
709
710Creates a new connection to the Koha database for the current context,
711and returns the database handle (a C<DBI::db> object).
712
713The handle is not saved anywhere: this method is strictly a
714convenience function; the point is that it knows which database to
715connect to so that the caller doesn't have to know.
716
717=cut
718
719#'
720sub new_dbh
721{
722 my $self = shift;
723
724 return &_new_dbh();
725}
726
727=item set_dbh
728
729 $my_dbh = C4::Connect->new_dbh;
730 C4::Connect->set_dbh($my_dbh);
731 ...
732 C4::Connect->restore_dbh;
733
734C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
735C<&set_context> and C<&restore_context>.
736
737C<&set_dbh> saves the current database handle on a stack, then sets
738the current database handle to C<$my_dbh>.
739
740C<$my_dbh> is assumed to be a good database handle.
741
742=cut
743
744#'
745sub set_dbh
746{
747 my $self = shift;
748 my $new_dbh = shift;
749
750 # Save the current database handle on the handle stack.
751 # We assume that $new_dbh is all good: if the caller wants to
752 # screw himself by passing an invalid handle, that's fine by
753 # us.
754 push @{$context->{"dbh_stack"}}, $context->{"dbh"};
755 $context->{"dbh"} = $new_dbh;
756}
757
758=item restore_dbh
759
760 C4::Context->restore_dbh;
761
762Restores the database handle saved by an earlier call to
763C<C4::Context-E<gt>set_dbh>.
764
765=cut
766
767#'
768sub restore_dbh
769{
770 my $self = shift;
771
772 if ($#{$context->{"dbh_stack"}} < 0)
773 {
774 # Stack underflow
775 die "DBH stack underflow";
776 }
777
778 # Pop the old database handle and set it.
779 $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
780
781 # FIXME - If it is determined that restore_context should
782 # return something, then this function should, too.
783}
784
785=item marcfromkohafield
786
787 $dbh = C4::Context->marcfromkohafield;
788
789Returns a hash with marcfromkohafield.
790
791This hash is cached for future use: if you call
792C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
793
794=cut
795
796#'
797sub marcfromkohafield
798{
799 my $retval = {};
800
801 # If the hash already exists, return it.
802 return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
803
804 # No hash. Create one.
805 $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
806
807 return $context->{"marcfromkohafield"};
808}
809
810# _new_marcfromkohafield
811# Internal helper function (not a method!). This creates a new
812# hash with stopwords
813sub _new_marcfromkohafield
814{
815 my $dbh = C4::Context->dbh;
816 my $marcfromkohafield;
817 my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
818 $sth->execute;
819 while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
820 my $retval = {};
821 $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
822 }
823 return $marcfromkohafield;
824}
825
826=item stopwords
827
828 $dbh = C4::Context->stopwords;
829
830Returns a hash with stopwords.
831
832This hash is cached for future use: if you call
833C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access
834
835=cut
836
837#'
838sub stopwords
839{
840 my $retval = {};
841
842 # If the hash already exists, return it.
843 return $context->{"stopwords"} if defined($context->{"stopwords"});
844
845 # No hash. Create one.
846 $context->{"stopwords"} = &_new_stopwords();
847
848 return $context->{"stopwords"};
849}
850
851# _new_stopwords
852# Internal helper function (not a method!). This creates a new
853# hash with stopwords