C4/Koha.pm

   1 package C4::Koha;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 # Parts Copyright 2010 Nelsonville Public Library
   5 # Parts copyright 2010 BibLibre
   6 #
   7 # This file is part of Koha.
   8 #
   9 # Koha is free software; you can redistribute it and/or modify it under the
  10 # terms of the GNU General Public License as published by the Free Software
  11 # Foundation; either version 2 of the License, or (at your option) any later
  12 # version.
  13 #
  14 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  15 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  16 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License along
  19 # with Koha; if not, write to the Free Software Foundation, Inc.,
  20 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  21
  22
  23 use strict;
  24 #use warnings; FIXME - Bug 2505
  25
  26 use C4::Context;
  27
  28 use Memoize;
  29 use DateTime;
  30 use DateTime::Format::MySQL;
  31 use autouse 'Data::Dumper' => qw(Dumper);
  32
  33 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
  34
  35 BEGIN {
  36     $VERSION = 3.07.00.049;
  37         require Exporter;
  38         @ISA    = qw(Exporter);
  39         @EXPORT = qw(
  40                 &slashifyDate
  41                 &subfield_is_koha_internal_p
  42                 &GetPrinters &GetPrinter
  43                 &GetItemTypes &getitemtypeinfo
  44                 &GetCcodes
  45                 &GetSupportName &GetSupportList
  46                 &get_itemtypeinfos_of
  47                 &getframeworks &getframeworkinfo
  48                 &getauthtypes &getauthtype
  49                 &getallthemes
  50                 &getFacets
  51                 &displayServers
  52                 &getnbpages
  53                 &get_infos_of
  54                 &get_notforloan_label_of
  55                 &getitemtypeimagedir
  56                 &getitemtypeimagesrc
  57                 &getitemtypeimagelocation
  58                 &GetAuthorisedValues
  59                 &GetAuthorisedValueCategories
  60                 &GetKohaAuthorisedValues
  61                 &GetKohaAuthorisedValuesFromField
  62     &GetKohaAuthorisedValueLib
  63     &GetAuthorisedValueByCode
  64     &GetKohaImageurlFromAuthorisedValues
  65                 &GetAuthValCode
  66                 &GetNormalizedUPC
  67                 &GetNormalizedISBN
  68                 &GetNormalizedEAN
  69                 &GetNormalizedOCLCNumber
  70         &xml_escape
  71
  72                 $DEBUG
  73         );
  74         $DEBUG = 0;
  75 @EXPORT_OK = qw( GetDailyQuote );
  76 }
  77
  78 # expensive functions
  79 memoize('GetAuthorisedValues');
  80
  81 =head1 NAME
  82
  83 C4::Koha - Perl Module containing convenience functions for Koha scripts
  84
  85 =head1 SYNOPSIS
  86
  87 use C4::Koha;
  88
  89 =head1 DESCRIPTION
  90
  91 Koha.pm provides many functions for Koha scripts.
  92
  93 =head1 FUNCTIONS
  94
  95 =cut
  96
  97 =head2 slashifyDate
  98
  99   $slash_date = &slashifyDate($dash_date);
 100
 101 Takes a string of the form "DD-MM-YYYY" (or anything separated by
 102 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
 103
 104 =cut
 105
 106 sub slashifyDate {
 107
 108     # accepts a date of the form xx-xx-xx[xx] and returns it in the
 109     # form xx/xx/xx[xx]
 110     my @dateOut = split( '-', shift );
 111     return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
 112 }
 113
 114 # FIXME.. this should be moved to a MARC-specific module
 115 sub subfield_is_koha_internal_p ($) {
 116     my ($subfield) = @_;
 117
 118     # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
 119     # But real MARC subfields are always single-character
 120     # so it really is safer just to check the length
 121
 122     return length $subfield != 1;
 123 }
 124
 125 =head2 GetSupportName
 126
 127   $itemtypename = &GetSupportName($codestring);
 128
 129 Returns a string with the name of the itemtype.
 130
 131 =cut
 132
 133 sub GetSupportName{
 134         my ($codestring)=@_;
 135         return if (! $codestring);
 136         my $resultstring;
 137         my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
 138         if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
 139                 my $query = qq|
 140                         SELECT description
 141                         FROM   itemtypes
 142                         WHERE itemtype=?
 143                         order by description
 144                 |;
 145                 my $sth = C4::Context->dbh->prepare($query);
 146                 $sth->execute($codestring);
 147                 ($resultstring)=$sth->fetchrow;
 148                 return $resultstring;
 149         } else {
 150         my $sth =
 151             C4::Context->dbh->prepare(
 152                     "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
 153                     );
 154         $sth->execute( $advanced_search_types, $codestring );
 155         my $data = $sth->fetchrow_hashref;
 156         return $$data{'lib'};
 157         }
 158
 159 }
 160 =head2 GetSupportList
 161
 162   $itemtypes = &GetSupportList();
 163
 164 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
 165
 166 build a HTML select with the following code :
 167
 168 =head3 in PERL SCRIPT
 169
 170     my $itemtypes = GetSupportList();
 171     $template->param(itemtypeloop => $itemtypes);
 172
 173 =head3 in TEMPLATE
 174
 175     <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 176         <select name="itemtype">
 177             <option value="">Default</option>
 178         <!-- TMPL_LOOP name="itemtypeloop" -->
 179             <option value="<!-- TMPL_VAR name="itemtype" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->> <!--TMPL_IF Name="imageurl"--><img alt="<!-- TMPL_VAR name="description" -->" src="<!--TMPL_VAR Name="imageurl"-->><!--TMPL_ELSE-->"<!-- TMPL_VAR name="description" --><!--/TMPL_IF--></option>
 180         <!-- /TMPL_LOOP -->
 181         </select>
 182         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 183         <input type="submit" value="OK" class="button">
 184     </form>
 185
 186 =cut
 187
 188 sub GetSupportList{
 189         my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
 190         if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
 191                 my $query = qq|
 192                         SELECT *
 193                         FROM   itemtypes
 194                         order by description
 195                 |;
 196                 my $sth = C4::Context->dbh->prepare($query);
 197                 $sth->execute;
 198                 return $sth->fetchall_arrayref({});
 199         } else {
 200                 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
 201                 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
 202                 return \@results;
 203         }
 204 }
 205 =head2 GetItemTypes
 206
 207   $itemtypes = &GetItemTypes();
 208
 209 Returns information about existing itemtypes.
 210
 211 build a HTML select with the following code :
 212
 213 =head3 in PERL SCRIPT
 214
 215     my $itemtypes = GetItemTypes;
 216     my @itemtypesloop;
 217     foreach my $thisitemtype (sort keys %$itemtypes) {
 218         my $selected = 1 if $thisitemtype eq $itemtype;
 219         my %row =(value => $thisitemtype,
 220                     selected => $selected,
 221                     description => $itemtypes->{$thisitemtype}->{'description'},
 222                 );
 223         push @itemtypesloop, \%row;
 224     }
 225     $template->param(itemtypeloop => \@itemtypesloop);
 226
 227 =head3 in TEMPLATE
 228
 229     <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 230         <select name="itemtype">
 231             <option value="">Default</option>
 232         <!-- TMPL_LOOP name="itemtypeloop" -->
 233             <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
 234         <!-- /TMPL_LOOP -->
 235         </select>
 236         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 237         <input type="submit" value="OK" class="button">
 238     </form>
 239
 240 =cut
 241
 242 sub GetItemTypes {
 243
 244     # returns a reference to a hash of references to itemtypes...
 245     my %itemtypes;
 246     my $dbh   = C4::Context->dbh;
 247     my $query = qq|
 248         SELECT *
 249         FROM   itemtypes
 250     |;
 251     my $sth = $dbh->prepare($query);
 252     $sth->execute;
 253     while ( my $IT = $sth->fetchrow_hashref ) {
 254         $itemtypes{ $IT->{'itemtype'} } = $IT;
 255     }
 256     return ( \%itemtypes );
 257 }
 258
 259 sub get_itemtypeinfos_of {
 260     my @itemtypes = @_;
 261
 262     my $placeholders = join( ', ', map { '?' } @itemtypes );
 263     my $query = <<"END_SQL";
 264 SELECT itemtype,
 265        description,
 266        imageurl,
 267        notforloan
 268   FROM itemtypes
 269   WHERE itemtype IN ( $placeholders )
 270 END_SQL
 271
 272     return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
 273 }
 274
 275 # this is temporary until we separate collection codes and item types
 276 sub GetCcodes {
 277     my $count = 0;
 278     my @results;
 279     my $dbh = C4::Context->dbh;
 280     my $sth =
 281       $dbh->prepare(
 282         "SELECT * FROM authorised_values ORDER BY authorised_value");
 283     $sth->execute;
 284     while ( my $data = $sth->fetchrow_hashref ) {
 285         if ( $data->{category} eq "CCODE" ) {
 286             $count++;
 287             $results[$count] = $data;
 288
 289             #warn "data: $data";
 290         }
 291     }
 292     $sth->finish;
 293     return ( $count, @results );
 294 }
 295
 296 =head2 getauthtypes
 297
 298   $authtypes = &getauthtypes();
 299
 300 Returns information about existing authtypes.
 301
 302 build a HTML select with the following code :
 303
 304 =head3 in PERL SCRIPT
 305
 306    my $authtypes = getauthtypes;
 307    my @authtypesloop;
 308    foreach my $thisauthtype (keys %$authtypes) {
 309        my $selected = 1 if $thisauthtype eq $authtype;
 310        my %row =(value => $thisauthtype,
 311                 selected => $selected,
 312                 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
 313             );
 314         push @authtypesloop, \%row;
 315     }
 316     $template->param(itemtypeloop => \@itemtypesloop);
 317
 318 =head3 in TEMPLATE
 319
 320   <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 321     <select name="authtype">
 322     <!-- TMPL_LOOP name="authtypeloop" -->
 323         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
 324     <!-- /TMPL_LOOP -->
 325     </select>
 326     <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 327     <input type="submit" value="OK" class="button">
 328   </form>
 329
 330
 331 =cut
 332
 333 sub getauthtypes {
 334
 335     # returns a reference to a hash of references to authtypes...
 336     my %authtypes;
 337     my $dbh = C4::Context->dbh;
 338     my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
 339     $sth->execute;
 340     while ( my $IT = $sth->fetchrow_hashref ) {
 341         $authtypes{ $IT->{'authtypecode'} } = $IT;
 342     }
 343     return ( \%authtypes );
 344 }
 345
 346 sub getauthtype {
 347     my ($authtypecode) = @_;
 348
 349     # returns a reference to a hash of references to authtypes...
 350     my %authtypes;
 351     my $dbh = C4::Context->dbh;
 352     my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
 353     $sth->execute($authtypecode);
 354     my $res = $sth->fetchrow_hashref;
 355     return $res;
 356 }
 357
 358 =head2 getframework
 359
 360   $frameworks = &getframework();
 361
 362 Returns information about existing frameworks
 363
 364 build a HTML select with the following code :
 365
 366 =head3 in PERL SCRIPT
 367
 368   my $frameworks = frameworks();
 369   my @frameworkloop;
 370   foreach my $thisframework (keys %$frameworks) {
 371     my $selected = 1 if $thisframework eq $frameworkcode;
 372     my %row =(value => $thisframework,
 373                 selected => $selected,
 374                 description => $frameworks->{$thisframework}->{'frameworktext'},
 375             );
 376     push @frameworksloop, \%row;
 377   }
 378   $template->param(frameworkloop => \@frameworksloop);
 379
 380 =head3 in TEMPLATE
 381
 382   <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 383     <select name="frameworkcode">
 384         <option value="">Default</option>
 385     <!-- TMPL_LOOP name="frameworkloop" -->
 386         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
 387     <!-- /TMPL_LOOP -->
 388     </select>
 389     <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 390     <input type="submit" value="OK" class="button">
 391   </form>
 392
 393 =cut
 394
 395 sub getframeworks {
 396
 397     # returns a reference to a hash of references to branches...
 398     my %itemtypes;
 399     my $dbh = C4::Context->dbh;
 400     my $sth = $dbh->prepare("select * from biblio_framework");
 401     $sth->execute;
 402     while ( my $IT = $sth->fetchrow_hashref ) {
 403         $itemtypes{ $IT->{'frameworkcode'} } = $IT;
 404     }
 405     return ( \%itemtypes );
 406 }
 407
 408 =head2 getframeworkinfo
 409
 410   $frameworkinfo = &getframeworkinfo($frameworkcode);
 411
 412 Returns information about an frameworkcode.
 413
 414 =cut
 415
 416 sub getframeworkinfo {
 417     my ($frameworkcode) = @_;
 418     my $dbh             = C4::Context->dbh;
 419     my $sth             =
 420       $dbh->prepare("select * from biblio_framework where frameworkcode=?");
 421     $sth->execute($frameworkcode);
 422     my $res = $sth->fetchrow_hashref;
 423     return $res;
 424 }
 425
 426 =head2 getitemtypeinfo
 427
 428   $itemtype = &getitemtype($itemtype);
 429
 430 Returns information about an itemtype.
 431
 432 =cut
 433
 434 sub getitemtypeinfo {
 435     my ($itemtype) = @_;
 436     my $dbh        = C4::Context->dbh;
 437     my $sth        = $dbh->prepare("select * from itemtypes where itemtype=?");
 438     $sth->execute($itemtype);
 439     my $res = $sth->fetchrow_hashref;
 440
 441     $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
 442
 443     return $res;
 444 }
 445
 446 =head2 getitemtypeimagedir
 447
 448   my $directory = getitemtypeimagedir( 'opac' );
 449
 450 pass in 'opac' or 'intranet'. Defaults to 'opac'.
 451
 452 returns the full path to the appropriate directory containing images.
 453
 454 =cut
 455
 456 sub getitemtypeimagedir {
 457         my $src = shift || 'opac';
 458         if ($src eq 'intranet') {
 459                 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
 460         } else {
 461                 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
 462         }
 463 }
 464
 465 sub getitemtypeimagesrc {
 466         my $src = shift || 'opac';
 467         if ($src eq 'intranet') {
 468                 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
 469         } else {
 470                 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
 471         }
 472 }
 473
 474 sub getitemtypeimagelocation($$) {
 475         my ( $src, $image ) = @_;
 476
 477         return '' if ( !$image );
 478     require URI::Split;
 479
 480         my $scheme = ( URI::Split::uri_split( $image ) )[0];
 481
 482         return $image if ( $scheme );
 483
 484         return getitemtypeimagesrc( $src ) . '/' . $image;
 485 }
 486
 487 =head3 _getImagesFromDirectory
 488
 489 Find all of the image files in a directory in the filesystem
 490
 491 parameters: a directory name
 492
 493 returns: a list of images in that directory.
 494
 495 Notes: this does not traverse into subdirectories. See
 496 _getSubdirectoryNames for help with that.
 497 Images are assumed to be files with .gif or .png file extensions.
 498 The image names returned do not have the directory name on them.
 499
 500 =cut
 501
 502 sub _getImagesFromDirectory {
 503     my $directoryname = shift;
 504     return unless defined $directoryname;
 505     return unless -d $directoryname;
 506
 507     if ( opendir ( my $dh, $directoryname ) ) {
 508         my @images = grep { /\.(gif|png)$/i } readdir( $dh );
 509         closedir $dh;
 510         @images = sort(@images);
 511         return @images;
 512     } else {
 513         warn "unable to opendir $directoryname: $!";
 514         return;
 515     }
 516 }
 517
 518 =head3 _getSubdirectoryNames
 519
 520 Find all of the directories in a directory in the filesystem
 521
 522 parameters: a directory name
 523
 524 returns: a list of subdirectories in that directory.
 525
 526 Notes: this does not traverse into subdirectories. Only the first
 527 level of subdirectories are returned.
 528 The directory names returned don't have the parent directory name on them.
 529
 530 =cut
 531
 532 sub _getSubdirectoryNames {
 533     my $directoryname = shift;
 534     return unless defined $directoryname;
 535     return unless -d $directoryname;
 536
 537     if ( opendir ( my $dh, $directoryname ) ) {
 538         my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
 539         closedir $dh;
 540         return @directories;
 541     } else {
 542         warn "unable to opendir $directoryname: $!";
 543         return;
 544     }
 545 }
 546
 547 =head3 getImageSets
 548
 549 returns: a listref of hashrefs. Each hash represents another collection of images.
 550
 551  { imagesetname => 'npl', # the name of the image set (npl is the original one)
 552          images => listref of image hashrefs
 553  }
 554
 555 each image is represented by a hashref like this:
 556
 557  { KohaImage     => 'npl/image.gif',
 558    StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
 559    OpacImageURL  => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
 560    checked       => 0 or 1: was this the image passed to this method?
 561                     Note: I'd like to remove this somehow.
 562  }
 563
 564 =cut
 565
 566 sub getImageSets {
 567     my %params = @_;
 568     my $checked = $params{'checked'} || '';
 569
 570     my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
 571                              url        => getitemtypeimagesrc('intranet'),
 572                         },
 573                   opac => { filesystem => getitemtypeimagedir('opac'),
 574                              url       => getitemtypeimagesrc('opac'),
 575                         }
 576                   };
 577
 578     my @imagesets = (); # list of hasrefs of image set data to pass to template
 579     my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
 580     foreach my $imagesubdir ( @subdirectories ) {
 581     warn $imagesubdir if $DEBUG;
 582         my @imagelist     = (); # hashrefs of image info
 583         my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
 584         my $imagesetactive = 0;
 585         foreach my $thisimage ( @imagenames ) {
 586             push( @imagelist,
 587                   { KohaImage     => "$imagesubdir/$thisimage",
 588                     StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
 589                     OpacImageUrl  => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
 590                     checked       => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
 591                }
 592              );
 593              $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
 594         }
 595         push @imagesets, { imagesetname => $imagesubdir,
 596                            imagesetactive => $imagesetactive,
 597                            images       => \@imagelist };
 598
 599     }
 600     return \@imagesets;
 601 }
 602
 603 =head2 GetPrinters
 604
 605   $printers = &GetPrinters();
 606   @queues = keys %$printers;
 607
 608 Returns information about existing printer queues.
 609
 610 C<$printers> is a reference-to-hash whose keys are the print queues
 611 defined in the printers table of the Koha database. The values are
 612 references-to-hash, whose keys are the fields in the printers table.
 613
 614 =cut
 615
 616 sub GetPrinters {
 617     my %printers;
 618     my $dbh = C4::Context->dbh;
 619     my $sth = $dbh->prepare("select * from printers");
 620     $sth->execute;
 621     while ( my $printer = $sth->fetchrow_hashref ) {
 622         $printers{ $printer->{'printqueue'} } = $printer;
 623     }
 624     return ( \%printers );
 625 }
 626
 627 =head2 GetPrinter
 628
 629   $printer = GetPrinter( $query, $printers );
 630
 631 =cut
 632
 633 sub GetPrinter ($$) {
 634     my ( $query, $printers ) = @_;    # get printer for this query from printers
 635     my $printer = $query->param('printer');
 636     my %cookie = $query->cookie('userenv');
 637     ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
 638     ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
 639     return $printer;
 640 }
 641
 642 =head2 getnbpages
 643
 644 Returns the number of pages to display in a pagination bar, given the number
 645 of items and the number of items per page.
 646
 647 =cut
 648
 649 sub getnbpages {
 650     my ( $nb_items, $nb_items_per_page ) = @_;
 651
 652     return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
 653 }
 654
 655 =head2 getallthemes
 656
 657   (@themes) = &getallthemes('opac');
 658   (@themes) = &getallthemes('intranet');
 659
 660 Returns an array of all available themes.
 661
 662 =cut
 663
 664 sub getallthemes {
 665     my $type = shift;
 666     my $htdocs;
 667     my @themes;
 668     if ( $type eq 'intranet' ) {
 669         $htdocs = C4::Context->config('intrahtdocs');
 670     }
 671     else {
 672         $htdocs = C4::Context->config('opachtdocs');
 673     }
 674     opendir D, "$htdocs";
 675     my @dirlist = readdir D;
 676     foreach my $directory (@dirlist) {
 677         -d "$htdocs/$directory/en" and push @themes, $directory;
 678     }
 679     return @themes;
 680 }
 681
 682 sub getFacets {
 683     my $facets;
 684     if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
 685         $facets = [
 686             {
 687                 idx   => 'su-to',
 688                 label => 'Topics',
 689                 tags  => [ qw/ 600a 601a 602a 603a 604a 605a 606ax 610a/ ],
 690                 sep   => ' - ',
 691             },
 692             {
 693                 idx   => 'su-geo',
 694                 label => 'Places',
 695                 tags  => [ qw/ 651a / ],
 696                 sep   => ' - ',
 697             },
 698             {
 699                 idx   => 'su-ut',
 700                 label => 'Titles',
 701                 tags  => [ qw/ 500a 501a 502a 503a 504a / ],
 702                 sep   => ', ',
 703             },
 704             {
 705                 idx   => 'au',
 706                 label => 'Authors',
 707                 tags  => [ qw/ 700ab 701ab 702ab / ],
 708                 sep   => ', ',
 709             },
 710             {
 711                 idx   => 'se',
 712                 label => 'Series',
 713                 tags  => [ qw/ 225a / ],
 714                 sep   => ', ',
 715             },
 716         ];
 717         my $library_facet = {
 718             idx   => 'branch',
 719             label => 'Libraries',
 720             tags  => [ qw/ 995b / ],
 721             expanded => '1',
 722         };
 723         push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 724     }
 725     else {
 726         $facets = [
 727             {
 728                 idx   => 'su-to',
 729                 label => 'Topics',
 730                 tags  => [ qw/ 650a / ],
 731                 sep   => '--',
 732             },
 733             #        {
 734             #        idx   => 'su-na',
 735             #        label => 'People and Organizations',
 736             #        tags  => [ qw/ 600a 610a 611a / ],
 737             #        sep   => 'a',
 738             #        },
 739             {
 740                 idx   => 'su-geo',
 741                 label => 'Places',
 742                 tags  => [ qw/ 651a / ],
 743                 sep   => '--',
 744             },
 745             {
 746                 idx   => 'su-ut',
 747                 label => 'Titles',
 748                 tags  => [ qw/ 630a / ],
 749                 sep   => '--',
 750             },
 751             {
 752                 idx   => 'au',
 753                 label => 'Authors',
 754                 tags  => [ qw/ 100a 110a 700a / ],
 755                 sep   => ', ',
 756             },
 757             {
 758                 idx   => 'se',
 759                 label => 'Series',
 760                 tags  => [ qw/ 440a 490a / ],
 761                 sep   => ', ',
 762             },
 763             ];
 764             my $library_facet;
 765             $library_facet = {
 766                 idx   => 'branch',
 767                 label => 'Libraries',
 768                 tags  => [ qw/ 952b / ],
 769                 sep   => ', ',
 770                 expanded    => '1',
 771             };
 772             push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 773     }
 774     return $facets;
 775 }
 776
 777 =head2 get_infos_of
 778
 779 Return a href where a key is associated to a href. You give a query,
 780 the name of the key among the fields returned by the query. If you
 781 also give as third argument the name of the value, the function
 782 returns a href of scalar. The optional 4th argument is an arrayref of
 783 items passed to the C<execute()> call. It is designed to bind
 784 parameters to any placeholders in your SQL.
 785
 786   my $query = '
 787 SELECT itemnumber,
 788        notforloan,
 789        barcode
 790   FROM items
 791 ';
 792
 793   # generic href of any information on the item, href of href.
 794   my $iteminfos_of = get_infos_of($query, 'itemnumber');
 795   print $iteminfos_of->{$itemnumber}{barcode};
 796
 797   # specific information, href of scalar
 798   my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
 799   print $barcode_of_item->{$itemnumber};
 800
 801 =cut
 802
 803 sub get_infos_of {
 804     my ( $query, $key_name, $value_name, $bind_params ) = @_;
 805
 806     my $dbh = C4::Context->dbh;
 807
 808     my $sth = $dbh->prepare($query);
 809     $sth->execute( @$bind_params );
 810
 811     my %infos_of;
 812     while ( my $row = $sth->fetchrow_hashref ) {
 813         if ( defined $value_name ) {
 814             $infos_of{ $row->{$key_name} } = $row->{$value_name};
 815         }
 816         else {
 817             $infos_of{ $row->{$key_name} } = $row;
 818         }
 819     }
 820     $sth->finish;
 821
 822     return \%infos_of;
 823 }
 824
 825 =head2 get_notforloan_label_of
 826
 827   my $notforloan_label_of = get_notforloan_label_of();
 828
 829 Each authorised value of notforloan (information available in items and
 830 itemtypes) is link to a single label.
 831
 832 Returns a href where keys are authorised values and values are corresponding
 833 labels.
 834
 835   foreach my $authorised_value (keys %{$notforloan_label_of}) {
 836     printf(
 837         "authorised_value: %s => %s\n",
 838         $authorised_value,
 839         $notforloan_label_of->{$authorised_value}
 840     );
 841   }
 842
 843 =cut
 844
 845 # FIXME - why not use GetAuthorisedValues ??
 846 #
 847 sub get_notforloan_label_of {
 848     my $dbh = C4::Context->dbh;
 849
 850     my $query = '
 851 SELECT authorised_value
 852   FROM marc_subfield_structure
 853   WHERE kohafield = \'items.notforloan\'
 854   LIMIT 0, 1
 855 ';
 856     my $sth = $dbh->prepare($query);
 857     $sth->execute();
 858     my ($statuscode) = $sth->fetchrow_array();
 859
 860     $query = '
 861 SELECT lib,
 862        authorised_value
 863   FROM authorised_values
 864   WHERE category = ?
 865 ';
 866     $sth = $dbh->prepare($query);
 867     $sth->execute($statuscode);
 868     my %notforloan_label_of;
 869     while ( my $row = $sth->fetchrow_hashref ) {
 870         $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
 871     }
 872     $sth->finish;
 873
 874     return \%notforloan_label_of;
 875 }
 876
 877 =head2 displayServers
 878
 879    my $servers = displayServers();
 880    my $servers = displayServers( $position );
 881    my $servers = displayServers( $position, $type );
 882
 883 displayServers returns a listref of hashrefs, each containing
 884 information about available z3950 servers. Each hashref has a format
 885 like:
 886
 887     {
 888       'checked'    => 'checked',
 889       'encoding'   => 'MARC-8'
 890       'icon'       => undef,
 891       'id'         => 'LIBRARY OF CONGRESS',
 892       'label'      => '',
 893       'name'       => 'server',
 894       'opensearch' => '',
 895       'value'      => 'z3950.loc.gov:7090/',
 896       'zed'        => 1,
 897     },
 898
 899 =cut
 900
 901 sub displayServers {
 902     my ( $position, $type ) = @_;
 903     my $dbh = C4::Context->dbh;
 904
 905     my $strsth = 'SELECT * FROM z3950servers';
 906     my @where_clauses;
 907     my @bind_params;
 908
 909     if ($position) {
 910         push @bind_params,   $position;
 911         push @where_clauses, ' position = ? ';
 912     }
 913
 914     if ($type) {
 915         push @bind_params,   $type;
 916         push @where_clauses, ' type = ? ';
 917     }
 918
 919     # reassemble where clause from where clause pieces
 920     if (@where_clauses) {
 921         $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
 922     }
 923
 924     my $rq = $dbh->prepare($strsth);
 925     $rq->execute(@bind_params);
 926     my @primaryserverloop;
 927
 928     while ( my $data = $rq->fetchrow_hashref ) {
 929         push @primaryserverloop,
 930           { label    => $data->{description},
 931             id       => $data->{name},
 932             name     => "server",
 933             value    => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
 934             encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
 935             checked  => "checked",
 936             icon     => $data->{icon},
 937             zed        => $data->{type} eq 'zed',
 938             opensearch => $data->{type} eq 'opensearch'
 939           };
 940     }
 941     return \@primaryserverloop;
 942 }
 943
 944
 945 =head2 GetKohaImageurlFromAuthorisedValues
 946
 947 $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode );
 948
 949 Return the first url of the authorised value image represented by $lib.
 950
 951 =cut
 952
 953 sub GetKohaImageurlFromAuthorisedValues {
 954     my ( $category, $lib ) = @_;
 955     my $dbh = C4::Context->dbh;
 956     my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?");
 957     $sth->execute( $category, $lib );
 958     while ( my $data = $sth->fetchrow_hashref ) {
 959         return $data->{'imageurl'};
 960     }
 961 }
 962
 963 =head2 GetAuthValCode
 964
 965   $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
 966
 967 =cut
 968
 969 sub GetAuthValCode {
 970         my ($kohafield,$fwcode) = @_;
 971         my $dbh = C4::Context->dbh;
 972         $fwcode='' unless $fwcode;
 973         my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
 974         $sth->execute($kohafield,$fwcode);
 975         my ($authvalcode) = $sth->fetchrow_array;
 976         return $authvalcode;
 977 }
 978
 979 =head2 GetAuthValCodeFromField
 980
 981   $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
 982
 983 C<$subfield> can be undefined
 984
 985 =cut
 986
 987 sub GetAuthValCodeFromField {
 988         my ($field,$subfield,$fwcode) = @_;
 989         my $dbh = C4::Context->dbh;
 990         $fwcode='' unless $fwcode;
 991         my $sth;
 992         if (defined $subfield) {
 993             $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
 994             $sth->execute($field,$subfield,$fwcode);
 995         } else {
 996             $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
 997             $sth->execute($field,$fwcode);
 998         }
 999         my ($authvalcode) = $sth->fetchrow_array;
1000         return $authvalcode;
1001 }
1002
1003 =head2 GetAuthorisedValues
1004
1005   $authvalues = GetAuthorisedValues([$category], [$selected]);
1006
1007 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1008
1009 C<$category> returns authorised values for just one category (optional).
1010
1011 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1012
1013 =cut
1014
1015 sub GetAuthorisedValues {
1016     my ($category,$selected,$opac) = @_;
1017     my @results;
1018     my $dbh      = C4::Context->dbh;
1019     my $query    = "SELECT * FROM authorised_values";
1020     $query .= " WHERE category = '" . $category . "'" if $category;
1021     $query .= " ORDER BY category, lib, lib_opac";
1022     my $sth = $dbh->prepare($query);
1023     $sth->execute;
1024     while (my $data=$sth->fetchrow_hashref) {
1025         if ( (defined($selected)) && ($selected eq $data->{'authorised_value'}) ) {
1026             $data->{'selected'} = 1;
1027         }
1028         else {
1029             $data->{'selected'} = 0;
1030         }
1031         if ($opac && $data->{'lib_opac'}) {
1032             $data->{'lib'} = $data->{'lib_opac'};
1033         }
1034         push @results, $data;
1035     }
1036     #my $data = $sth->fetchall_arrayref({});
1037     return \@results; #$data;
1038 }
1039
1040 =head2 GetAuthorisedValueCategories
1041
1042   $auth_categories = GetAuthorisedValueCategories();
1043
1044 Return an arrayref of all of the available authorised
1045 value categories.
1046
1047 =cut
1048
1049 sub GetAuthorisedValueCategories {
1050     my $dbh = C4::Context->dbh;
1051     my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1052     $sth->execute;
1053     my @results;
1054     while (defined (my $category  = $sth->fetchrow_array) ) {
1055         push @results, $category;
1056     }
1057     return \@results;
1058 }
1059
1060 =head2 GetAuthorisedValueByCode
1061
1062 $authhorised_value = GetAuthorisedValueByCode( $category, $authvalcode );
1063
1064 Return the lib attribute from authorised_values from the row identified
1065 by the passed category and code
1066
1067 =cut
1068
1069 sub GetAuthorisedValueByCode {
1070     my ( $category, $authvalcode ) = @_;
1071
1072     my $dbh = C4::Context->dbh;
1073     my $sth = $dbh->prepare("SELECT lib FROM authorised_values WHERE category=? AND authorised_value =?");
1074     $sth->execute( $category, $authvalcode );
1075     while ( my $data = $sth->fetchrow_hashref ) {
1076         return $data->{'lib'};
1077     }
1078 }
1079
1080 =head2 GetKohaAuthorisedValues
1081
1082 Takes $kohafield, $fwcode as parameters.
1083
1084 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1085
1086 Returns hashref of Code => description
1087
1088 Returns undef if no authorised value category is defined for the kohafield.
1089
1090 =cut
1091
1092 sub GetKohaAuthorisedValues {
1093   my ($kohafield,$fwcode,$opac) = @_;
1094   $fwcode='' unless $fwcode;
1095   my %values;
1096   my $dbh = C4::Context->dbh;
1097   my $avcode = GetAuthValCode($kohafield,$fwcode);
1098   if ($avcode) {
1099         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1100         $sth->execute($avcode);
1101         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1102                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1103         }
1104         return \%values;
1105   } else {
1106         return undef;
1107   }
1108 }
1109
1110 =head2 GetKohaAuthorisedValuesFromField
1111
1112 Takes $field, $subfield, $fwcode as parameters.
1113
1114 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1115 $subfield can be undefined
1116
1117 Returns hashref of Code => description
1118
1119 Returns undef if no authorised value category is defined for the given field and subfield
1120
1121 =cut
1122
1123 sub GetKohaAuthorisedValuesFromField {
1124   my ($field, $subfield, $fwcode,$opac) = @_;
1125   $fwcode='' unless $fwcode;
1126   my %values;
1127   my $dbh = C4::Context->dbh;
1128   my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1129   if ($avcode) {
1130         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1131         $sth->execute($avcode);
1132         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1133                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1134         }
1135         return \%values;
1136   } else {
1137         return undef;
1138   }
1139 }
1140
1141 =head2 xml_escape
1142
1143   my $escaped_string = C4::Koha::xml_escape($string);
1144
1145 Convert &, <, >, ', and " in a string to XML entities
1146
1147 =cut
1148
1149 sub xml_escape {
1150     my $str = shift;
1151     return '' unless defined $str;
1152     $str =~ s/&/&amp;/g;
1153     $str =~ s/</&lt;/g;
1154     $str =~ s/>/&gt;/g;
1155     $str =~ s/'/&apos;/g;
1156     $str =~ s/"/&quot;/g;
1157     return $str;
1158 }
1159
1160 =head2 GetKohaAuthorisedValueLib
1161
1162 Takes $category, $authorised_value as parameters.
1163
1164 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1165
1166 Returns authorised value description
1167
1168 =cut
1169
1170 sub GetKohaAuthorisedValueLib {
1171   my ($category,$authorised_value,$opac) = @_;
1172   my $value;
1173   my $dbh = C4::Context->dbh;
1174   my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1175   $sth->execute($category,$authorised_value);
1176   my $data = $sth->fetchrow_hashref;
1177   $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1178   return $value;
1179 }
1180
1181 =head2 display_marc_indicators
1182
1183   my $display_form = C4::Koha::display_marc_indicators($field);
1184
1185 C<$field> is a MARC::Field object
1186
1187 Generate a display form of the indicators of a variable
1188 MARC field, replacing any blanks with '#'.
1189
1190 =cut
1191
1192 sub display_marc_indicators {
1193     my $field = shift;
1194     my $indicators = '';
1195     if ($field->tag() >= 10) {
1196         $indicators = $field->indicator(1) . $field->indicator(2);
1197         $indicators =~ s/ /#/g;
1198     }
1199     return $indicators;
1200 }
1201
1202 sub GetNormalizedUPC {
1203  my ($record,$marcflavour) = @_;
1204     my (@fields,$upc);
1205
1206     if ($marcflavour eq 'UNIMARC') {
1207         @fields = $record->field('072');
1208         foreach my $field (@fields) {
1209             my $upc = _normalize_match_point($field->subfield('a'));
1210             if ($upc ne '') {
1211                 return $upc;
1212             }
1213         }
1214
1215     }
1216     else { # assume marc21 if not unimarc
1217         @fields = $record->field('024');
1218         foreach my $field (@fields) {
1219             my $indicator = $field->indicator(1);
1220             my $upc = _normalize_match_point($field->subfield('a'));
1221             if ($indicator == 1 and $upc ne '') {
1222                 return $upc;
1223             }
1224         }
1225     }
1226 }
1227
1228 # Normalizes and returns the first valid ISBN found in the record
1229 # ISBN13 are converted into ISBN10. This is required to get Amazon cover book.
1230 sub GetNormalizedISBN {
1231     my ($isbn,$record,$marcflavour) = @_;
1232     my @fields;
1233     if ($isbn) {
1234         # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1235         # anything after " | " should be removed, along with the delimiter
1236         $isbn =~ s/(.*)( \| )(.*)/$1/;
1237         return _isbn_cleanup($isbn);
1238     }
1239     return undef unless $record;
1240
1241     if ($marcflavour eq 'UNIMARC') {
1242         @fields = $record->field('010');
1243         foreach my $field (@fields) {
1244             my $isbn = $field->subfield('a');
1245             if ($isbn) {
1246                 return _isbn_cleanup($isbn);
1247             } else {
1248                 return undef;
1249             }
1250         }
1251     }
1252     else { # assume marc21 if not unimarc
1253         @fields = $record->field('020');
1254         foreach my $field (@fields) {
1255             $isbn = $field->subfield('a');
1256             if ($isbn) {
1257                 return _isbn_cleanup($isbn);
1258             } else {
1259                 return undef;
1260             }
1261         }
1262     }
1263 }
1264
1265 sub GetNormalizedEAN {
1266     my ($record,$marcflavour) = @_;
1267     my (@fields,$ean);
1268
1269     if ($marcflavour eq 'UNIMARC') {
1270         @fields = $record->field('073');
1271         foreach my $field (@fields) {
1272             $ean = _normalize_match_point($field->subfield('a'));
1273             if ($ean ne '') {
1274                 return $ean;
1275             }
1276         }
1277     }
1278     else { # assume marc21 if not unimarc
1279         @fields = $record->field('024');
1280         foreach my $field (@fields) {
1281             my $indicator = $field->indicator(1);
1282             $ean = _normalize_match_point($field->subfield('a'));
1283             if ($indicator == 3 and $ean ne '') {
1284                 return $ean;
1285             }
1286         }
1287     }
1288 }
1289 sub GetNormalizedOCLCNumber {
1290     my ($record,$marcflavour) = @_;
1291     my (@fields,$oclc);
1292
1293     if ($marcflavour eq 'UNIMARC') {
1294         # TODO: add UNIMARC fields
1295     }
1296     else { # assume marc21 if not unimarc
1297         @fields = $record->field('035');
1298         foreach my $field (@fields) {
1299             $oclc = $field->subfield('a');
1300             if ($oclc =~ /OCoLC/) {
1301                 $oclc =~ s/\(OCoLC\)//;
1302                 return $oclc;
1303             } else {
1304                 return undef;
1305             }
1306         }
1307     }
1308 }
1309
1310 =head2 GetDailyQuote($opts)
1311
1312 Takes a hashref of options
1313
1314 Currently supported options are:
1315
1316 'id'        An exact quote id
1317 'random'    Select a random quote
1318 noop        When no option is passed in, this sub will return the quote timestamped for the current day
1319
1320 The function returns an anonymous hash following this format:
1321
1322         {
1323           'source' => 'source-of-quote',
1324           'timestamp' => 'timestamp-value',
1325           'text' => 'text-of-quote',
1326           'id' => 'quote-id'
1327         };
1328
1329 =cut
1330
1331 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1332 # at least for default option
1333
1334 sub GetDailyQuote {
1335     my %opts = @_;
1336     my $dbh = C4::Context->dbh;
1337     my $query = '';
1338     my $sth = undef;
1339     my $quote = undef;
1340     if ($opts{'id'}) {
1341         $query = 'SELECT * FROM quotes WHERE id = ?';
1342         $sth = $dbh->prepare($query);
1343         $sth->execute($opts{'id'});
1344         $quote = $sth->fetchrow_hashref();
1345     }
1346     elsif ($opts{'random'}) {
1347         # Fall through... we also return a random quote as a catch-all if all else fails
1348     }
1349     else {
1350         $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1351         $sth = $dbh->prepare($query);
1352         $sth->execute();
1353         $quote = $sth->fetchrow_hashref();
1354     }
1355     unless ($quote) {        # if there are not matches, choose a random quote
1356         # get a list of all available quote ids
1357         $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1358         $sth->execute;
1359         my $range = ($sth->fetchrow_array)[0];
1360         if ($range > 1) {
1361             # chose a random id within that range if there is more than one quote
1362             my $id = int(rand($range));
1363             # grab it
1364             $query = 'SELECT * FROM quotes WHERE id = ?;';
1365             $sth = C4::Context->dbh->prepare($query);
1366             $sth->execute($id);
1367         }
1368         else {
1369             $query = 'SELECT * FROM quotes;';
1370             $sth = C4::Context->dbh->prepare($query);
1371             $sth->execute();
1372         }
1373         $quote = $sth->fetchrow_hashref();
1374         # update the timestamp for that quote
1375         $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1376         $sth = C4::Context->dbh->prepare($query);
1377         $sth->execute(DateTime::Format::MySQL->format_datetime(DateTime->now), $quote->{'id'});
1378     }
1379     return $quote;
1380 }
1381
1382 sub _normalize_match_point {
1383     my $match_point = shift;
1384     (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1385     $normalized_match_point =~ s/-//g;
1386
1387     return $normalized_match_point;
1388 }
1389
1390 sub _isbn_cleanup {
1391     require Business::ISBN;
1392     my $isbn = Business::ISBN->new( $_[0] );
1393     if ( $isbn ) {
1394         $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13';
1395         if (defined $isbn) {
1396             return $isbn->as_string([]);
1397         }
1398     }
1399     return;
1400 }
1401
1402 1;
1403
1404 __END__
1405
1406 =head1 AUTHOR
1407
1408 Koha Team
1409
1410 =cut