Profile of C4/Context.pm

Filename	/home/vagrant/kohaclone/C4/Context.pm
Statements	Executed 0 statements in 2.77ms

Line	State ments	Time on line	Code
1			package 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
7			# under the terms of the GNU General Public License as published by
8			# the Free Software Foundation; either version 3 of the License, or
9			# (at your option) any later version.
10			#
11			# Koha is distributed in the hope that it will be useful, but
12			# WITHOUT ANY WARRANTY; without even the implied warranty of
13			# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14			# GNU General Public License for more details.
15			#
16			# You should have received a copy of the GNU General Public License
17			# along with Koha; if not, see <http://www.gnu.org/licenses>.
18
19			use strict;
20			use warnings;
21			use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached);
22			BEGIN {
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
81			# Check if there are memcached servers set
82			$servers = $ENV{'MEMCACHED_SERVERS'};
83			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
97			$VERSION = '3.07.00.049';
98			}
99
100			use Encode;
101			use ZOOM;
102			use XML::Simple;
103			use POSIX ();
104			use DateTime::TimeZone;
105			use Module::Load::Conditional qw(can_load);
106			use Carp;
107
108			use C4::Boolean;
109			use C4::Debug;
110			use Koha;
111			use Koha::Config::SysPrefs;
112
113			=head1 NAME
114
115			C4::Context - Maintain and manipulate the context of a Koha script
116
117			=head1 SYNOPSIS
118
119			use C4::Context;
120
121			use C4::Context("/path/to/koha-conf.xml");
122
123			$config_value = C4::Context->config("config_variable");
124
125			$koha_preference = C4::Context->preference("preference");
126
127			$db_handle = C4::Context->dbh;
128
129			$Zconn = C4::Context->Zconn;
130
131			=head1 DESCRIPTION
132
133			When a Koha script runs, it makes use of a certain number of things:
134			configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
135			databases, and so forth. These things make up the I<context> in which
136			the script runs.
137
138			This module takes care of setting up the context for a script:
139			figuring out which configuration file to load, and loading it, opening
140			a connection to the right database, and so forth.
141
142			Most scripts will only use one context. They can simply have
143
144			use C4::Context;
145
146			at the top.
147
148			Other scripts may need to use several contexts. For instance, if a
149			library has two databases, one for a certain collection, and the other
150			for everything else, it might be necessary for a script to use two
151			different contexts to search both databases. Such scripts should use
152			the C<&set_context> and C<&restore_context> functions, below.
153
154			By default, C4::Context reads the configuration from
155			F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
156			environment variable to the pathname of a configuration file to use.
157
158			=head1 METHODS
159
160			=cut
161
162			#'
163			# In addition to what is said in the POD above, a Context object is a
164			# reference-to-hash with the following fields:
165			#
166			# config
167			# A reference-to-hash whose keys and values are the
168			# configuration variables and values specified in the config
169			# file (/etc/koha/koha-conf.xml).
170			# dbh
171			# A handle to the appropriate database for this context.
172			# dbh_stack
173			# Used by &set_dbh and &restore_dbh to hold other database
174			# handles for this context.
175			# Zconn
176			# A connection object for the Zebra server
177
178			# Koha's main configuration file koha-conf.xml
179			# is searched for according to this priority list:
180			#
181			# 1. Path supplied via use C4::Context '/path/to/koha-conf.xml'
182			# 2. Path supplied in KOHA_CONF environment variable.
183			# 3. Path supplied in INSTALLED_CONFIG_FNAME, as long
184			# as value has changed from its default of
185			# '__KOHA_CONF_DIR__/koha-conf.xml', as happens
186			# when Koha is installed in 'standard' or 'single'
187			# mode.
188			# 4. Path supplied in CONFIG_FNAME.
189			#
190			# The first entry that refers to a readable file is used.
191
192			use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
193			# Default config file, if none is specified
194
195			my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml';
196			# path to config file set by installer
197			# __KOHA_CONF_DIR__ is set by rewrite-confg.PL
198			# when Koha is installed in 'standard' or 'single'
199			# mode. If Koha was installed in 'dev' mode,
200			# __KOHA_CONF_DIR__ is not rewritten; instead
201			# developers should set the KOHA_CONF environment variable
202
203			$context = undef; # Initially, no context is set
204			@context_stack = (); # Initially, no saved contexts
205
206
207			=head2 read_config_file
208
209			Reads the specified Koha config file.
210
211			Returns an object containing the configuration variables. The object's
212			structure is a bit complex to the uninitiated ... take a look at the
213			koha-conf.xml file as well as the XML::Simple documentation for details. Or,
214			here are a few examples that may give you what you need:
215
216			The simple elements nested within the <config> element:
217
218			my $pass = $koha->{'config'}->{'pass'};
219
220			The <listen> elements:
221
222			my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};
223
224			The elements nested within the <server> element:
225
226			my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};
227
228			Returns undef in case of error.
229
230			=cut
231
232			sub read_config_file { # Pass argument naming config file to read
233			my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
234
235			if ($ismemcached) {
236			$memcached->set('kohaconf',$koha);
237			}
238
239			return $koha; # Return value: ref-to-hash holding the configuration
240			}
241
242			=head2 ismemcached
243
244			Returns the value of the $ismemcached variable (0/1)
245
246			=cut
247
248			sub ismemcached {
249			return $ismemcached;
250			}
251
252			=head2 memcached
253
254			If $ismemcached is true, returns the $memcache variable.
255			Returns undef otherwise
256
257			=cut
258
259			sub memcached {
260			if ($ismemcached) {
261			return $memcached;
262			} else {
263			return;
264			}
265			}
266
267			=head2 db_scheme2dbi
268
269			my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
270
271			This routines translates a database type to part of the name
272			of the appropriate DBD driver to use when establishing a new
273			database connection. It recognizes 'mysql' and 'Pg'; if any
274			other scheme is supplied it defaults to 'mysql'.
275
276			=cut
277
278			sub db_scheme2dbi {
279			my $scheme = shift // '';
280			return $scheme eq 'Pg' ? $scheme : 'mysql';
281			}
282
283			sub import {
284			# Create the default context ($C4::Context::Context)
285			# the first time the module is called
286			# (a config file can be optionaly passed)
287
288			# default context already exists?
289			return if $context;
290
291			# no ? so load it!
292			my ($pkg,$config_file) = @_ ;
293			my $new_ctx = __PACKAGE__->new($config_file);
294			return unless $new_ctx;
295
296			# if successfully loaded, use it by default
297			$new_ctx->set_context;
298			1;
299			}
300
301			=head2 new
302
303			$context = new C4::Context;
304			$context = new C4::Context("/path/to/koha-conf.xml");
305
306			Allocates a new context. Initializes the context from the specified
307			file, which defaults to either the file given by the C<$KOHA_CONF>
308			environment variable, or F</etc/koha/koha-conf.xml>.
309
310			It saves the koha-conf.xml values in the declared memcached server(s)
311			if currently available and uses those values until them expire and
312			re-reads them.
313
314			C<&new> does not set this context as the new default context; for
315			that, use C<&set_context>.
316
317			=cut
318
319			#'
320			# Revision History:
321			# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
322			sub new {
323			my $class = shift;
324			my $conf_fname = shift; # Config file to load
325			my $self = {};
326
327			# check that the specified config file exists and is not empty
328			undef $conf_fname unless
329			(defined $conf_fname && -s $conf_fname);
330			# Figure out a good config file to load if none was specified.
331			if (!defined($conf_fname))
332			{
333			# If the $KOHA_CONF environment variable is set, use
334			# that. Otherwise, use the built-in default.
335			if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) {
336			$conf_fname = $ENV{"KOHA_CONF"};
337			} elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) {
338			# NOTE: be careful -- don't change __KOHA_CONF_DIR in the above
339			# regex to anything else -- don't want installer to rewrite it
340			$conf_fname = $INSTALLED_CONFIG_FNAME;
341			} elsif (-s CONFIG_FNAME) {
342			$conf_fname = CONFIG_FNAME;
343			} else {
344			warn "unable to locate Koha configuration file koha-conf.xml";
345			return;
346			}
347			}
348
349			if ($ismemcached) {
350			# retrieve from memcached
351			$self = $memcached->get('kohaconf');
352			if (not defined $self) {
353			# not in memcached yet
354			$self = read_config_file($conf_fname);
355			}
356			} else {
357			# non-memcached env, read from file
358			$self = read_config_file($conf_fname);
359			}
360
361			$self->{"config_file"} = $conf_fname;
362			warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
363			return if !defined($self->{"config"});
364
365			$self->{"Zconn"} = undef; # Zebra Connections
366			$self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
367			$self->{"userenv"} = undef; # User env
368			$self->{"activeuser"} = undef; # current active user
369			$self->{"shelves"} = undef;
370			$self->{tz} = undef; # local timezone object
371
372			bless $self, $class;
373			$self->{db_driver} = db_scheme2dbi($self->config('db_scheme')); # cache database driver
374			return $self;
375			}
376
377			=head2 set_context
378
379			$context = new C4::Context;
380			$context->set_context();
381			or
382			set_context C4::Context $context;
383
384			...
385			restore_context C4::Context;
386
387			In some cases, it might be necessary for a script to use multiple
388			contexts. C<&set_context> saves the current context on a stack, then
389			sets the context to C<$context>, which will be used in future
390			operations. To restore the previous context, use C<&restore_context>.
391
392			=cut
393
394			#'
395			sub set_context
396			{
397			my $self = shift;
398			my $new_context; # The context to set
399
400			# Figure out whether this is a class or instance method call.
401			#
402			# We're going to make the assumption that control got here
403			# through valid means, i.e., that the caller used an instance
404			# or class method call, and that control got here through the
405			# usual inheritance mechanisms. The caller can, of course,
406			# break this assumption by playing silly buggers, but that's
407			# harder to do than doing it properly, and harder to check
408			# for.
409			if (ref($self) eq "")
410			{
411			# Class method. The new context is the next argument.
412			$new_context = shift;
413			} else {
414			# Instance method. The new context is $self.
415			$new_context = $self;
416			}
417
418			# Save the old context, if any, on the stack
419			push @context_stack, $context if defined($context);
420
421			# Set the new context
422			$context = $new_context;
423			}
424
425			=head2 restore_context
426
427			&restore_context;
428
429			Restores the context set by C<&set_context>.
430
431			=cut
432
433			#'
434			sub restore_context
435			{
436			my $self = shift;
437
438			if ($#context_stack < 0)
439			{
440			# Stack underflow.
441			die "Context stack underflow";
442			}
443
444			# Pop the old context and set it.
445			$context = pop @context_stack;
446
447			# FIXME - Should this return something, like maybe the context
448			# that was current when this was called?
449			}
450
451			=head2 config
452
453			$value = C4::Context->config("config_variable");
454
455			$value = C4::Context->config_variable;
456
457			Returns the value of a variable specified in the configuration file
458			from which the current context was created.
459
460			The second form is more compact, but of course may conflict with
461			method names. If there is a configuration variable called "new", then
462			C<C4::Config-E<gt>new> will not return it.
463
464			=cut
465
466			sub _common_config {
467			my $var = shift;
468			my $term = shift;
469			return if !defined($context->{$term});
470			# Presumably $self->{$term} might be
471			# undefined if the config file given to &new
472			# didn't exist, and the caller didn't bother
473			# to check the return value.
474
475			# Return the value of the requested config variable
476			return $context->{$term}->{$var};
477			}
478
479			sub config {
480			return _common_config($_[1],'config');
481			}
482			sub zebraconfig {
483			return _common_config($_[1],'server');
484			}
485			sub ModZebrations {
486			return _common_config($_[1],'serverinfo');
487			}
488
489			=head2 preference
490
491			$sys_preference = C4::Context->preference('some_variable');
492
493			Looks up the value of the given system preference in the
494			systempreferences table of the Koha database, and returns it. If the
495			variable is not set or does not exist, undef is returned.
496
497			In case of an error, this may return 0.
498
499			Note: It is impossible to tell the difference between system
500			preferences which do not exist, and those whose values are set to NULL
501			with this method.
502
503			=cut
504
505			# FIXME: running this under mod_perl will require a means of
506			# flushing the caching mechanism.
507
508			my %sysprefs;
509			my $use_syspref_cache = 1;
510
511			sub preference {
512			my $self = shift;
513			my $var = shift; # The system preference to return
514
515			if ($use_syspref_cache && exists $sysprefs{lc $var}) {
516			return $sysprefs{lc $var};
517			}
518
519			my $dbh = C4::Context->dbh or return 0;
520
521			my $value;
522			if ( defined $ENV{"OVERRIDE_SYSPREF_$var"} ) {
523			$value = $ENV{"OVERRIDE_SYSPREF_$var"};
524			} else {
525			my $syspref;
526			eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
527			$value = $syspref ? $syspref->value() : undef;
528			}
529
530			$sysprefs{lc $var} = $value;
531			return $value;
532			}
533
534			sub boolean_preference {
535			my $self = shift;
536			my $var = shift; # The system preference to return
537			my $it = preference($self, $var);
538			return defined($it)? C4::Boolean::true_p($it): undef;
539			}
540
541			=head2 enable_syspref_cache
542
543			C4::Context->enable_syspref_cache();
544
545			Enable the in-memory syspref cache used by C4::Context. This is the
546			default behavior.
547
548			=cut
549
550			sub enable_syspref_cache {
551			my ($self) = @_;
552			$use_syspref_cache = 1;
553			}
554
555			=head2 disable_syspref_cache
556
557			C4::Context->disable_syspref_cache();
558
559			Disable the in-memory syspref cache used by C4::Context. This should be
560			used with Plack and other persistent environments.
561
562			=cut
563
564			sub disable_syspref_cache {
565			my ($self) = @_;
566			$use_syspref_cache = 0;
567			$self->clear_syspref_cache();
568			}
569
570			=head2 clear_syspref_cache
571
572			C4::Context->clear_syspref_cache();
573
574			cleans the internal cache of sysprefs. Please call this method if
575			you update the systempreferences table. Otherwise, your new changes
576			will not be seen by this process.
577
578			=cut
579
580			sub clear_syspref_cache {
581			%sysprefs = ();
582			}
583
584			=head2 set_preference
585
586			C4::Context->set_preference( $variable, $value );
587
588			This updates a preference's value both in the systempreferences table and in
589			the sysprefs cache.
590
591			=cut
592
593			sub set_preference {
594			my $self = shift;
595			my $var = lc(shift);
596			my $value = shift;
597
598			my $syspref = Koha::Config::SysPrefs->find( $var );
599			my $type = $syspref ? $syspref->type() : undef;
600
601			$value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
602
603			# force explicit protocol on OPACBaseURL
604			if ($var eq 'opacbaseurl' && substr($value,0,4) !~ /http/) {
605			$value = 'http://' . $value;
606			}
607
608			if ($syspref) {
609			$syspref = $syspref->set( { value => $value } )->store();
610			}
611			else {
612			$syspref = Koha::Config::SysPref->new( { variable => $var, value => $value } )->store();
613			}
614
615			if ($syspref) {
616			$sysprefs{$var} = $value;
617			}
618			}
619
620			=head2 Zconn
621
622			$Zconn = C4::Context->Zconn
623
624			Returns a connection to the Zebra database
625
626			C<$self>
627
628			C<$server> one of the servers defined in the koha-conf.xml file
629
630			C<$async> whether this is a asynchronous connection
631
632			=cut
633
634			sub Zconn {
635			my ($self, $server, $async ) = @_;
636			my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
637			if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
638			# if we are running the script from the commandline, lets try to use the caching
639			return $context->{"Zconn"}->{$cache_key};
640			}
641			$context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
642			$context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
643			return $context->{"Zconn"}->{$cache_key};
644			}
645
646			=head2 _new_Zconn
647
648			$context->{"Zconn"} = &_new_Zconn($server,$async);
649
650			Internal function. Creates a new database connection from the data given in the current context and returns it.
651
652			C<$server> one of the servers defined in the koha-conf.xml file
653
654			C<$async> whether this is a asynchronous connection
655
656			C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
657
658			=cut
659
660			sub _new_Zconn {
661			my ( $server, $async ) = @_;
662
663			my $tried=0; # first attempt
664			my $Zconn; # connection object
665			my $elementSetName;
666			my $index_mode;
667			my $syntax;
668
669			$server //= "biblioserver";
670
671			if ( $server eq 'biblioserver' ) {
672			$index_mode = $context->{'config'}->{'zebra_bib_index_mode'} // 'dom';
673			} elsif ( $server eq 'authorityserver' ) {
674			$index_mode = $context->{'config'}->{'zebra_auth_index_mode'} // 'dom';
675			}
676
677			if ( $index_mode eq 'grs1' ) {
678			$elementSetName = 'F';
679			$syntax = ( $context->preference("marcflavour") eq 'UNIMARC' )
680			? 'unimarc'
681			: 'usmarc';
682
683			} else { # $index_mode eq 'dom'
684			$syntax = 'xml';
685			$elementSetName = 'marcxml';
686			}
687
688			my $host = $context->{'listen'}->{$server}->{'content'};
689			my $user = $context->{"serverinfo"}->{$server}->{"user"};
690			my $password = $context->{"serverinfo"}->{$server}->{"password"};
691			eval {
692			# set options
693			my $o = new ZOOM::Options();
694			$o->option(user => $user) if $user && $password;
695			$o->option(password => $password) if $user && $password;
696			$o->option(async => 1) if $async;
697			$o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
698			$o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
699			$o->option(preferredRecordSyntax => $syntax);
700			$o->option(elementSetName => $elementSetName) if $elementSetName;
701			$o->option(databaseName => $context->{"config"}->{$server}\|\|"biblios");
702
703			# create a new connection object
704			$Zconn= create ZOOM::Connection($o);
705
706			# forge to server
707			$Zconn->connect($host, 0);
708
709			# check for errors and warn
710			if ($Zconn->errcode() !=0) {
711			warn "something wrong with the connection: ". $Zconn->errmsg();
712			}
713			};
714			return $Zconn;
715			}
716
717			# _new_dbh
718			# Internal helper function (not a method!). This creates a new
719			# database connection from the data given in the current context, and
720			# returns it.
721			sub _new_dbh
722			{
723
724			Koha::Database->schema({ new => 1 })->storage->dbh;
725			}
726
727			=head2 dbh
728
729			$dbh = C4::Context->dbh;
730
731			Returns a database handle connected to the Koha database for the
732			current context. If no connection has yet been made, this method
733			creates one, and connects to the database.
734
735			This database handle is cached for future use: if you call
736			C<C4::Context-E<gt>dbh> twice, you will get the same handle both
737			times. If you need a second database handle, use C<&new_dbh> and
738			possibly C<&set_dbh>.
739
740			=cut
741
742			#'
743			sub dbh
744			{
745			my $self = shift;
746			my $params = shift;
747			my $sth;
748
749	1	2.77ms	unless ( $params->{new} ) {
750			return Koha::Database->schema->storage->dbh;
751			}
752
753			return Koha::Database->schema({ new => 1 })->storage->dbh;
754			}
755
756			=head2 new_dbh
757
758			$dbh = C4::Context->new_dbh;
759
760			Creates a new connection to the Koha database for the current context,
761			and returns the database handle (a C<DBI::db> object).
762
763			The handle is not saved anywhere: this method is strictly a
764			convenience function; the point is that it knows which database to
765			connect to so that the caller doesn't have to know.
766
767			=cut
768
769			#'
770			sub new_dbh
771			{
772			my $self = shift;
773
774			return &dbh({ new => 1 });
775			}
776
777			=head2 set_dbh
778
779			$my_dbh = C4::Connect->new_dbh;
780			C4::Connect->set_dbh($my_dbh);
781			...
782			C4::Connect->restore_dbh;
783
784			C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
785			C<&set_context> and C<&restore_context>.
786
787			C<&set_dbh> saves the current database handle on a stack, then sets
788			the current database handle to C<$my_dbh>.
789
790			C<$my_dbh> is assumed to be a good database handle.
791
792			=cut
793
794			#'
795			sub set_dbh
796			{
797			my $self = shift;
798			my $new_dbh = shift;
799
800			# Save the current database handle on the handle stack.
801			# We assume that $new_dbh is all good: if the caller wants to
802			# screw himself by passing an invalid handle, that's fine by
803			# us.
804			push @{$context->{"dbh_stack"}}, $context->{"dbh"};
805			$context->{"dbh"} = $new_dbh;
806			}
807
808			=head2 restore_dbh
809
810			C4::Context->restore_dbh;
811
812			Restores the database handle saved by an earlier call to
813			C<C4::Context-E<gt>set_dbh>.
814
815			=cut
816
817			#'
818			sub restore_dbh
819			{
820			my $self = shift;
821
822			if ($#{$context->{"dbh_stack"}} < 0)
823			{
824			# Stack underflow
825			die "DBH stack underflow";
826			}
827
828			# Pop the old database handle and set it.
829			$context->{"dbh"} = pop @{$context->{"dbh_stack"}};
830
831			# FIXME - If it is determined that restore_context should
832			# return something, then this function should, too.
833			}
834
835			=head2 queryparser
836
837			$queryparser = C4::Context->queryparser
838
839			Returns a handle to an initialized Koha::QueryParser::Driver::PQF object.
840
841			=cut
842
843			sub queryparser {
844			my $self = shift;
845			unless (defined $context->{"queryparser"}) {
846			$context->{"queryparser"} = &_new_queryparser();
847			}
848
849			return
850			defined( $context->{"queryparser"} )
851			? $context->{"queryparser"}->new
852			: undef;
853			}
854
855			=head2 _new_queryparser
856
857			Internal helper function to create a new QueryParser object. QueryParser
858			is loaded dynamically so as to keep the lack of the QueryParser library from
859			getting in anyone's way.
860
861			=cut
862
863			sub _new_queryparser {
864			my $qpmodules = {
865			'OpenILS::QueryParser' => undef,
866			'Koha::QueryParser::Driver::PQF' => undef
867			};
868			if ( can_load( 'modules' => $qpmodules ) ) {
869			my $QParser = Koha::QueryParser::Driver::PQF->new();
870			my $config_file = $context->config('queryparser_config');
871			$config_file \|\|= '/etc/koha/searchengine/queryparser.yaml';
872			if ( $QParser->load_config($config_file) ) {
873			# Set 'keyword' as the default search class
874			$QParser->default_search_class('keyword');
875			# TODO: allow indexes to be configured in the database
876			return $QParser;
877			}
878			}
879			return;
880			}
881
882			=head2 marcfromkohafield
883
884			$dbh = C4::Context->marcfromkohafield;
885
886			Returns a hash with marcfromkohafield.
887
888			This hash is cached for future use: if you call
889			C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access
890
891			=cut
892
893			#'
894			sub marcfromkohafield
895			{
896			my $retval = {};
897
898			# If the hash already exists, return it.
899			return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
900
901			# No hash. Create one.
902			$context->{"marcfromkohafield"} = &_new_marcfromkohafield();
903
904			return $context->{"marcfromkohafield"};
905			}
906
907			# _new_marcfromkohafield
908			sub _new_marcfromkohafield
909			{
910			my $dbh = C4::Context->dbh;
911			my $marcfromkohafield;
912			my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
913			$sth->execute;
914			while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
915			my $retval = {};
916			$marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
917			}
918			return $marcfromkohafield;
919			}
920
921			=head2 userenv
922
923			C4::Context->userenv;
924
925			Retrieves a hash for user environment variables.
926
927			This hash shall be cached for future use: if you call
928			C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
929
930			=cut
931
932			#'
933			sub userenv {
934			my $var = $context->{"activeuser"};
935			if (defined $var and defined $context->{"userenv"}->{$var}) {
936			return $context->{"userenv"}->{$var};
937			} else {
938			return;
939			}
940			}
941
942			=head2 set_userenv
943
944			C4::Context->set_userenv($usernum, $userid, $usercnum,
945			$userfirstname, $usersurname,
946			$userbranch, $branchname, $userflags,
947			$emailaddress, $branchprinter, $persona);
948
949			Establish a hash of user environment variables.
950
951			set_userenv is called in Auth.pm
952
953			=cut
954
955			#'
956			sub set_userenv {
957			shift @_;
958			my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter, $persona, $shibboleth)=
959			map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
960			@_;
961			my $var=$context->{"activeuser"} \|\| '';
962			my $cell = {
963			"number" => $usernum,
964			"id" => $userid,
965			"cardnumber" => $usercnum,
966			"firstname" => $userfirstname,
967			"surname" => $usersurname,
968			#possibly a law problem
969			"branch" => $userbranch,
970			"branchname" => $branchname,
971			"flags" => $userflags,
972			"emailaddress" => $emailaddress,
973			"branchprinter" => $branchprinter,
974			"persona" => $persona,
975			"shibboleth" => $shibboleth,
976			};
977			$context->{userenv}->{$var} = $cell;
978			return $cell;
979			}
980
981			sub set_shelves_userenv {
982			my ($type, $shelves) = @_ or return;
983			my $activeuser = $context->{activeuser} or return;
984			$context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
985			$context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
986			$context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
987			}
988
989			sub get_shelves_userenv {
990			my $active;
991			unless ($active = $context->{userenv}->{$context->{activeuser}}) {
992			$debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
993			return;
994			}
995			my $totshelves = $active->{totshelves} or undef;
996			my $pubshelves = $active->{pubshelves} or undef;
997			my $barshelves = $active->{barshelves} or undef;
998			return ($totshelves, $pubshelves, $barshelves);
999			}
1000
1001			=head2 _new_userenv
1002
1003			C4::Context->_new_userenv($session); # FIXME: This calling style is wrong for what looks like an _internal function
1004
1005			Builds a hash for user environment variables.
1006
1007			This hash shall be cached for future use: if you call
1008			C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
1009
1010			_new_userenv is called in Auth.pm
1011
1012			=cut
1013
1014			#'
1015			sub _new_userenv
1016			{
1017			shift; # Useless except it compensates for bad calling style
1018			my ($sessionID)= @_;
1019			$context->{"activeuser"}=$sessionID;
1020			}
1021
1022			=head2 _unset_userenv
1023
1024			C4::Context->_unset_userenv;
1025
1026			Destroys the hash for activeuser user environment variables.
1027
1028			=cut
1029
1030			#'
1031
1032			sub _unset_userenv
1033			{
1034			my ($sessionID)= @_;
1035			undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1036			}
1037
1038
1039			=head2 get_versions
1040
1041			C4::Context->get_versions
1042
1043			Gets 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'.
1044
1045			=cut
1046
1047			#'
1048
1049			# A little example sub to show more debugging info for CGI::Carp
1050			sub get_versions {
1051			my %versions;
1052			$versions{kohaVersion} = Koha::version();
1053			$versions{kohaDbVersion} = C4::Context->preference('version');
1054			$versions{osVersion} = join(" ", POSIX::uname());
1055			$versions{perlVersion} = $];
1056			{
1057			no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1058			$versions{mysqlVersion} = `mysql -V`;
1059			$versions{apacheVersion} = `httpd -v`;
1060			$versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
1061			$versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
1062			$versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
1063			}
1064			return %versions;
1065			}
1066
1067
1068			=head2 tz
1069
1070			C4::Context->tz
1071
1072			Returns a DateTime::TimeZone object for the system timezone
1073
1074			=cut
1075
1076			sub tz {
1077			my $self = shift;
1078			if (!defined $context->{tz}) {
1079			$context->{tz} = DateTime::TimeZone->new(name => 'local');
1080			}
1081			return $context->{tz};
1082			}
1083
1084
1085			=head2 IsSuperLibrarian
1086
1087			C4::Context->IsSuperLibrarian();
1088
1089			=cut
1090
1091			sub IsSuperLibrarian {
1092			my $userenv = C4::Context->userenv;
1093
1094			unless ( $userenv and exists $userenv->{flags} ) {
1095			# If we reach this without a user environment,
1096			# assume that we're running from a command-line script,
1097			# and act as a superlibrarian.
1098			carp("C4::Context->userenv not defined!");
1099			return 1;
1100			}
1101
1102			return ($userenv->{flags}//0) % 2;
1103			}
1104
1105			=head2 interface
1106
1107			Sets the current interface for later retrieval in any Perl module
1108
1109			C4::Context->interface('opac');
1110			C4::Context->interface('intranet');
1111			my $interface = C4::Context->interface;
1112
1113			=cut
1114
1115			sub interface {
1116			my ($class, $interface) = @_;
1117
1118			if (defined $interface) {
1119			$interface = lc $interface;
1120			if ($interface eq 'opac' \|\| $interface eq 'intranet') {
1121			$context->{interface} = $interface;
1122			} else {
1123			warn "invalid interface : '$interface'";
1124			}
1125			}
1126
1127			return $context->{interface} // 'opac';
1128			}
1129
1130			1;
1131			__END__
1132
1133			=head1 ENVIRONMENT
1134
1135			=head2 C<KOHA_CONF>
1136
1137			Specifies the configuration file to read.
1138
1139			=head1 SEE ALSO
1140
1141			XML::Simple
1142
1143			=head1 AUTHORS
1144
1145			Andrew Arensburger <arensb at ooblick dot com>
1146
1147			Joshua Ferraro <jmf at liblime dot com>
1148