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