C4/Context.pm

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