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