File Coverage

File:C4/Context.pm
Coverage:24.4%

linestmtbrancondsubtimecode
1package C4::Context;
2# Copyright 2002 Katipo Communications
3#
4# This file is part of Koha.
5#
6# Koha is free software; you can redistribute it and/or modify it under the
7# terms of the GNU General Public License as published by the Free Software
8# Foundation; either version 2 of the License, or (at your option) any later
9# version.
10#
11# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
12# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
13# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
14#
15# You should have received a copy of the GNU General Public License along
16# with Koha; if not, write to the Free Software Foundation, Inc.,
17# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
18
19
58
58
58
519
314
1973
use strict;
20
58
58
58
606
299
3644
use warnings;
21
58
58
58
591
339
29664
use vars qw($VERSION $AUTOLOAD $context @context_stack $servers $memcached $ismemcached);
22
23BEGIN {
24
58
586
        if ($ENV{'HTTP_USER_AGENT'}) {
25
0
0
                require CGI::Carp;
26        # FIXME for future reference, CGI::Carp doc says
27        # "Note that fatalsToBrowser does not work with mod_perl version 2.0 and higher."
28
0
0
                import CGI::Carp qw(fatalsToBrowser);
29                        sub handle_errors {
30
0
0
                            my $msg = shift;
31
0
0
                            my $debug_level;
32
0
0
0
0
                            eval {C4::Context->dbh();};
33
0
0
                            if ($@){
34
0
0
                                $debug_level = 1;
35                            }
36                            else {
37
0
0
                                $debug_level = C4::Context->preference("DebugLevel");
38                            }
39
40
0
0
                print q(<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
41                            "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
42                       <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
43                       <head><title>Koha Error</title></head>
44                       <body>
45                );
46
0
0
                                if ($debug_level eq "2"){
47                                        # debug 2 , print extra info too.
48
0
0
                                        my %versions = get_versions();
49
50                # a little example table with various version info";
51
0
0
                                        print "
52                                                <h1>Koha error</h1>
53                                                <p>The following fatal error has occurred:</p>
54                        <pre><code>$msg</code></pre>
55                                                <table>
56                                                <tr><th>Apache</th><td> $versions{apacheVersion}</td></tr>
57                                                <tr><th>Koha</th><td> $versions{kohaVersion}</td></tr>
58                                                <tr><th>Koha DB</th><td> $versions{kohaDbVersion}</td></tr>
59                                                <tr><th>MySQL</th><td> $versions{mysqlVersion}</td></tr>
60                                                <tr><th>OS</th><td> $versions{osVersion}</td></tr>
61                                                <tr><th>Perl</th><td> $versions{perlVersion}</td></tr>
62                                                </table>";
63
64                                } elsif ($debug_level eq "1"){
65
0
0
                                        print "
66                                                <h1>Koha error</h1>
67                                                <p>The following fatal error has occurred:</p>
68                        <pre><code>$msg</code></pre>";
69                                } else {
70
0
0
                                        print "<p>production mode - trapped fatal error</p>";
71                                }
72
0
0
                print "</body></html>";
73                        }
74                #CGI::Carp::set_message(\&handle_errors);
75                ## give a stack backtrace if KOHA_BACKTRACES is set
76                ## can't rely on DebugLevel for this, as we're not yet connected
77
0
0
                if ($ENV{KOHA_BACKTRACES}) {
78
0
0
                        $main::SIG{__DIE__} = \&CGI::Carp::confess;
79                }
80    } # else there is no browser to send fatals to!
81
82    # Check if there are memcached servers set
83
58
353
    $servers = $ENV{'MEMCACHED_SERVERS'};
84
58
328
    if ($servers) {
85        # Load required libraries and create the memcached object
86
0
0
        require Cache::Memcached;
87
0
0
        $memcached = Cache::Memcached->new({
88        servers => [ $servers ],
89        debug => 0,
90        compress_threshold => 10_000,
91        expire_time => 600,
92        namespace => $ENV{'MEMCACHED_NAMESPACE'} || 'koha'
93    });
94        # Verify memcached available (set a variable and test the output)
95
0
0
    $ismemcached = $memcached->set('ismemcached','1');
96    }
97
98
58
1712
    $VERSION = '3.00.00.036';
99}
100
101
58
58
58
61170
1402893
5060
use DBI;
102
58
58
58
30208
1239928
3850
use ZOOM;
103
58
58
58
34814
677933
2220
use XML::Simple;
104
58
58
58
17507
291
3018
use C4::Boolean;
105
58
58
58
11358
158
6257
use C4::Debug;
106
58
58
58
20117
317599
11964
use POSIX ();
107
108 - 157
=head1 NAME

C4::Context - Maintain and manipulate the context of a Koha script

=head1 SYNOPSIS

  use C4::Context;

  use C4::Context("/path/to/koha-conf.xml");

  $config_value = C4::Context->config("config_variable");

  $koha_preference = C4::Context->preference("preference");

  $db_handle = C4::Context->dbh;

  $Zconn = C4::Context->Zconn;

  $stopwordhash = C4::Context->stopwords;

=head1 DESCRIPTION

When a Koha script runs, it makes use of a certain number of things:
configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
databases, and so forth. These things make up the I<context> in which
the script runs.

This module takes care of setting up the context for a script:
figuring out which configuration file to load, and loading it, opening
a connection to the right database, and so forth.

Most scripts will only use one context. They can simply have

  use C4::Context;

at the top.

Other scripts may need to use several contexts. For instance, if a
library has two databases, one for a certain collection, and the other
for everything else, it might be necessary for a script to use two
different contexts to search both databases. Such scripts should use
the C<&set_context> and C<&restore_context> functions, below.

By default, C4::Context reads the configuration from
F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
environment variable to the pathname of a configuration file to use.

=head1 METHODS

=cut
158
159#'
160# In addition to what is said in the POD above, a Context object is a
161# reference-to-hash with the following fields:
162#
163# config
164# A reference-to-hash whose keys and values are the
165# configuration variables and values specified in the config
166# file (/etc/koha/koha-conf.xml).
167# dbh
168# A handle to the appropriate database for this context.
169# dbh_stack
170# Used by &set_dbh and &restore_dbh to hold other database
171# handles for this context.
172# Zconn
173# A connection object for the Zebra server
174
175# Koha's main configuration file koha-conf.xml
176# is searched for according to this priority list:
177#
178# 1. Path supplied via use C4::Context '/path/to/koha-conf.xml'
179# 2. Path supplied in KOHA_CONF environment variable.
180# 3. Path supplied in INSTALLED_CONFIG_FNAME, as long
181# as value has changed from its default of
182# '__KOHA_CONF_DIR__/koha-conf.xml', as happens
183# when Koha is installed in 'standard' or 'single'
184# mode.
185# 4. Path supplied in CONFIG_FNAME.
186#
187# The first entry that refers to a readable file is used.
188
189
58
58
58
1524
877
1431
use constant CONFIG_FNAME => "/etc/koha/koha-conf.xml";
190                # Default config file, if none is specified
191
192my $INSTALLED_CONFIG_FNAME = '__KOHA_CONF_DIR__/koha-conf.xml';
193                # path to config file set by installer
194                # __KOHA_CONF_DIR__ is set by rewrite-confg.PL
195                # when Koha is installed in 'standard' or 'single'
196                # mode. If Koha was installed in 'dev' mode,
197                # __KOHA_CONF_DIR__ is *not* rewritten; instead
198                # developers should set the KOHA_CONF environment variable
199
200$context = undef; # Initially, no context is set
201@context_stack = (); # Initially, no saved contexts
202
203
204 - 208
=head2 KOHAVERSION

returns the kohaversion stored in kohaversion.pl file

=cut
209
210sub KOHAVERSION {
211
0
0
    my $cgidir = C4::Context->intranetdir;
212
213    # Apparently the GIT code does not run out of a CGI-BIN subdirectory
214    # but distribution code does? (Stan, 1jan08)
215
0
0
    if(-d $cgidir . "/cgi-bin"){
216
0
0
        my $cgidir .= "/cgi-bin";
217    }
218
219
0
0
    do $cgidir."/kohaversion.pl" || die "NO $cgidir/kohaversion.pl";
220
0
0
    return kohaversion();
221}
222 - 245
=head2 read_config_file

Reads the specified Koha config file. 

Returns an object containing the configuration variables. The object's
structure is a bit complex to the uninitiated ... take a look at the
koha-conf.xml file as well as the XML::Simple documentation for details. Or,
here are a few examples that may give you what you need:

The simple elements nested within the <config> element:

    my $pass = $koha->{'config'}->{'pass'};

The <listen> elements:

    my $listen = $koha->{'listen'}->{'biblioserver'}->{'content'};

The elements nested within the <server> element:

    my $ccl2rpn = $koha->{'server'}->{'biblioserver'}->{'cql2rpn'};

Returns undef in case of error.

=cut
246
247sub read_config_file { # Pass argument naming config file to read
248
58
1068
    my $koha = XMLin(shift, keyattr => ['id'], forcearray => ['listen', 'server', 'serverinfo'], suppressempty => '');
249
250
58
7014356
    if ($ismemcached) {
251
0
0
      $memcached->set('kohaconf',$koha);
252    }
253
254
58
1143
    return $koha; # Return value: ref-to-hash holding the configuration
255}
256
257 - 261
=head2 ismemcached

Returns the value of the $ismemcached variable (0/1)

=cut
262
263sub ismemcached {
264
23
671
    return $ismemcached;
265}
266
267 - 272
=head2 memcached

If $ismemcached is true, returns the $memcache variable.
Returns undef otherwise

=cut
273
274sub memcached {
275
0
0
    if ($ismemcached) {
276
0
0
      return $memcached;
277    } else {
278
0
0
      return undef;
279    }
280}
281
282# db_scheme2dbi
283# Translates the full text name of a database into de appropiate dbi name
284#
285sub db_scheme2dbi {
286
0
0
    my $name = shift;
287    # for instance, we support only mysql, so don't care checking
288
0
0
    return "mysql";
289
0
0
    for ($name) {
290# FIXME - Should have other databases.
291
0
0
0
0
        if (/mysql/) { return("mysql"); }
292
0
0
0
0
        if (/Postgres|Pg|PostgresSQL/) { return("Pg"); }
293
0
0
0
0
        if (/oracle/) { return("Oracle"); }
294    }
295
0
0
    return undef; # Just in case
296}
297
298sub import {
299    # Create the default context ($C4::Context::Context)
300    # the first time the module is called
301    # (a config file can be optionaly passed)
302
303    # default context allready exists?
304
446
28769
    return if $context;
305
306    # no ? so load it!
307
58
736
    my ($pkg,$config_file) = @_ ;
308
58
694
    my $new_ctx = __PACKAGE__->new($config_file);
309
58
519
    return unless $new_ctx;
310
311    # if successfully loaded, use it by default
312
58
515
    $new_ctx->set_context;
313
58
4006
    1;
314}
315
316 - 332
=head2 new

  $context = new C4::Context;
  $context = new C4::Context("/path/to/koha-conf.xml");

Allocates a new context. Initializes the context from the specified
file, which defaults to either the file given by the C<$KOHA_CONF>
environment variable, or F</etc/koha/koha-conf.xml>.

It saves the koha-conf.xml values in the declared memcached server(s)
if currently available and uses those values until them expire and
re-reads them.

C<&new> does not set this context as the new default context; for
that, use C<&set_context>.

=cut
333
334#'
335# Revision History:
336# 2004-08-10 A. Tarallo: Added check if the conf file is not empty
337sub new {
338
58
597
    my $class = shift;
339
58
788
    my $conf_fname = shift; # Config file to load
340
58
458
    my $self = {};
341
342    # check that the specified config file exists and is not empty
343
58
746
    undef $conf_fname unless
344        (defined $conf_fname && -s $conf_fname);
345    # Figure out a good config file to load if none was specified.
346
58
647
    if (!defined($conf_fname))
347    {
348        # If the $KOHA_CONF environment variable is set, use
349        # that. Otherwise, use the built-in default.
350
58
2182
        if (exists $ENV{"KOHA_CONF"} and $ENV{'KOHA_CONF'} and -s $ENV{"KOHA_CONF"}) {
351
58
626
            $conf_fname = $ENV{"KOHA_CONF"};
352        } elsif ($INSTALLED_CONFIG_FNAME !~ /__KOHA_CONF_DIR/ and -s $INSTALLED_CONFIG_FNAME) {
353            # NOTE: be careful -- don't change __KOHA_CONF_DIR in the above
354            # regex to anything else -- don't want installer to rewrite it
355
0
0
            $conf_fname = $INSTALLED_CONFIG_FNAME;
356        } elsif (-s CONFIG_FNAME) {
357
0
0
            $conf_fname = CONFIG_FNAME;
358        } else {
359
0
0
            warn "unable to locate Koha configuration file koha-conf.xml";
360
0
0
            return undef;
361        }
362    }
363
364
58
415
    if ($ismemcached) {
365        # retreive from memcached
366
0
0
        $self = $memcached->get('kohaconf');
367
0
0
        if (not defined $self) {
368            # not in memcached yet
369
0
0
            $self = read_config_file($conf_fname);
370        }
371    } else {
372        # non-memcached env, read from file
373
58
405
        $self = read_config_file($conf_fname);
374    }
375
376
58
1005
    $self->{"config_file"} = $conf_fname;
377
58
999
    warn "read_config_file($conf_fname) returned undef" if !defined($self->{"config"});
378
58
855
    return undef if !defined($self->{"config"});
379
380
58
729
    $self->{"dbh"} = undef; # Database handle
381
58
792
    $self->{"Zconn"} = undef; # Zebra Connections
382
58
1109
    $self->{"stopwords"} = undef; # stopwords list
383
58
731
    $self->{"marcfromkohafield"} = undef; # the hash with relations between koha table fields and MARC field/subfield
384
58
654
    $self->{"userenv"} = undef; # User env
385
58
538
    $self->{"activeuser"} = undef; # current active user
386
58
546
    $self->{"shelves"} = undef;
387
388
58
1144
    bless $self, $class;
389
58
541
    return $self;
390}
391
392 - 407
=head2 set_context

  $context = new C4::Context;
  $context->set_context();
or
  set_context C4::Context $context;

  ...
  restore_context C4::Context;

In some cases, it might be necessary for a script to use multiple
contexts. C<&set_context> saves the current context on a stack, then
sets the context to C<$context>, which will be used in future
operations. To restore the previous context, use C<&restore_context>.

=cut
408
409#'
410sub set_context
411{
412
58
425
    my $self = shift;
413
58
379
    my $new_context; # The context to set
414
415    # Figure out whether this is a class or instance method call.
416    #
417    # We're going to make the assumption that control got here
418    # through valid means, i.e., that the caller used an instance
419    # or class method call, and that control got here through the
420    # usual inheritance mechanisms. The caller can, of course,
421    # break this assumption by playing silly buggers, but that's
422    # harder to do than doing it properly, and harder to check
423    # for.
424
58
504
    if (ref($self) eq "")
425    {
426        # Class method. The new context is the next argument.
427
0
0
        $new_context = shift;
428    } else {
429        # Instance method. The new context is $self.
430
58
458
        $new_context = $self;
431    }
432
433    # Save the old context, if any, on the stack
434
58
433
    push @context_stack, $context if defined($context);
435
436    # Set the new context
437
58
360
    $context = $new_context;
438}
439
440 - 446
=head2 restore_context

  &restore_context;

Restores the context set by C<&set_context>.

=cut
447
448#'
449sub restore_context
450{
451
0
0
    my $self = shift;
452
453
0
0
    if ($#context_stack < 0)
454    {
455        # Stack underflow.
456
0
0
        die "Context stack underflow";
457    }
458
459    # Pop the old context and set it.
460
0
0
    $context = pop @context_stack;
461
462    # FIXME - Should this return something, like maybe the context
463    # that was current when this was called?
464}
465
466 - 479
=head2 config

  $value = C4::Context->config("config_variable");

  $value = C4::Context->config_variable;

Returns the value of a variable specified in the configuration file
from which the current context was created.

The second form is more compact, but of course may conflict with
method names. If there is a configuration variable called "new", then
C<C4::Config-E<gt>new> will not return it.

=cut
480
481sub _common_config ($$) {
482
18
166
        my $var = shift;
483
18
138
        my $term = shift;
484
18
200
    return undef if !defined($context->{$term});
485       # Presumably $self->{$term} might be
486       # undefined if the config file given to &new
487       # didn't exist, and the caller didn't bother
488       # to check the return value.
489
490    # Return the value of the requested config variable
491
18
390
    return $context->{$term}->{$var};
492}
493
494sub config {
495
18
199
        return _common_config($_[1],'config');
496}
497sub zebraconfig {
498
0
0
        return _common_config($_[1],'server');
499}
500sub ModZebrations {
501
0
0
        return _common_config($_[1],'serverinfo');
502}
503
504 - 518
=head2 preference

  $sys_preference = C4::Context->preference('some_variable');

Looks up the value of the given system preference in the
systempreferences table of the Koha database, and returns it. If the
variable is not set or does not exist, undef is returned.

In case of an error, this may return 0.

Note: It is impossible to tell the difference between system
preferences which do not exist, and those whose values are set to NULL
with this method.

=cut
519
520# FIXME: running this under mod_perl will require a means of
521# flushing the caching mechanism.
522
523my %sysprefs;
524
525sub preference {
526
0
0
    my $self = shift;
527
0
0
    my $var = lc(shift); # The system preference to return
528
529
0
0
    if (exists $sysprefs{$var}) {
530
0
0
        return $sysprefs{$var};
531    }
532
533
0
0
    my $dbh = C4::Context->dbh or return 0;
534
535    # Look up systempreferences.variable==$var
536
0
0
    my $sql = <<'END_SQL';
537        SELECT value
538        FROM systempreferences
539        WHERE variable=?
540        LIMIT 1
541END_SQL
542
0
0
    $sysprefs{$var} = $dbh->selectrow_array( $sql, {}, $var );
543
0
0
    return $sysprefs{$var};
544}
545
546sub boolean_preference ($) {
547
0
0
    my $self = shift;
548
0
0
    my $var = shift; # The system preference to return
549
0
0
    my $it = preference($self, $var);
550
0
0
    return defined($it)? C4::Boolean::true_p($it): undef;
551}
552
553 - 561
=head2 clear_syspref_cache

  C4::Context->clear_syspref_cache();

cleans the internal cache of sysprefs. Please call this method if
you update the systempreferences table. Otherwise, your new changes
will not be seen by this process.

=cut
562
563sub clear_syspref_cache {
564
0
0
    %sysprefs = ();
565}
566
567 - 574
=head2 set_preference

  C4::Context->set_preference( $variable, $value );

This updates a preference's value both in the systempreferences table and in
the sysprefs cache.

=cut
575
576sub set_preference {
577
0
0
    my $self = shift;
578
0
0
    my $var = lc(shift);
579
0
0
    my $value = shift;
580
581
0
0
    my $dbh = C4::Context->dbh or return 0;
582
583
0
0
    my $type = $dbh->selectrow_array( "SELECT type FROM systempreferences WHERE variable = ?", {}, $var );
584
585
0
0
    $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
586
587
0
0
    my $sth = $dbh->prepare( "
588      INSERT INTO systempreferences
589        ( variable, value )
590        VALUES( ?, ? )
591        ON DUPLICATE KEY UPDATE value = VALUES(value)
592    " );
593
594
0
0
    if($sth->execute( $var, $value )) {
595
0
0
        $sysprefs{$var} = $value;
596    }
597
0
0
    $sth->finish;
598}
599
600# AUTOLOAD
601# This implements C4::Config->foo, and simply returns
602# C4::Context->config("foo"), as described in the documentation for
603# &config, above.
604
605# FIXME - Perhaps this should be extended to check &config first, and
606# then &preference if that fails. OTOH, AUTOLOAD could lead to crappy
607# code, so it'd probably be best to delete it altogether so as not to
608# encourage people to use it.
609sub AUTOLOAD
610{
611
0
0
    my $self = shift;
612
613
0
0
    $AUTOLOAD =~ s/.*:://; # Chop off the package name,
614                    # leaving only the function name.
615
0
0
    return $self->config($AUTOLOAD);
616}
617
618 - 635
=head2 Zconn

  $Zconn = C4::Context->Zconn

Returns a connection to the Zebra database for the current
context. If no connection has yet been made, this method 
creates one and connects.

C<$self> 

C<$server> one of the servers defined in the koha-conf.xml file

C<$async> whether this is a asynchronous connection

C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)


=cut
636
637sub Zconn {
638
0
0
    my $self=shift;
639
0
0
    my $server=shift;
640
0
0
    my $async=shift;
641
0
0
    my $auth=shift;
642
0
0
    my $piggyback=shift;
643
0
0
    my $syntax=shift;
644
0
0
    if ( defined($context->{"Zconn"}->{$server}) && (0 == $context->{"Zconn"}->{$server}->errcode()) ) {
645
0
0
        return $context->{"Zconn"}->{$server};
646    # No connection object or it died. Create one.
647    }else {
648        # release resources if we're closing a connection and making a new one
649        # FIXME: this needs to be smarter -- an error due to a malformed query or
650        # a missing index does not necessarily require us to close the connection
651        # and make a new one, particularly for a batch job. However, at
652        # first glance it does not look like there's a way to easily check
653        # the basic health of a ZOOM::Connection
654
0
0
        $context->{"Zconn"}->{$server}->destroy() if defined($context->{"Zconn"}->{$server});
655
656
0
0
        $context->{"Zconn"}->{$server} = &_new_Zconn($server,$async,$auth,$piggyback,$syntax);
657
0
0
        return $context->{"Zconn"}->{$server};
658    }
659}
660
661 - 673
=head2 _new_Zconn

$context->{"Zconn"} = &_new_Zconn($server,$async);

Internal function. Creates a new database connection from the data given in the current context and returns it.

C<$server> one of the servers defined in the koha-conf.xml file

C<$async> whether this is a asynchronous connection

C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)

=cut
674
675sub _new_Zconn {
676
0
0
    my ($server,$async,$auth,$piggyback,$syntax) = @_;
677
678
0
0
    my $tried=0; # first attempt
679
0
0
    my $Zconn; # connection object
680
0
0
    $server = "biblioserver" unless $server;
681
0
0
    $syntax = "usmarc" unless $syntax;
682
683
0
0
    my $host = $context->{'listen'}->{$server}->{'content'};
684
0
0
    my $servername = $context->{"config"}->{$server};
685
0
0
    my $user = $context->{"serverinfo"}->{$server}->{"user"};
686
0
0
    my $password = $context->{"serverinfo"}->{$server}->{"password"};
687
0
0
 $auth = 1 if($user && $password);
688    retry:
689
0
0
    eval {
690        # set options
691
0
0
        my $o = new ZOOM::Options();
692
0
0
        $o->option(user=>$user) if $auth;
693
0
0
        $o->option(password=>$password) if $auth;
694
0
0
        $o->option(async => 1) if $async;
695
0
0
        $o->option(count => $piggyback) if $piggyback;
696
0
0
        $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
697
0
0
        $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
698
0
0
        $o->option(preferredRecordSyntax => $syntax);
699
0
0
        $o->option(elementSetName => "F"); # F for 'full' as opposed to B for 'brief'
700
0
0
        $o->option(databaseName => ($servername?$servername:"biblios"));
701
702        # create a new connection object
703
0
0
        $Zconn= create ZOOM::Connection($o);
704
705        # forge to server
706
0
0
        $Zconn->connect($host, 0);
707
708        # check for errors and warn
709
0
0
        if ($Zconn->errcode() !=0) {
710
0
0
            warn "something wrong with the connection: ". $Zconn->errmsg();
711        }
712
713    };
714# if ($@) {
715# # Koha manages the Zebra server -- this doesn't work currently for me because of permissions issues
716# # Also, I'm skeptical about whether it's the best approach
717# warn "problem with Zebra";
718# if ( C4::Context->preference("ManageZebra") ) {
719# if ($@->code==10000 && $tried==0) { ##No connection try restarting Zebra
720# $tried=1;
721# warn "trying to restart Zebra";
722# my $res=system("zebrasrv -f $ENV{'KOHA_CONF'} >/koha/log/zebra-error.log");
723# goto "retry";
724# } else {
725# warn "Error ", $@->code(), ": ", $@->message(), "\n";
726# $Zconn="error";
727# return $Zconn;
728# }
729# }
730# }
731
0
0
    return $Zconn;
732}
733
734# _new_dbh
735# Internal helper function (not a method!). This creates a new
736# database connection from the data given in the current context, and
737# returns it.
738sub _new_dbh
739{
740
741    ## $context
742    ## correct name for db_schme
743
0
0
    my $db_driver;
744
0
0
    if ($context->config("db_scheme")){
745
0
0
        $db_driver=db_scheme2dbi($context->config("db_scheme"));
746    }else{
747
0
0
        $db_driver="mysql";
748    }
749
750
0
0
    my $db_name = $context->config("database");
751
0
0
    my $db_host = $context->config("hostname");
752
0
0
    my $db_port = $context->config("port") || '';
753
0
0
    my $db_user = $context->config("user");
754
0
0
    my $db_passwd = $context->config("pass");
755    # MJR added or die here, as we can't work without dbh
756
0
0
    my $dbh= DBI->connect("DBI:$db_driver:dbname=$db_name;host=$db_host;port=$db_port",
757    $db_user, $db_passwd, {'RaiseError' => $ENV{DEBUG}?1:0 }) or die $DBI::errstr;
758
0
0
        my $tz = $ENV{TZ};
759
0
0
    if ( $db_driver eq 'mysql' ) {
760        # Koha 3.0 is utf-8, so force utf8 communication between mySQL and koha, whatever the mysql default config.
761        # this is better than modifying my.cnf (and forcing all communications to be in utf8)
762
0
0
        $dbh->{'mysql_enable_utf8'}=1; #enable
763
0
0
        $dbh->do("set NAMES 'utf8'");
764
0
0
        ($tz) and $dbh->do(qq(SET time_zone = "$tz"));
765    }
766    elsif ( $db_driver eq 'Pg' ) {
767
0
0
            $dbh->do( "set client_encoding = 'UTF8';" );
768
0
0
        ($tz) and $dbh->do(qq(SET TIME ZONE = "$tz"));
769    }
770
0
0
    return $dbh;
771}
772
773 - 786
=head2 dbh

  $dbh = C4::Context->dbh;

Returns a database handle connected to the Koha database for the
current context. If no connection has yet been made, this method
creates one, and connects to the database.

This database handle is cached for future use: if you call
C<C4::Context-E<gt>dbh> twice, you will get the same handle both
times. If you need a second database handle, use C<&new_dbh> and
possibly C<&set_dbh>.

=cut
787
788#'
789sub dbh
790{
791
0
0
    my $self = shift;
792
0
0
    my $sth;
793
794
0
0
    if (defined($context->{"dbh"}) && $context->{"dbh"}->ping()) {
795
0
0
        return $context->{"dbh"};
796    }
797
798    # No database handle or it died . Create one.
799
0
0
    $context->{"dbh"} = &_new_dbh();
800
801
0
0
    return $context->{"dbh"};
802}
803
804 - 815
=head2 new_dbh

  $dbh = C4::Context->new_dbh;

Creates a new connection to the Koha database for the current context,
and returns the database handle (a C<DBI::db> object).

The handle is not saved anywhere: this method is strictly a
convenience function; the point is that it knows which database to
connect to so that the caller doesn't have to know.

=cut
816
817#'
818sub new_dbh
819{
820
0
0
    my $self = shift;
821
822
0
0
    return &_new_dbh();
823}
824
825 - 840
=head2 set_dbh

  $my_dbh = C4::Connect->new_dbh;
  C4::Connect->set_dbh($my_dbh);
  ...
  C4::Connect->restore_dbh;

C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
C<&set_context> and C<&restore_context>.

C<&set_dbh> saves the current database handle on a stack, then sets
the current database handle to C<$my_dbh>.

C<$my_dbh> is assumed to be a good database handle.

=cut
841
842#'
843sub set_dbh
844{
845
0
0
    my $self = shift;
846
0
0
    my $new_dbh = shift;
847
848    # Save the current database handle on the handle stack.
849    # We assume that $new_dbh is all good: if the caller wants to
850    # screw himself by passing an invalid handle, that's fine by
851    # us.
852
0
0
0
0
    push @{$context->{"dbh_stack"}}, $context->{"dbh"};
853
0
0
    $context->{"dbh"} = $new_dbh;
854}
855
856 - 863
=head2 restore_dbh

  C4::Context->restore_dbh;

Restores the database handle saved by an earlier call to
C<C4::Context-E<gt>set_dbh>.

=cut
864
865#'
866sub restore_dbh
867{
868
0
0
    my $self = shift;
869
870
0
0
0
0
    if ($#{$context->{"dbh_stack"}} < 0)
871    {
872        # Stack underflow
873
0
0
        die "DBH stack underflow";
874    }
875
876    # Pop the old database handle and set it.
877
0
0
0
0
    $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
878
879    # FIXME - If it is determined that restore_context should
880    # return something, then this function should, too.
881}
882
883 - 892
=head2 marcfromkohafield

  $dbh = C4::Context->marcfromkohafield;

Returns a hash with marcfromkohafield.

This hash is cached for future use: if you call
C<C4::Context-E<gt>marcfromkohafield> twice, you will get the same hash without real DB access

=cut
893
894#'
895sub marcfromkohafield
896{
897
0
0
    my $retval = {};
898
899    # If the hash already exists, return it.
900
0
0
    return $context->{"marcfromkohafield"} if defined($context->{"marcfromkohafield"});
901
902    # No hash. Create one.
903
0
0
    $context->{"marcfromkohafield"} = &_new_marcfromkohafield();
904
905
0
0
    return $context->{"marcfromkohafield"};
906}
907
908# _new_marcfromkohafield
909# Internal helper function (not a method!). This creates a new
910# hash with stopwords
911sub _new_marcfromkohafield
912{
913
0
0
    my $dbh = C4::Context->dbh;
914
0
0
    my $marcfromkohafield;
915
0
0
    my $sth = $dbh->prepare("select frameworkcode,kohafield,tagfield,tagsubfield from marc_subfield_structure where kohafield > ''");
916
0
0
    $sth->execute;
917
0
0
    while (my ($frameworkcode,$kohafield,$tagfield,$tagsubfield) = $sth->fetchrow) {
918
0
0
        my $retval = {};
919
0
0
        $marcfromkohafield->{$frameworkcode}->{$kohafield} = [$tagfield,$tagsubfield];
920    }
921
0
0
    return $marcfromkohafield;
922}
923
924 - 933
=head2 stopwords

  $dbh = C4::Context->stopwords;

Returns a hash with stopwords.

This hash is cached for future use: if you call
C<C4::Context-E<gt>stopwords> twice, you will get the same hash without real DB access

=cut
934
935#'
936sub stopwords
937{
938
0
0
    my $retval = {};
939
940    # If the hash already exists, return it.
941
0
0
    return $context->{"stopwords"} if defined($context->{"stopwords"});
942
943    # No hash. Create one.
944
0
0
    $context->{"stopwords"} = &_new_stopwords();
945
946
0
0
    return $context->{"stopwords"};
947}
948
949# _new_stopwords
950# Internal helper function (not a method!). This creates a new
951# hash with stopwords
952sub _new_stopwords
953{
954
0
0
    my $dbh = C4::Context->dbh;
955
0
0
    my $stopwordlist;
956
0
0
    my $sth = $dbh->prepare("select word from stopwords");
957
0
0
    $sth->execute;
958
0
0
    while (my $stopword = $sth->fetchrow_array) {
959
0
0
        $stopwordlist->{$stopword} = uc($stopword);
960    }
961
0
0
    $stopwordlist->{A} = "A" unless $stopwordlist;
962
0
0
    return $stopwordlist;
963}
964
965 - 974
=head2 userenv

  C4::Context->userenv;

Retrieves a hash for user environment variables.

This hash shall be cached for future use: if you call
C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access

=cut
975
976#'
977sub userenv {
978
46
80
    my $var = $context->{"activeuser"};
979
46
676
    return $context->{"userenv"}->{$var} if (defined $var and defined $context->{"userenv"}->{$var});
980    # insecure=1 management
981
0
0
    if ($context->{"dbh"} && $context->preference('insecure') eq 'yes') {
982
0
0
        my %insecure;
983
0
0
        $insecure{flags} = '16382';
984
0
0
        $insecure{branchname} ='Insecure';
985
0
0
        $insecure{number} ='0';
986
0
0
        $insecure{cardnumber} ='0';
987
0
0
        $insecure{id} = 'insecure';
988
0
0
        $insecure{branch} = 'INS';
989
0
0
        $insecure{emailaddress} = 'test@mode.insecure.com';
990
0
0
        return \%insecure;
991    } else {
992
0
0
        return;
993    }
994}
995
996 - 1005
=head2 set_userenv

  C4::Context->set_userenv($usernum, $userid, $usercnum, $userfirstname, 
                  $usersurname, $userbranch, $userflags, $emailaddress);

Establish a hash of user environment variables.

set_userenv is called in Auth.pm

=cut
1006
1007#'
1008sub set_userenv {
1009
1
11
    my ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $branchprinter)= @_;
1010
1
2
    my $var=$context->{"activeuser"};
1011
1
24
    my $cell = {
1012        "number" => $usernum,
1013        "id" => $userid,
1014        "cardnumber" => $usercnum,
1015        "firstname" => $userfirstname,
1016        "surname" => $usersurname,
1017        #possibly a law problem
1018        "branch" => $userbranch,
1019        "branchname" => $branchname,
1020        "flags" => $userflags,
1021        "emailaddress" => $emailaddress,
1022        "branchprinter" => $branchprinter
1023    };
1024
1
4
    $context->{userenv}->{$var} = $cell;
1025
1
7
    return $cell;
1026}
1027
1028sub set_shelves_userenv ($$) {
1029
0
0
        my ($type, $shelves) = @_ or return undef;
1030
0
0
        my $activeuser = $context->{activeuser} or return undef;
1031
0
0
        $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
1032
0
0
        $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
1033
0
0
        $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
1034}
1035
1036sub get_shelves_userenv () {
1037
0
0
        my $active;
1038
0
0
        unless ($active = $context->{userenv}->{$context->{activeuser}}) {
1039
0
0
                $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
1040
0
0
                return undef;
1041        }
1042
0
0
        my $totshelves = $active->{totshelves} or undef;
1043
0
0
        my $pubshelves = $active->{pubshelves} or undef;
1044
0
0
        my $barshelves = $active->{barshelves} or undef;
1045
0
0
        return ($totshelves, $pubshelves, $barshelves);
1046}
1047
1048 - 1059
=head2 _new_userenv

  C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function

Builds a hash for user environment variables.

This hash shall be cached for future use: if you call
C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access

_new_userenv is called in Auth.pm

=cut
1060
1061#'
1062sub _new_userenv
1063{
1064
1
898459
    shift; # Useless except it compensates for bad calling style
1065
1
1
    my ($sessionID)= @_;
1066
1
7
     $context->{"activeuser"}=$sessionID;
1067}
1068
1069 - 1075
=head2 _unset_userenv

  C4::Context->_unset_userenv;

Destroys the hash for activeuser user environment variables.

=cut
1076
1077#'
1078
1079sub _unset_userenv
1080{
1081
0
    my ($sessionID)= @_;
1082
0
    undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
1083}
1084
1085
1086 - 1092
=head2 get_versions

  C4::Context->get_versions

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'.

=cut
1093
1094#'
1095
1096# A little example sub to show more debugging info for CGI::Carp
1097sub get_versions {
1098
0
    my %versions;
1099
0
    $versions{kohaVersion} = KOHAVERSION();
1100
0
    $versions{kohaDbVersion} = C4::Context->preference('version');
1101
0
    $versions{osVersion} = join(" ", POSIX::uname());
1102
0
    $versions{perlVersion} = $];
1103    {
1104
58
58
58
0
242831
1515
9863
        no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
1105
0
        $versions{mysqlVersion} = `mysql -V`;
1106
0
        $versions{apacheVersion} = `httpd -v`;
1107
0
        $versions{apacheVersion} = `httpd2 -v` unless $versions{apacheVersion} ;
1108
0
        $versions{apacheVersion} = `apache2 -v` unless $versions{apacheVersion} ;
1109
0
        $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless $versions{apacheVersion} ;
1110    }
1111
0
    return %versions;
1112}
1113
1114
11151;