C4/Context.pm

   1 package C4::Context;
   2
   3 # Copyright 2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 use vars qw($AUTOLOAD $context @context_stack);
  23 BEGIN {
  24     if ( $ENV{'HTTP_USER_AGENT'} ) { # Only hit when plack is not enabled
  25
  26         # Redefine multi_param if cgi version is < 4.08
  27         # Remove the "CGI::param called in list context" warning in this case
  28         require CGI;    # Can't check version without the require.
  29         if ( !defined($CGI::VERSION) || $CGI::VERSION < 4.08 ) {
  30             no warnings 'redefine';
  31             *CGI::multi_param = \&CGI::param;
  32             use warnings 'redefine';
  33             $CGI::LIST_CONTEXT_WARN = 0;
  34         }
  35     }
  36 };
  37
  38 use Carp;
  39 use DateTime::TimeZone;
  40 use Encode;
  41 use File::Spec;
  42 use Module::Load::Conditional qw(can_load);
  43 use POSIX ();
  44 use YAML::XS;
  45 use ZOOM;
  46
  47 use C4::Debug;
  48 use Koha::Caches;
  49 use Koha::Config::SysPref;
  50 use Koha::Config::SysPrefs;
  51 use Koha::Config;
  52 use Koha;
  53
  54 =head1 NAME
  55
  56 C4::Context - Maintain and manipulate the context of a Koha script
  57
  58 =head1 SYNOPSIS
  59
  60   use C4::Context;
  61
  62   use C4::Context("/path/to/koha-conf.xml");
  63
  64   $config_value = C4::Context->config("config_variable");
  65
  66   $koha_preference = C4::Context->preference("preference");
  67
  68   $db_handle = C4::Context->dbh;
  69
  70   $Zconn = C4::Context->Zconn;
  71
  72 =head1 DESCRIPTION
  73
  74 When a Koha script runs, it makes use of a certain number of things:
  75 configuration settings in F</etc/koha/koha-conf.xml>, a connection to the Koha
  76 databases, and so forth. These things make up the I<context> in which
  77 the script runs.
  78
  79 This module takes care of setting up the context for a script:
  80 figuring out which configuration file to load, and loading it, opening
  81 a connection to the right database, and so forth.
  82
  83 Most scripts will only use one context. They can simply have
  84
  85   use C4::Context;
  86
  87 at the top.
  88
  89 Other scripts may need to use several contexts. For instance, if a
  90 library has two databases, one for a certain collection, and the other
  91 for everything else, it might be necessary for a script to use two
  92 different contexts to search both databases. Such scripts should use
  93 the C<&set_context> and C<&restore_context> functions, below.
  94
  95 By default, C4::Context reads the configuration from
  96 F</etc/koha/koha-conf.xml>. This may be overridden by setting the C<$KOHA_CONF>
  97 environment variable to the pathname of a configuration file to use.
  98
  99 =head1 METHODS
 100
 101 =cut
 102
 103 #'
 104 # In addition to what is said in the POD above, a Context object is a
 105 # reference-to-hash with the following fields:
 106 #
 107 # config
 108 #    A reference-to-hash whose keys and values are the
 109 #    configuration variables and values specified in the config
 110 #    file (/etc/koha/koha-conf.xml).
 111 # dbh
 112 #    A handle to the appropriate database for this context.
 113 # dbh_stack
 114 #    Used by &set_dbh and &restore_dbh to hold other database
 115 #    handles for this context.
 116 # Zconn
 117 #     A connection object for the Zebra server
 118
 119 $context = undef;        # Initially, no context is set
 120 @context_stack = ();        # Initially, no saved contexts
 121
 122 =head2 db_scheme2dbi
 123
 124     my $dbd_driver_name = C4::Context::db_schema2dbi($scheme);
 125
 126 This routines translates a database type to part of the name
 127 of the appropriate DBD driver to use when establishing a new
 128 database connection.  It recognizes 'mysql' and 'Pg'; if any
 129 other scheme is supplied it defaults to 'mysql'.
 130
 131 =cut
 132
 133 sub db_scheme2dbi {
 134     my $scheme = shift // '';
 135     return $scheme eq 'Pg' ? $scheme : 'mysql';
 136 }
 137
 138 sub import {
 139     # Create the default context ($C4::Context::Context)
 140     # the first time the module is called
 141     # (a config file can be optionaly passed)
 142
 143     # default context already exists?
 144     return if $context;
 145
 146     # no ? so load it!
 147     my ($pkg,$config_file) = @_ ;
 148     my $new_ctx = __PACKAGE__->new($config_file);
 149     return unless $new_ctx;
 150
 151     # if successfully loaded, use it by default
 152     $new_ctx->set_context;
 153     1;
 154 }
 155
 156 =head2 new
 157
 158   $context = C4::Context->new;
 159   $context = C4::Context->new("/path/to/koha-conf.xml");
 160
 161 Allocates a new context. Initializes the context from the specified
 162 file, which defaults to either the file given by the C<$KOHA_CONF>
 163 environment variable, or F</etc/koha/koha-conf.xml>.
 164
 165 It saves the koha-conf.xml values in the declared memcached server(s)
 166 if currently available and uses those values until them expire and
 167 re-reads them.
 168
 169 C<&new> does not set this context as the new default context; for
 170 that, use C<&set_context>.
 171
 172 =cut
 173
 174 #'
 175 # Revision History:
 176 # 2004-08-10 A. Tarallo: Added check if the conf file is not empty
 177 sub new {
 178     my $class = shift;
 179     my $conf_fname = shift;        # Config file to load
 180
 181     # check that the specified config file exists and is not empty
 182     undef $conf_fname unless
 183         (defined $conf_fname && -s $conf_fname);
 184     # Figure out a good config file to load if none was specified.
 185     unless ( defined $conf_fname ) {
 186         $conf_fname = Koha::Config->guess_koha_conf;
 187         unless ( $conf_fname ) {
 188             warn "unable to locate Koha configuration file koha-conf.xml";
 189             return;
 190         }
 191     }
 192
 193     my $self = Koha::Config->read_from_file($conf_fname);
 194     unless ( exists $self->{config} or defined $self->{config} ) {
 195         warn "The config file ($conf_fname) has not been parsed correctly";
 196         return;
 197     }
 198
 199     $self->{"Zconn"} = undef;    # Zebra Connections
 200     $self->{"userenv"} = undef;        # User env
 201     $self->{"activeuser"} = undef;        # current active user
 202     $self->{"shelves"} = undef;
 203     $self->{tz} = undef; # local timezone object
 204
 205     bless $self, $class;
 206     $self->{db_driver} = db_scheme2dbi($self->config('db_scheme'));  # cache database driver
 207     return $self;
 208 }
 209
 210 =head2 set_context
 211
 212   $context = new C4::Context;
 213   $context->set_context();
 214 or
 215   set_context C4::Context $context;
 216
 217   ...
 218   restore_context C4::Context;
 219
 220 In some cases, it might be necessary for a script to use multiple
 221 contexts. C<&set_context> saves the current context on a stack, then
 222 sets the context to C<$context>, which will be used in future
 223 operations. To restore the previous context, use C<&restore_context>.
 224
 225 =cut
 226
 227 #'
 228 sub set_context
 229 {
 230     my $self = shift;
 231     my $new_context;    # The context to set
 232
 233     # Figure out whether this is a class or instance method call.
 234     #
 235     # We're going to make the assumption that control got here
 236     # through valid means, i.e., that the caller used an instance
 237     # or class method call, and that control got here through the
 238     # usual inheritance mechanisms. The caller can, of course,
 239     # break this assumption by playing silly buggers, but that's
 240     # harder to do than doing it properly, and harder to check
 241     # for.
 242     if (ref($self) eq "")
 243     {
 244         # Class method. The new context is the next argument.
 245         $new_context = shift;
 246     } else {
 247         # Instance method. The new context is $self.
 248         $new_context = $self;
 249     }
 250
 251     # Save the old context, if any, on the stack
 252     push @context_stack, $context if defined($context);
 253
 254     # Set the new context
 255     $context = $new_context;
 256 }
 257
 258 =head2 restore_context
 259
 260   &restore_context;
 261
 262 Restores the context set by C<&set_context>.
 263
 264 =cut
 265
 266 #'
 267 sub restore_context
 268 {
 269     my $self = shift;
 270
 271     if ($#context_stack < 0)
 272     {
 273         # Stack underflow.
 274         die "Context stack underflow";
 275     }
 276
 277     # Pop the old context and set it.
 278     $context = pop @context_stack;
 279
 280     # FIXME - Should this return something, like maybe the context
 281     # that was current when this was called?
 282 }
 283
 284 =head2 config
 285
 286   $value = C4::Context->config("config_variable");
 287
 288   $value = C4::Context->config_variable;
 289
 290 Returns the value of a variable specified in the configuration file
 291 from which the current context was created.
 292
 293 The second form is more compact, but of course may conflict with
 294 method names. If there is a configuration variable called "new", then
 295 C<C4::Config-E<gt>new> will not return it.
 296
 297 =cut
 298
 299 sub _common_config {
 300         my $var = shift;
 301         my $term = shift;
 302     return unless defined $context and defined $context->{$term};
 303        # Presumably $self->{$term} might be
 304        # undefined if the config file given to &new
 305        # didn't exist, and the caller didn't bother
 306        # to check the return value.
 307
 308     # Return the value of the requested config variable
 309     return $context->{$term}->{$var};
 310 }
 311
 312 sub config {
 313         return _common_config($_[1],'config');
 314 }
 315 sub zebraconfig {
 316         return _common_config($_[1],'server');
 317 }
 318
 319 =head2 preference
 320
 321   $sys_preference = C4::Context->preference('some_variable');
 322
 323 Looks up the value of the given system preference in the
 324 systempreferences table of the Koha database, and returns it. If the
 325 variable is not set or does not exist, undef is returned.
 326
 327 In case of an error, this may return 0.
 328
 329 Note: It is impossible to tell the difference between system
 330 preferences which do not exist, and those whose values are set to NULL
 331 with this method.
 332
 333 =cut
 334
 335 my $use_syspref_cache = 1;
 336 sub preference {
 337     my $self = shift;
 338     my $var  = shift;    # The system preference to return
 339
 340     return Encode::decode_utf8($ENV{"OVERRIDE_SYSPREF_$var"})
 341         if defined $ENV{"OVERRIDE_SYSPREF_$var"};
 342
 343     $var = lc $var;
 344
 345     if ($use_syspref_cache) {
 346         my $syspref_cache = Koha::Caches->get_instance('syspref');
 347         my $cached_var = $syspref_cache->get_from_cache("syspref_$var");
 348         return $cached_var if defined $cached_var;
 349     }
 350
 351     my $syspref;
 352     eval { $syspref = Koha::Config::SysPrefs->find( lc $var ) };
 353     my $value = $syspref ? $syspref->value() : undef;
 354
 355     if ( $use_syspref_cache ) {
 356         my $syspref_cache = Koha::Caches->get_instance('syspref');
 357         $syspref_cache->set_in_cache("syspref_$var", $value);
 358     }
 359     return $value;
 360 }
 361
 362 =head2 yaml_preference
 363
 364 Retrieves the required system preference value, and converts it
 365 from YAML into a Perl data structure. It throws an exception if
 366 the value cannot be properly decoded as YAML.
 367
 368 =cut
 369
 370 sub yaml_preference {
 371     my ( $self, $preference ) = @_;
 372
 373     my $yaml = eval { YAML::XS::Load( Encode::encode_utf8( $self->preference( $preference ) ) ); };
 374     if ($@) {
 375         warn "Unable to parse $preference syspref : $@";
 376         return;
 377     }
 378
 379     return $yaml;
 380 }
 381
 382 =head2 enable_syspref_cache
 383
 384   C4::Context->enable_syspref_cache();
 385
 386 Enable the in-memory syspref cache used by C4::Context. This is the
 387 default behavior.
 388
 389 =cut
 390
 391 sub enable_syspref_cache {
 392     my ($self) = @_;
 393     $use_syspref_cache = 1;
 394     # We need to clear the cache to have it up-to-date
 395     $self->clear_syspref_cache();
 396 }
 397
 398 =head2 disable_syspref_cache
 399
 400   C4::Context->disable_syspref_cache();
 401
 402 Disable the in-memory syspref cache used by C4::Context. This should be
 403 used with Plack and other persistent environments.
 404
 405 =cut
 406
 407 sub disable_syspref_cache {
 408     my ($self) = @_;
 409     $use_syspref_cache = 0;
 410     $self->clear_syspref_cache();
 411 }
 412
 413 =head2 clear_syspref_cache
 414
 415   C4::Context->clear_syspref_cache();
 416
 417 cleans the internal cache of sysprefs. Please call this method if
 418 you update the systempreferences table. Otherwise, your new changes
 419 will not be seen by this process.
 420
 421 =cut
 422
 423 sub clear_syspref_cache {
 424     return unless $use_syspref_cache;
 425     my $syspref_cache = Koha::Caches->get_instance('syspref');
 426     $syspref_cache->flush_all;
 427 }
 428
 429 =head2 set_preference
 430
 431   C4::Context->set_preference( $variable, $value, [ $explanation, $type, $options ] );
 432
 433 This updates a preference's value both in the systempreferences table and in
 434 the sysprefs cache. If the optional parameters are provided, then the query
 435 becomes a create. It won't update the parameters (except value) for an existing
 436 preference.
 437
 438 =cut
 439
 440 sub set_preference {
 441     my ( $self, $variable, $value, $explanation, $type, $options ) = @_;
 442
 443     my $variable_case = $variable;
 444     $variable = lc $variable;
 445
 446     my $syspref = Koha::Config::SysPrefs->find($variable);
 447     $type =
 448         $type    ? $type
 449       : $syspref ? $syspref->type
 450       :            undef;
 451
 452     $value = 0 if ( $type && $type eq 'YesNo' && $value eq '' );
 453
 454     # force explicit protocol on OPACBaseURL
 455     if ( $variable eq 'opacbaseurl' && $value && substr( $value, 0, 4 ) !~ /http/ ) {
 456         $value = 'http://' . $value;
 457     }
 458
 459     if ($syspref) {
 460         $syspref->set(
 461             {   ( defined $value ? ( value       => $value )       : () ),
 462                 ( $explanation   ? ( explanation => $explanation ) : () ),
 463                 ( $type          ? ( type        => $type )        : () ),
 464                 ( $options       ? ( options     => $options )     : () ),
 465             }
 466         )->store;
 467     } else {
 468         $syspref = Koha::Config::SysPref->new(
 469             {   variable    => $variable_case,
 470                 value       => $value,
 471                 explanation => $explanation || undef,
 472                 type        => $type,
 473                 options     => $options || undef,
 474             }
 475         )->store();
 476     }
 477
 478     if ( $use_syspref_cache ) {
 479         my $syspref_cache = Koha::Caches->get_instance('syspref');
 480         $syspref_cache->set_in_cache( "syspref_$variable", $value );
 481     }
 482
 483     return $syspref;
 484 }
 485
 486 =head2 delete_preference
 487
 488     C4::Context->delete_preference( $variable );
 489
 490 This deletes a system preference from the database. Returns a true value on
 491 success. Failure means there was an issue with the database, not that there
 492 was no syspref of the name.
 493
 494 =cut
 495
 496 sub delete_preference {
 497     my ( $self, $var ) = @_;
 498
 499     if ( Koha::Config::SysPrefs->find( $var )->delete ) {
 500         if ( $use_syspref_cache ) {
 501             my $syspref_cache = Koha::Caches->get_instance('syspref');
 502             $syspref_cache->clear_from_cache("syspref_$var");
 503         }
 504
 505         return 1;
 506     }
 507     return 0;
 508 }
 509
 510 =head2 Zconn
 511
 512   $Zconn = C4::Context->Zconn
 513
 514 Returns a connection to the Zebra database
 515
 516 C<$self>
 517
 518 C<$server> one of the servers defined in the koha-conf.xml file
 519
 520 C<$async> whether this is a asynchronous connection
 521
 522 =cut
 523
 524 sub Zconn {
 525     my ($self, $server, $async ) = @_;
 526     my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
 527     if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
 528         # if we are running the script from the commandline, lets try to use the caching
 529         return $context->{"Zconn"}->{$cache_key};
 530     }
 531     $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
 532     $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
 533     return $context->{"Zconn"}->{$cache_key};
 534 }
 535
 536 =head2 _new_Zconn
 537
 538 $context->{"Zconn"} = &_new_Zconn($server,$async);
 539
 540 Internal function. Creates a new database connection from the data given in the current context and returns it.
 541
 542 C<$server> one of the servers defined in the koha-conf.xml file
 543
 544 C<$async> whether this is a asynchronous connection
 545
 546 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 547
 548 =cut
 549
 550 sub _new_Zconn {
 551     my ( $server, $async ) = @_;
 552
 553     my $tried=0; # first attempt
 554     my $Zconn; # connection object
 555     my $elementSetName;
 556     my $syntax;
 557
 558     $server //= "biblioserver";
 559
 560     $syntax = 'xml';
 561     $elementSetName = 'marcxml';
 562
 563     my $host = $context->{'listen'}->{$server}->{'content'};
 564     my $user = $context->{"serverinfo"}->{$server}->{"user"};
 565     my $password = $context->{"serverinfo"}->{$server}->{"password"};
 566     eval {
 567         # set options
 568         my $o = ZOOM::Options->new();
 569         $o->option(user => $user) if $user && $password;
 570         $o->option(password => $password) if $user && $password;
 571         $o->option(async => 1) if $async;
 572         $o->option(cqlfile=> $context->{"server"}->{$server}->{"cql2rpn"});
 573         $o->option(cclfile=> $context->{"serverinfo"}->{$server}->{"ccl2rpn"});
 574         $o->option(preferredRecordSyntax => $syntax);
 575         $o->option(elementSetName => $elementSetName) if $elementSetName;
 576         $o->option(databaseName => $context->{"config"}->{$server}||"biblios");
 577
 578         # create a new connection object
 579         $Zconn= create ZOOM::Connection($o);
 580
 581         # forge to server
 582         $Zconn->connect($host, 0);
 583
 584         # check for errors and warn
 585         if ($Zconn->errcode() !=0) {
 586             warn "something wrong with the connection: ". $Zconn->errmsg();
 587         }
 588     };
 589     return $Zconn;
 590 }
 591
 592 # _new_dbh
 593 # Internal helper function (not a method!). This creates a new
 594 # database connection from the data given in the current context, and
 595 # returns it.
 596 sub _new_dbh
 597 {
 598
 599     Koha::Database->schema({ new => 1 })->storage->dbh;
 600 }
 601
 602 =head2 dbh
 603
 604   $dbh = C4::Context->dbh;
 605
 606 Returns a database handle connected to the Koha database for the
 607 current context. If no connection has yet been made, this method
 608 creates one, and connects to the database.
 609
 610 This database handle is cached for future use: if you call
 611 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
 612 times. If you need a second database handle, use C<&new_dbh> and
 613 possibly C<&set_dbh>.
 614
 615 =cut
 616
 617 #'
 618 sub dbh
 619 {
 620     my $self = shift;
 621     my $params = shift;
 622
 623     unless ( $params->{new} ) {
 624         return Koha::Database->schema->storage->dbh;
 625     }
 626
 627     return Koha::Database->schema({ new => 1 })->storage->dbh;
 628 }
 629
 630 =head2 new_dbh
 631
 632   $dbh = C4::Context->new_dbh;
 633
 634 Creates a new connection to the Koha database for the current context,
 635 and returns the database handle (a C<DBI::db> object).
 636
 637 The handle is not saved anywhere: this method is strictly a
 638 convenience function; the point is that it knows which database to
 639 connect to so that the caller doesn't have to know.
 640
 641 =cut
 642
 643 #'
 644 sub new_dbh
 645 {
 646     my $self = shift;
 647
 648     return &dbh({ new => 1 });
 649 }
 650
 651 =head2 set_dbh
 652
 653   $my_dbh = C4::Connect->new_dbh;
 654   C4::Connect->set_dbh($my_dbh);
 655   ...
 656   C4::Connect->restore_dbh;
 657
 658 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
 659 C<&set_context> and C<&restore_context>.
 660
 661 C<&set_dbh> saves the current database handle on a stack, then sets
 662 the current database handle to C<$my_dbh>.
 663
 664 C<$my_dbh> is assumed to be a good database handle.
 665
 666 =cut
 667
 668 #'
 669 sub set_dbh
 670 {
 671     my $self = shift;
 672     my $new_dbh = shift;
 673
 674     # Save the current database handle on the handle stack.
 675     # We assume that $new_dbh is all good: if the caller wants to
 676     # screw himself by passing an invalid handle, that's fine by
 677     # us.
 678     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
 679     $context->{"dbh"} = $new_dbh;
 680 }
 681
 682 =head2 restore_dbh
 683
 684   C4::Context->restore_dbh;
 685
 686 Restores the database handle saved by an earlier call to
 687 C<C4::Context-E<gt>set_dbh>.
 688
 689 =cut
 690
 691 #'
 692 sub restore_dbh
 693 {
 694     my $self = shift;
 695
 696     if ($#{$context->{"dbh_stack"}} < 0)
 697     {
 698         # Stack underflow
 699         die "DBH stack underflow";
 700     }
 701
 702     # Pop the old database handle and set it.
 703     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
 704
 705     # FIXME - If it is determined that restore_context should
 706     # return something, then this function should, too.
 707 }
 708
 709 =head2 userenv
 710
 711   C4::Context->userenv;
 712
 713 Retrieves a hash for user environment variables.
 714
 715 This hash shall be cached for future use: if you call
 716 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 717
 718 =cut
 719
 720 #'
 721 sub userenv {
 722     my $var = $context->{"activeuser"};
 723     if (defined $var and defined $context->{"userenv"}->{$var}) {
 724         return $context->{"userenv"}->{$var};
 725     } else {
 726         return;
 727     }
 728 }
 729
 730 =head2 set_userenv
 731
 732   C4::Context->set_userenv($usernum, $userid, $usercnum,
 733                            $userfirstname, $usersurname,
 734                            $userbranch, $branchname, $userflags,
 735                            $emailaddress, $shibboleth
 736                            $desk_id, $desk_name,
 737                            $register_id, $register_name);
 738
 739 Establish a hash of user environment variables.
 740
 741 set_userenv is called in Auth.pm
 742
 743 =cut
 744
 745 #'
 746 sub set_userenv {
 747     shift @_;
 748     my (
 749         $usernum,      $userid,     $usercnum,   $userfirstname,
 750         $usersurname,  $userbranch, $branchname, $userflags,
 751         $emailaddress, $shibboleth, $desk_id,    $desk_name,
 752         $register_id,  $register_name
 753     ) = @_;
 754
 755     my $var=$context->{"activeuser"} || '';
 756     my $cell = {
 757         "number"     => $usernum,
 758         "id"         => $userid,
 759         "cardnumber" => $usercnum,
 760         "firstname"  => $userfirstname,
 761         "surname"    => $usersurname,
 762
 763         #possibly a law problem
 764         "branch"        => $userbranch,
 765         "branchname"    => $branchname,
 766         "flags"         => $userflags,
 767         "emailaddress"  => $emailaddress,
 768         "shibboleth"    => $shibboleth,
 769         "desk_id"       => $desk_id,
 770         "desk_name"     => $desk_name,
 771         "register_id"   => $register_id,
 772         "register_name" => $register_name
 773     };
 774     $context->{userenv}->{$var} = $cell;
 775     return $cell;
 776 }
 777
 778 sub set_shelves_userenv {
 779         my ($type, $shelves) = @_ or return;
 780         my $activeuser = $context->{activeuser} or return;
 781         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
 782         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
 783         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
 784 }
 785
 786 sub get_shelves_userenv {
 787         my $active;
 788         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
 789                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
 790                 return;
 791         }
 792         my $totshelves = $active->{totshelves} or undef;
 793         my $pubshelves = $active->{pubshelves} or undef;
 794         my $barshelves = $active->{barshelves} or undef;
 795         return ($totshelves, $pubshelves, $barshelves);
 796 }
 797
 798 =head2 _new_userenv
 799
 800   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 801
 802 Builds a hash for user environment variables.
 803
 804 This hash shall be cached for future use: if you call
 805 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 806
 807 _new_userenv is called in Auth.pm
 808
 809 =cut
 810
 811 #'
 812 sub _new_userenv
 813 {
 814     shift;  # Useless except it compensates for bad calling style
 815     my ($sessionID)= @_;
 816      $context->{"activeuser"}=$sessionID;
 817 }
 818
 819 =head2 _unset_userenv
 820
 821   C4::Context->_unset_userenv;
 822
 823 Destroys the hash for activeuser user environment variables.
 824
 825 =cut
 826
 827 #'
 828
 829 sub _unset_userenv
 830 {
 831     my ($sessionID)= @_;
 832     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
 833 }
 834
 835
 836 =head2 get_versions
 837
 838   C4::Context->get_versions
 839
 840 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'.
 841
 842 =cut
 843
 844 #'
 845
 846 # A little example sub to show more debugging info for CGI::Carp
 847 sub get_versions {
 848     my %versions;
 849     $versions{kohaVersion}  = Koha::version();
 850     $versions{kohaDbVersion} = C4::Context->preference('version');
 851     $versions{osVersion} = join(" ", POSIX::uname());
 852     $versions{perlVersion} = $];
 853     {
 854         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
 855         $versions{mysqlVersion}  = `mysql -V`;
 856         $versions{apacheVersion} = (`apache2ctl -v`)[0];
 857         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
 858         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
 859         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
 860         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
 861     }
 862     return %versions;
 863 }
 864
 865 =head2 timezone
 866
 867   my $C4::Context->timzone
 868
 869   Returns a timezone code for the instance of Koha
 870
 871 =cut
 872
 873 sub timezone {
 874     my $self = shift;
 875
 876     my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local';
 877     if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) {
 878         warn "Invalid timezone in koha-conf.xml ($timezone)";
 879         $timezone = 'local';
 880     }
 881
 882     return $timezone;
 883 }
 884
 885 =head2 tz
 886
 887   C4::Context->tz
 888
 889   Returns a DateTime::TimeZone object for the system timezone
 890
 891 =cut
 892
 893 sub tz {
 894     my $self = shift;
 895     if (!defined $context->{tz}) {
 896         my $timezone = $self->timezone;
 897         $context->{tz} = DateTime::TimeZone->new(name => $timezone);
 898     }
 899     return $context->{tz};
 900 }
 901
 902
 903 =head2 IsSuperLibrarian
 904
 905     C4::Context->IsSuperLibrarian();
 906
 907 =cut
 908
 909 sub IsSuperLibrarian {
 910     my $userenv = C4::Context->userenv;
 911
 912     unless ( $userenv and exists $userenv->{flags} ) {
 913         # If we reach this without a user environment,
 914         # assume that we're running from a command-line script,
 915         # and act as a superlibrarian.
 916         carp("C4::Context->userenv not defined!");
 917         return 1;
 918     }
 919
 920     return ($userenv->{flags}//0) % 2;
 921 }
 922
 923 =head2 interface
 924
 925 Sets the current interface for later retrieval in any Perl module
 926
 927     C4::Context->interface('opac');
 928     C4::Context->interface('intranet');
 929     my $interface = C4::Context->interface;
 930
 931 =cut
 932
 933 sub interface {
 934     my ($class, $interface) = @_;
 935
 936     if (defined $interface) {
 937         $interface = lc $interface;
 938         if (   $interface eq 'api'
 939             || $interface eq 'opac'
 940             || $interface eq 'intranet'
 941             || $interface eq 'sip'
 942             || $interface eq 'cron'
 943             || $interface eq 'commandline' )
 944         {
 945             $context->{interface} = $interface;
 946         } else {
 947             warn "invalid interface : '$interface'";
 948         }
 949     }
 950
 951     return $context->{interface} // 'opac';
 952 }
 953
 954 # always returns a string for OK comparison via "eq" or "ne"
 955 sub mybranch {
 956     C4::Context->userenv           or return '';
 957     return C4::Context->userenv->{branch} || '';
 958 }
 959
 960 =head2 only_my_library
 961
 962     my $test = C4::Context->only_my_library;
 963
 964     Returns true if you enabled IndependentBranches and the current user
 965     does not have superlibrarian permissions.
 966
 967 =cut
 968
 969 sub only_my_library {
 970     return
 971          C4::Context->preference('IndependentBranches')
 972       && C4::Context->userenv
 973       && !C4::Context->IsSuperLibrarian()
 974       && C4::Context->userenv->{branch};
 975 }
 976
 977 =head3 temporary_directory
 978
 979 Returns root directory for temporary storage
 980
 981 =cut
 982
 983 sub temporary_directory {
 984     my ( $class ) = @_;
 985     return C4::Context->config('tmp_path') || File::Spec->tmpdir;
 986 }
 987
 988 =head3 set_remote_address
 989
 990 set_remote_address should be called at the beginning of every script
 991 that is *not* running under plack in order to the REMOTE_ADDR environment
 992 variable to be set correctly.
 993
 994 =cut
 995
 996 sub set_remote_address {
 997     if ( C4::Context->config('koha_trusted_proxies') ) {
 998         require CGI;
 999         my $header = CGI->http('HTTP_X_FORWARDED_FOR');
1000
1001         if ($header) {
1002             require Koha::Middleware::RealIP;
1003             $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header );
1004         }
1005     }
1006 }
1007
1008 =head3 https_enabled
1009
1010 https_enabled should be called when checking if a HTTPS connection
1011 is used.
1012
1013 Note that this depends on a HTTPS environmental variable being defined
1014 by the web server. This function may not return the expected result,
1015 if your web server or reverse proxies are not setting the correct
1016 X-Forwarded-Proto headers and HTTPS environmental variable.
1017
1018 Note too that the HTTPS value can vary from web server to web server.
1019 We are relying on the convention of the value being "on" or "ON" here.
1020
1021 =cut
1022
1023 sub https_enabled {
1024     my $https_enabled = 0;
1025     my $env_https = $ENV{HTTPS};
1026     if ($env_https){
1027         if ($env_https =~ /^ON$/i){
1028             $https_enabled = 1;
1029         }
1030     }
1031     return $https_enabled;
1032 }
1033
1034 1;
1035
1036 =head3 needs_install
1037
1038     if ( $context->needs_install ) { ... }
1039
1040 This method returns a boolean representing the install status of the Koha instance.
1041
1042 =cut
1043
1044 sub needs_install {
1045     my ($self) = @_;
1046     return ($self->preference('Version')) ? 0 : 1;
1047 }
1048
1049 __END__
1050
1051 =head1 ENVIRONMENT
1052
1053 =head2 C<KOHA_CONF>
1054
1055 Specifies the configuration file to read.
1056
1057 =head1 AUTHORS
1058
1059 Andrew Arensburger <arensb at ooblick dot com>
1060
1061 Joshua Ferraro <jmf at liblime dot com>
1062