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