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 ($usernum, $userid, $usercnum, $userfirstname, $usersurname, $userbranch, $branchname, $userflags, $emailaddress, $shibboleth, $desk_id, $desk_name, $register_id, $register_name)=
 749     map { Encode::is_utf8( $_ ) ? $_ : Encode::decode('UTF-8', $_) } # CGI::Session doesn't handle utf-8, so we decode it here
 750     @_;
 751     my $var=$context->{"activeuser"} || '';
 752     my $cell = {
 753         "number"     => $usernum,
 754         "id"         => $userid,
 755         "cardnumber" => $usercnum,
 756         "firstname"  => $userfirstname,
 757         "surname"    => $usersurname,
 758
 759         #possibly a law problem
 760         "branch"        => $userbranch,
 761         "branchname"    => $branchname,
 762         "flags"         => $userflags,
 763         "emailaddress"  => $emailaddress,
 764         "shibboleth"    => $shibboleth,
 765         "desk_id"       => $desk_id,
 766         "desk_name"     => $desk_name,
 767         "register_id"   => $register_id,
 768         "register_name" => $register_name
 769     };
 770     $context->{userenv}->{$var} = $cell;
 771     return $cell;
 772 }
 773
 774 sub set_shelves_userenv {
 775         my ($type, $shelves) = @_ or return;
 776         my $activeuser = $context->{activeuser} or return;
 777         $context->{userenv}->{$activeuser}->{barshelves} = $shelves if $type eq 'bar';
 778         $context->{userenv}->{$activeuser}->{pubshelves} = $shelves if $type eq 'pub';
 779         $context->{userenv}->{$activeuser}->{totshelves} = $shelves if $type eq 'tot';
 780 }
 781
 782 sub get_shelves_userenv {
 783         my $active;
 784         unless ($active = $context->{userenv}->{$context->{activeuser}}) {
 785                 $debug and warn "get_shelves_userenv cannot retrieve context->{userenv}->{context->{activeuser}}";
 786                 return;
 787         }
 788         my $totshelves = $active->{totshelves} or undef;
 789         my $pubshelves = $active->{pubshelves} or undef;
 790         my $barshelves = $active->{barshelves} or undef;
 791         return ($totshelves, $pubshelves, $barshelves);
 792 }
 793
 794 =head2 _new_userenv
 795
 796   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 797
 798 Builds a hash for user environment variables.
 799
 800 This hash shall be cached for future use: if you call
 801 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 802
 803 _new_userenv is called in Auth.pm
 804
 805 =cut
 806
 807 #'
 808 sub _new_userenv
 809 {
 810     shift;  # Useless except it compensates for bad calling style
 811     my ($sessionID)= @_;
 812      $context->{"activeuser"}=$sessionID;
 813 }
 814
 815 =head2 _unset_userenv
 816
 817   C4::Context->_unset_userenv;
 818
 819 Destroys the hash for activeuser user environment variables.
 820
 821 =cut
 822
 823 #'
 824
 825 sub _unset_userenv
 826 {
 827     my ($sessionID)= @_;
 828     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
 829 }
 830
 831
 832 =head2 get_versions
 833
 834   C4::Context->get_versions
 835
 836 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'.
 837
 838 =cut
 839
 840 #'
 841
 842 # A little example sub to show more debugging info for CGI::Carp
 843 sub get_versions {
 844     my %versions;
 845     $versions{kohaVersion}  = Koha::version();
 846     $versions{kohaDbVersion} = C4::Context->preference('version');
 847     $versions{osVersion} = join(" ", POSIX::uname());
 848     $versions{perlVersion} = $];
 849     {
 850         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
 851         $versions{mysqlVersion}  = `mysql -V`;
 852         $versions{apacheVersion} = (`apache2ctl -v`)[0];
 853         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
 854         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
 855         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
 856         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
 857     }
 858     return %versions;
 859 }
 860
 861 =head2 timezone
 862
 863   my $C4::Context->timzone
 864
 865   Returns a timezone code for the instance of Koha
 866
 867 =cut
 868
 869 sub timezone {
 870     my $self = shift;
 871
 872     my $timezone = C4::Context->config('timezone') || $ENV{TZ} || 'local';
 873     if ( !DateTime::TimeZone->is_valid_name( $timezone ) ) {
 874         warn "Invalid timezone in koha-conf.xml ($timezone)";
 875         $timezone = 'local';
 876     }
 877
 878     return $timezone;
 879 }
 880
 881 =head2 tz
 882
 883   C4::Context->tz
 884
 885   Returns a DateTime::TimeZone object for the system timezone
 886
 887 =cut
 888
 889 sub tz {
 890     my $self = shift;
 891     if (!defined $context->{tz}) {
 892         my $timezone = $self->timezone;
 893         $context->{tz} = DateTime::TimeZone->new(name => $timezone);
 894     }
 895     return $context->{tz};
 896 }
 897
 898
 899 =head2 IsSuperLibrarian
 900
 901     C4::Context->IsSuperLibrarian();
 902
 903 =cut
 904
 905 sub IsSuperLibrarian {
 906     my $userenv = C4::Context->userenv;
 907
 908     unless ( $userenv and exists $userenv->{flags} ) {
 909         # If we reach this without a user environment,
 910         # assume that we're running from a command-line script,
 911         # and act as a superlibrarian.
 912         carp("C4::Context->userenv not defined!");
 913         return 1;
 914     }
 915
 916     return ($userenv->{flags}//0) % 2;
 917 }
 918
 919 =head2 interface
 920
 921 Sets the current interface for later retrieval in any Perl module
 922
 923     C4::Context->interface('opac');
 924     C4::Context->interface('intranet');
 925     my $interface = C4::Context->interface;
 926
 927 =cut
 928
 929 sub interface {
 930     my ($class, $interface) = @_;
 931
 932     if (defined $interface) {
 933         $interface = lc $interface;
 934         if (   $interface eq 'api'
 935             || $interface eq 'opac'
 936             || $interface eq 'intranet'
 937             || $interface eq 'sip'
 938             || $interface eq 'cron'
 939             || $interface eq 'commandline' )
 940         {
 941             $context->{interface} = $interface;
 942         } else {
 943             warn "invalid interface : '$interface'";
 944         }
 945     }
 946
 947     return $context->{interface} // 'opac';
 948 }
 949
 950 # always returns a string for OK comparison via "eq" or "ne"
 951 sub mybranch {
 952     C4::Context->userenv           or return '';
 953     return C4::Context->userenv->{branch} || '';
 954 }
 955
 956 =head2 only_my_library
 957
 958     my $test = C4::Context->only_my_library;
 959
 960     Returns true if you enabled IndependentBranches and the current user
 961     does not have superlibrarian permissions.
 962
 963 =cut
 964
 965 sub only_my_library {
 966     return
 967          C4::Context->preference('IndependentBranches')
 968       && C4::Context->userenv
 969       && !C4::Context->IsSuperLibrarian()
 970       && C4::Context->userenv->{branch};
 971 }
 972
 973 =head3 temporary_directory
 974
 975 Returns root directory for temporary storage
 976
 977 =cut
 978
 979 sub temporary_directory {
 980     my ( $class ) = @_;
 981     return C4::Context->config('tmp_path') || File::Spec->tmpdir;
 982 }
 983
 984 =head3 set_remote_address
 985
 986 set_remote_address should be called at the beginning of every script
 987 that is *not* running under plack in order to the REMOTE_ADDR environment
 988 variable to be set correctly.
 989
 990 =cut
 991
 992 sub set_remote_address {
 993     if ( C4::Context->config('koha_trusted_proxies') ) {
 994         require CGI;
 995         my $header = CGI->http('HTTP_X_FORWARDED_FOR');
 996
 997         if ($header) {
 998             require Koha::Middleware::RealIP;
 999             $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header );
1000         }
1001     }
1002 }
1003
1004 =head3 https_enabled
1005
1006 https_enabled should be called when checking if a HTTPS connection
1007 is used.
1008
1009 Note that this depends on a HTTPS environmental variable being defined
1010 by the web server. This function may not return the expected result,
1011 if your web server or reverse proxies are not setting the correct
1012 X-Forwarded-Proto headers and HTTPS environmental variable.
1013
1014 Note too that the HTTPS value can vary from web server to web server.
1015 We are relying on the convention of the value being "on" or "ON" here.
1016
1017 =cut
1018
1019 sub https_enabled {
1020     my $https_enabled = 0;
1021     my $env_https = $ENV{HTTPS};
1022     if ($env_https){
1023         if ($env_https =~ /^ON$/i){
1024             $https_enabled = 1;
1025         }
1026     }
1027     return $https_enabled;
1028 }
1029
1030 1;
1031
1032 =head3 needs_install
1033
1034     if ( $context->needs_install ) { ... }
1035
1036 This method returns a boolean representing the install status of the Koha instance.
1037
1038 =cut
1039
1040 sub needs_install {
1041     my ($self) = @_;
1042     return ($self->preference('Version')) ? 0 : 1;
1043 }
1044
1045 __END__
1046
1047 =head1 ENVIRONMENT
1048
1049 =head2 C<KOHA_CONF>
1050
1051 Specifies the configuration file to read.
1052
1053 =head1 AUTHORS
1054
1055 Andrew Arensburger <arensb at ooblick dot com>
1056
1057 Joshua Ferraro <jmf at liblime dot com>
1058