← Index
Performance Profile   « block view • line view • sub view »
For opac/opac-main.pl
  Run on Thu Jul 17 22:22:09 2008
Reported on Thu Jul 17 22:22:20 2008

FileC4/Context.pm
Statements Executed1278
Total Time0.020294 seconds

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