C4/Context.pm

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