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 Zconn
 482
 483   $Zconn = C4::Context->Zconn
 484
 485 Returns a connection to the Zebra database
 486
 487 C<$self>
 488
 489 C<$server> one of the servers defined in the koha-conf.xml file
 490
 491 C<$async> whether this is a asynchronous connection
 492
 493 =cut
 494
 495 sub Zconn {
 496     my ($self, $server, $async ) = @_;
 497     my $cache_key = join ('::', (map { $_ // '' } ($server, $async )));
 498     if ( (!defined($ENV{GATEWAY_INTERFACE})) && defined($context->{"Zconn"}->{$cache_key}) && (0 == $context->{"Zconn"}->{$cache_key}->errcode()) ) {
 499         # if we are running the script from the commandline, lets try to use the caching
 500         return $context->{"Zconn"}->{$cache_key};
 501     }
 502     $context->{"Zconn"}->{$cache_key}->destroy() if defined($context->{"Zconn"}->{$cache_key}); #destroy old connection before making a new one
 503     $context->{"Zconn"}->{$cache_key} = &_new_Zconn( $server, $async );
 504     return $context->{"Zconn"}->{$cache_key};
 505 }
 506
 507 =head2 _new_Zconn
 508
 509 $context->{"Zconn"} = &_new_Zconn($server,$async);
 510
 511 Internal function. Creates a new database connection from the data given in the current context and returns it.
 512
 513 C<$server> one of the servers defined in the koha-conf.xml file
 514
 515 C<$async> whether this is a asynchronous connection
 516
 517 C<$auth> whether this connection has rw access (1) or just r access (0 or NULL)
 518
 519 =cut
 520
 521 sub _new_Zconn {
 522     my ( $server, $async ) = @_;
 523
 524     my $tried=0; # first attempt
 525     my $Zconn; # connection object
 526     my $elementSetName;
 527     my $syntax;
 528
 529     $server //= "biblioserver";
 530
 531     $syntax = 'xml';
 532     $elementSetName = 'marcxml';
 533
 534     my $host = _common_config($server, 'listen')->{content};
 535     my $serverinfo = _common_config($server, 'serverinfo');
 536     my $user = $serverinfo->{user};
 537     my $password = $serverinfo->{password};
 538     eval {
 539         # set options
 540         my $o = ZOOM::Options->new();
 541         $o->option(user => $user) if $user && $password;
 542         $o->option(password => $password) if $user && $password;
 543         $o->option(async => 1) if $async;
 544         $o->option(cqlfile=> _common_config($server, 'server')->{cql2rpn});
 545         $o->option(cclfile=> $serverinfo->{ccl2rpn});
 546         $o->option(preferredRecordSyntax => $syntax);
 547         $o->option(elementSetName => $elementSetName) if $elementSetName;
 548         $o->option(databaseName => _common_config($server, 'config') || 'biblios');
 549
 550         # create a new connection object
 551         $Zconn= create ZOOM::Connection($o);
 552
 553         # forge to server
 554         $Zconn->connect($host, 0);
 555
 556         # check for errors and warn
 557         if ($Zconn->errcode() !=0) {
 558             warn "something wrong with the connection: ". $Zconn->errmsg();
 559         }
 560     };
 561     return $Zconn;
 562 }
 563
 564 # _new_dbh
 565 # Internal helper function (not a method!). This creates a new
 566 # database connection from the data given in the current context, and
 567 # returns it.
 568 sub _new_dbh
 569 {
 570
 571     Koha::Database->schema({ new => 1 })->storage->dbh;
 572 }
 573
 574 =head2 dbh
 575
 576   $dbh = C4::Context->dbh;
 577
 578 Returns a database handle connected to the Koha database for the
 579 current context. If no connection has yet been made, this method
 580 creates one, and connects to the database.
 581
 582 This database handle is cached for future use: if you call
 583 C<C4::Context-E<gt>dbh> twice, you will get the same handle both
 584 times. If you need a second database handle, use C<&new_dbh> and
 585 possibly C<&set_dbh>.
 586
 587 =cut
 588
 589 #'
 590 sub dbh
 591 {
 592     my $self = shift;
 593     my $params = shift;
 594
 595     unless ( $params->{new} ) {
 596         return Koha::Database->schema->storage->dbh;
 597     }
 598
 599     return Koha::Database->schema({ new => 1 })->storage->dbh;
 600 }
 601
 602 =head2 new_dbh
 603
 604   $dbh = C4::Context->new_dbh;
 605
 606 Creates a new connection to the Koha database for the current context,
 607 and returns the database handle (a C<DBI::db> object).
 608
 609 The handle is not saved anywhere: this method is strictly a
 610 convenience function; the point is that it knows which database to
 611 connect to so that the caller doesn't have to know.
 612
 613 =cut
 614
 615 #'
 616 sub new_dbh
 617 {
 618     my $self = shift;
 619
 620     return &dbh({ new => 1 });
 621 }
 622
 623 =head2 set_dbh
 624
 625   $my_dbh = C4::Connect->new_dbh;
 626   C4::Connect->set_dbh($my_dbh);
 627   ...
 628   C4::Connect->restore_dbh;
 629
 630 C<&set_dbh> and C<&restore_dbh> work in a manner analogous to
 631 C<&set_context> and C<&restore_context>.
 632
 633 C<&set_dbh> saves the current database handle on a stack, then sets
 634 the current database handle to C<$my_dbh>.
 635
 636 C<$my_dbh> is assumed to be a good database handle.
 637
 638 =cut
 639
 640 #'
 641 sub set_dbh
 642 {
 643     my $self = shift;
 644     my $new_dbh = shift;
 645
 646     # Save the current database handle on the handle stack.
 647     # We assume that $new_dbh is all good: if the caller wants to
 648     # screw himself by passing an invalid handle, that's fine by
 649     # us.
 650     push @{$context->{"dbh_stack"}}, $context->{"dbh"};
 651     $context->{"dbh"} = $new_dbh;
 652 }
 653
 654 =head2 restore_dbh
 655
 656   C4::Context->restore_dbh;
 657
 658 Restores the database handle saved by an earlier call to
 659 C<C4::Context-E<gt>set_dbh>.
 660
 661 =cut
 662
 663 #'
 664 sub restore_dbh
 665 {
 666     my $self = shift;
 667
 668     if ($#{$context->{"dbh_stack"}} < 0)
 669     {
 670         # Stack underflow
 671         die "DBH stack underflow";
 672     }
 673
 674     # Pop the old database handle and set it.
 675     $context->{"dbh"} = pop @{$context->{"dbh_stack"}};
 676
 677     # FIXME - If it is determined that restore_context should
 678     # return something, then this function should, too.
 679 }
 680
 681 =head2 userenv
 682
 683   C4::Context->userenv;
 684
 685 Retrieves a hash for user environment variables.
 686
 687 This hash shall be cached for future use: if you call
 688 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 689
 690 =cut
 691
 692 #'
 693 sub userenv {
 694     my $var = $context->{"activeuser"};
 695     if (defined $var and defined $context->{"userenv"}->{$var}) {
 696         return $context->{"userenv"}->{$var};
 697     } else {
 698         return;
 699     }
 700 }
 701
 702 =head2 set_userenv
 703
 704   C4::Context->set_userenv($usernum, $userid, $usercnum,
 705                            $userfirstname, $usersurname,
 706                            $userbranch, $branchname, $userflags,
 707                            $emailaddress, $shibboleth
 708                            $desk_id, $desk_name,
 709                            $register_id, $register_name);
 710
 711 Establish a hash of user environment variables.
 712
 713 set_userenv is called in Auth.pm
 714
 715 =cut
 716
 717 #'
 718 sub set_userenv {
 719     shift @_;
 720     my (
 721         $usernum,      $userid,     $usercnum,   $userfirstname,
 722         $usersurname,  $userbranch, $branchname, $userflags,
 723         $emailaddress, $shibboleth, $desk_id,    $desk_name,
 724         $register_id,  $register_name
 725     ) = @_;
 726
 727     my $var=$context->{"activeuser"} || '';
 728     my $cell = {
 729         "number"     => $usernum,
 730         "id"         => $userid,
 731         "cardnumber" => $usercnum,
 732         "firstname"  => $userfirstname,
 733         "surname"    => $usersurname,
 734
 735         #possibly a law problem
 736         "branch"        => $userbranch,
 737         "branchname"    => $branchname,
 738         "flags"         => $userflags,
 739         "emailaddress"  => $emailaddress,
 740         "shibboleth"    => $shibboleth,
 741         "desk_id"       => $desk_id,
 742         "desk_name"     => $desk_name,
 743         "register_id"   => $register_id,
 744         "register_name" => $register_name
 745     };
 746     $context->{userenv}->{$var} = $cell;
 747     return $cell;
 748 }
 749
 750 =head2 _new_userenv
 751
 752   C4::Context->_new_userenv($session);  # FIXME: This calling style is wrong for what looks like an _internal function
 753
 754 Builds a hash for user environment variables.
 755
 756 This hash shall be cached for future use: if you call
 757 C<C4::Context-E<gt>userenv> twice, you will get the same hash without real DB access
 758
 759 _new_userenv is called in Auth.pm
 760
 761 =cut
 762
 763 #'
 764 sub _new_userenv
 765 {
 766     shift;  # Useless except it compensates for bad calling style
 767     my ($sessionID)= @_;
 768      $context->{"activeuser"}=$sessionID;
 769 }
 770
 771 =head2 _unset_userenv
 772
 773   C4::Context->_unset_userenv;
 774
 775 Destroys the hash for activeuser user environment variables.
 776
 777 =cut
 778
 779 #'
 780
 781 sub _unset_userenv
 782 {
 783     my ($sessionID)= @_;
 784     undef $context->{"activeuser"} if ($context->{"activeuser"} eq $sessionID);
 785 }
 786
 787
 788 =head2 get_versions
 789
 790   C4::Context->get_versions
 791
 792 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'.
 793
 794 =cut
 795
 796 #'
 797
 798 # A little example sub to show more debugging info for CGI::Carp
 799 sub get_versions {
 800     my %versions;
 801     $versions{kohaVersion}  = Koha::version();
 802     $versions{kohaDbVersion} = C4::Context->preference('version');
 803     $versions{osVersion} = join(" ", POSIX::uname());
 804     $versions{perlVersion} = $];
 805     {
 806         no warnings qw(exec); # suppress warnings if unable to find a program in $PATH
 807         $versions{mysqlVersion}  = `mysql -V`;
 808         $versions{apacheVersion} = (`apache2ctl -v`)[0];
 809         $versions{apacheVersion} = `httpd -v`             unless  $versions{apacheVersion} ;
 810         $versions{apacheVersion} = `httpd2 -v`            unless  $versions{apacheVersion} ;
 811         $versions{apacheVersion} = `apache2 -v`           unless  $versions{apacheVersion} ;
 812         $versions{apacheVersion} = `/usr/sbin/apache2 -v` unless  $versions{apacheVersion} ;
 813     }
 814     return %versions;
 815 }
 816
 817 =head2 tz
 818
 819   C4::Context->tz
 820
 821   Returns a DateTime::TimeZone object for the system timezone
 822
 823 =cut
 824
 825 sub tz {
 826     my $self = shift;
 827     if (!defined $context->{tz}) {
 828         my $timezone = $context->{config}->timezone;
 829         $context->{tz} = DateTime::TimeZone->new(name => $timezone);
 830     }
 831     return $context->{tz};
 832 }
 833
 834
 835 =head2 IsSuperLibrarian
 836
 837     C4::Context->IsSuperLibrarian();
 838
 839 =cut
 840
 841 sub IsSuperLibrarian {
 842     my $userenv = C4::Context->userenv;
 843
 844     unless ( $userenv and exists $userenv->{flags} ) {
 845         # If we reach this without a user environment,
 846         # assume that we're running from a command-line script,
 847         # and act as a superlibrarian.
 848         carp("C4::Context->userenv not defined!");
 849         return 1;
 850     }
 851
 852     return ($userenv->{flags}//0) % 2;
 853 }
 854
 855 =head2 interface
 856
 857 Sets the current interface for later retrieval in any Perl module
 858
 859     C4::Context->interface('opac');
 860     C4::Context->interface('intranet');
 861     my $interface = C4::Context->interface;
 862
 863 =cut
 864
 865 sub interface {
 866     my ($class, $interface) = @_;
 867
 868     if (defined $interface) {
 869         $interface = lc $interface;
 870         if (   $interface eq 'api'
 871             || $interface eq 'opac'
 872             || $interface eq 'intranet'
 873             || $interface eq 'sip'
 874             || $interface eq 'cron'
 875             || $interface eq 'commandline' )
 876         {
 877             $context->{interface} = $interface;
 878         } else {
 879             warn "invalid interface : '$interface'";
 880         }
 881     }
 882
 883     return $context->{interface} // 'opac';
 884 }
 885
 886 # always returns a string for OK comparison via "eq" or "ne"
 887 sub mybranch {
 888     C4::Context->userenv           or return '';
 889     return C4::Context->userenv->{branch} || '';
 890 }
 891
 892 =head2 only_my_library
 893
 894     my $test = C4::Context->only_my_library;
 895
 896     Returns true if you enabled IndependentBranches and the current user
 897     does not have superlibrarian permissions.
 898
 899 =cut
 900
 901 sub only_my_library {
 902     return
 903          C4::Context->preference('IndependentBranches')
 904       && C4::Context->userenv
 905       && !C4::Context->IsSuperLibrarian()
 906       && C4::Context->userenv->{branch};
 907 }
 908
 909 =head3 temporary_directory
 910
 911 Returns root directory for temporary storage
 912
 913 =cut
 914
 915 sub temporary_directory {
 916     my ( $class ) = @_;
 917     return C4::Context->config('tmp_path') || File::Spec->tmpdir;
 918 }
 919
 920 =head3 set_remote_address
 921
 922 set_remote_address should be called at the beginning of every script
 923 that is *not* running under plack in order to the REMOTE_ADDR environment
 924 variable to be set correctly.
 925
 926 =cut
 927
 928 sub set_remote_address {
 929     if ( C4::Context->config('koha_trusted_proxies') ) {
 930         require CGI;
 931         my $header = CGI->http('HTTP_X_FORWARDED_FOR');
 932
 933         if ($header) {
 934             require Koha::Middleware::RealIP;
 935             $ENV{REMOTE_ADDR} = Koha::Middleware::RealIP::get_real_ip( $ENV{REMOTE_ADDR}, $header );
 936         }
 937     }
 938 }
 939
 940 =head3 https_enabled
 941
 942 https_enabled should be called when checking if a HTTPS connection
 943 is used.
 944
 945 Note that this depends on a HTTPS environmental variable being defined
 946 by the web server. This function may not return the expected result,
 947 if your web server or reverse proxies are not setting the correct
 948 X-Forwarded-Proto headers and HTTPS environmental variable.
 949
 950 Note too that the HTTPS value can vary from web server to web server.
 951 We are relying on the convention of the value being "on" or "ON" here.
 952
 953 =cut
 954
 955 sub https_enabled {
 956     my $https_enabled = 0;
 957     my $env_https = $ENV{HTTPS};
 958     if ($env_https){
 959         if ($env_https =~ /^ON$/i){
 960             $https_enabled = 1;
 961         }
 962     }
 963     return $https_enabled;
 964 }
 965
 966 1;
 967
 968 =head3 needs_install
 969
 970     if ( $context->needs_install ) { ... }
 971
 972 This method returns a boolean representing the install status of the Koha instance.
 973
 974 =cut
 975
 976 sub needs_install {
 977     my ($self) = @_;
 978     return ($self->preference('Version')) ? 0 : 1;
 979 }
 980
 981 __END__
 982
 983 =head1 ENVIRONMENT
 984
 985 =head2 C<KOHA_CONF>
 986
 987 Specifies the configuration file to read.
 988
 989 =head1 AUTHORS
 990
 991 Andrew Arensburger <arensb at ooblick dot com>
 992
 993 Joshua Ferraro <jmf at liblime dot com>
 994