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 use C4::Branch qw(GetBranchesCount);
  28 use Koha::Cache;
  29 use Koha::DateUtils qw(dt_from_string);
  30 use DateTime::Format::MySQL;
  31 use Business::ISBN;
  32 use autouse 'Data::Dumper' => qw(Dumper);
  33 use DBI qw(:sql_types);
  34
  35 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $DEBUG);
  36
  37 BEGIN {
  38     $VERSION = 3.07.00.049;
  39         require Exporter;
  40         @ISA    = qw(Exporter);
  41         @EXPORT = qw(
  42                 &slashifyDate
  43                 &subfield_is_koha_internal_p
  44                 &GetPrinters &GetPrinter
  45                 &GetItemTypes &getitemtypeinfo
  46                 &GetSupportName &GetSupportList
  47                 &get_itemtypeinfos_of
  48                 &getframeworks &getframeworkinfo
  49         &GetFrameworksLoop
  50                 &getauthtypes &getauthtype
  51                 &getallthemes
  52                 &getFacets
  53                 &displayServers
  54                 &getnbpages
  55                 &get_infos_of
  56                 &get_notforloan_label_of
  57                 &getitemtypeimagedir
  58                 &getitemtypeimagesrc
  59                 &getitemtypeimagelocation
  60                 &GetAuthorisedValues
  61                 &GetAuthorisedValueCategories
  62                 &IsAuthorisedValueCategory
  63                 &GetKohaAuthorisedValues
  64                 &GetKohaAuthorisedValuesFromField
  65     &GetKohaAuthorisedValueLib
  66     &GetAuthorisedValueByCode
  67     &GetKohaImageurlFromAuthorisedValues
  68                 &GetAuthValCode
  69         &AddAuthorisedValue
  70                 &GetNormalizedUPC
  71                 &GetNormalizedISBN
  72                 &GetNormalizedEAN
  73                 &GetNormalizedOCLCNumber
  74         &xml_escape
  75
  76         &GetVariationsOfISBN
  77         &GetVariationsOfISBNs
  78         &NormalizeISBN
  79
  80                 $DEBUG
  81         );
  82         $DEBUG = 0;
  83 @EXPORT_OK = qw( GetDailyQuote );
  84 }
  85
  86 =head1 NAME
  87
  88 C4::Koha - Perl Module containing convenience functions for Koha scripts
  89
  90 =head1 SYNOPSIS
  91
  92 use C4::Koha;
  93
  94 =head1 DESCRIPTION
  95
  96 Koha.pm provides many functions for Koha scripts.
  97
  98 =head1 FUNCTIONS
  99
 100 =cut
 101
 102 =head2 slashifyDate
 103
 104   $slash_date = &slashifyDate($dash_date);
 105
 106 Takes a string of the form "DD-MM-YYYY" (or anything separated by
 107 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
 108
 109 =cut
 110
 111 sub slashifyDate {
 112
 113     # accepts a date of the form xx-xx-xx[xx] and returns it in the
 114     # form xx/xx/xx[xx]
 115     my @dateOut = split( '-', shift );
 116     return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
 117 }
 118
 119 # FIXME.. this should be moved to a MARC-specific module
 120 sub subfield_is_koha_internal_p {
 121     my ($subfield) = @_;
 122
 123     # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
 124     # But real MARC subfields are always single-character
 125     # so it really is safer just to check the length
 126
 127     return length $subfield != 1;
 128 }
 129
 130 =head2 GetSupportName
 131
 132   $itemtypename = &GetSupportName($codestring);
 133
 134 Returns a string with the name of the itemtype.
 135
 136 =cut
 137
 138 sub GetSupportName{
 139         my ($codestring)=@_;
 140         return if (! $codestring);
 141         my $resultstring;
 142         my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
 143         if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') {
 144                 my $query = qq|
 145                         SELECT description
 146                         FROM   itemtypes
 147                         WHERE itemtype=?
 148                         order by description
 149                 |;
 150                 my $sth = C4::Context->dbh->prepare($query);
 151                 $sth->execute($codestring);
 152                 ($resultstring)=$sth->fetchrow;
 153                 return $resultstring;
 154         } else {
 155         my $sth =
 156             C4::Context->dbh->prepare(
 157                     "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?"
 158                     );
 159         $sth->execute( $advanced_search_types, $codestring );
 160         my $data = $sth->fetchrow_hashref;
 161         return $$data{'lib'};
 162         }
 163
 164 }
 165 =head2 GetSupportList
 166
 167   $itemtypes = &GetSupportList();
 168
 169 Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
 170
 171 build a HTML select with the following code :
 172
 173 =head3 in PERL SCRIPT
 174
 175     my $itemtypes = GetSupportList();
 176     $template->param(itemtypeloop => $itemtypes);
 177
 178 =head3 in TEMPLATE
 179
 180     <select name="itemtype" id="itemtype">
 181         <option value=""></option>
 182         [% FOREACH itemtypeloo IN itemtypeloop %]
 183              [% IF ( itemtypeloo.selected ) %]
 184                 <option value="[% itemtypeloo.itemtype %]" selected="selected">[% itemtypeloo.description %]</option>
 185             [% ELSE %]
 186                 <option value="[% itemtypeloo.itemtype %]">[% itemtypeloo.description %]</option>
 187             [% END %]
 188        [% END %]
 189     </select>
 190
 191 =cut
 192
 193 sub GetSupportList{
 194         my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes");
 195     if (!$advanced_search_types or $advanced_search_types =~ /itemtypes/) {
 196                 my $query = qq|
 197                         SELECT *
 198                         FROM   itemtypes
 199                         order by description
 200                 |;
 201                 my $sth = C4::Context->dbh->prepare($query);
 202                 $sth->execute;
 203                 return $sth->fetchall_arrayref({});
 204         } else {
 205                 my $advsearchtypes = GetAuthorisedValues($advanced_search_types);
 206                 my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes;
 207                 return \@results;
 208         }
 209 }
 210 =head2 GetItemTypes
 211
 212   $itemtypes = &GetItemTypes( style => $style );
 213
 214 Returns information about existing itemtypes.
 215
 216 Params:
 217     style: either 'array' or 'hash', defaults to 'hash'.
 218            'array' returns an arrayref,
 219            'hash' return a hashref with the itemtype value as the key
 220
 221 build a HTML select with the following code :
 222
 223 =head3 in PERL SCRIPT
 224
 225     my $itemtypes = GetItemTypes;
 226     my @itemtypesloop;
 227     foreach my $thisitemtype (sort keys %$itemtypes) {
 228         my $selected = 1 if $thisitemtype eq $itemtype;
 229         my %row =(value => $thisitemtype,
 230                     selected => $selected,
 231                     description => $itemtypes->{$thisitemtype}->{'description'},
 232                 );
 233         push @itemtypesloop, \%row;
 234     }
 235     $template->param(itemtypeloop => \@itemtypesloop);
 236
 237 =head3 in TEMPLATE
 238
 239     <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 240         <select name="itemtype">
 241             <option value="">Default</option>
 242         <!-- TMPL_LOOP name="itemtypeloop" -->
 243             <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
 244         <!-- /TMPL_LOOP -->
 245         </select>
 246         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 247         <input type="submit" value="OK" class="button">
 248     </form>
 249
 250 =cut
 251
 252 sub GetItemTypes {
 253     my ( %params ) = @_;
 254     my $style = defined( $params{'style'} ) ? $params{'style'} : 'hash';
 255
 256     # returns a reference to a hash of references to itemtypes...
 257     my %itemtypes;
 258     my $dbh   = C4::Context->dbh;
 259     my $query = qq|
 260         SELECT *
 261         FROM   itemtypes
 262     |;
 263     my $sth = $dbh->prepare($query);
 264     $sth->execute;
 265
 266     if ( $style eq 'hash' ) {
 267         while ( my $IT = $sth->fetchrow_hashref ) {
 268             $itemtypes{ $IT->{'itemtype'} } = $IT;
 269         }
 270         return ( \%itemtypes );
 271     } else {
 272         return $sth->fetchall_arrayref({});
 273     }
 274 }
 275
 276 sub get_itemtypeinfos_of {
 277     my @itemtypes = @_;
 278
 279     my $placeholders = join( ', ', map { '?' } @itemtypes );
 280     my $query = <<"END_SQL";
 281 SELECT itemtype,
 282        description,
 283        imageurl,
 284        notforloan
 285   FROM itemtypes
 286   WHERE itemtype IN ( $placeholders )
 287 END_SQL
 288
 289     return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
 290 }
 291
 292 =head2 getauthtypes
 293
 294   $authtypes = &getauthtypes();
 295
 296 Returns information about existing authtypes.
 297
 298 build a HTML select with the following code :
 299
 300 =head3 in PERL SCRIPT
 301
 302    my $authtypes = getauthtypes;
 303    my @authtypesloop;
 304    foreach my $thisauthtype (keys %$authtypes) {
 305        my $selected = 1 if $thisauthtype eq $authtype;
 306        my %row =(value => $thisauthtype,
 307                 selected => $selected,
 308                 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
 309             );
 310         push @authtypesloop, \%row;
 311     }
 312     $template->param(itemtypeloop => \@itemtypesloop);
 313
 314 =head3 in TEMPLATE
 315
 316   <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 317     <select name="authtype">
 318     <!-- TMPL_LOOP name="authtypeloop" -->
 319         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
 320     <!-- /TMPL_LOOP -->
 321     </select>
 322     <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 323     <input type="submit" value="OK" class="button">
 324   </form>
 325
 326
 327 =cut
 328
 329 sub getauthtypes {
 330
 331     # returns a reference to a hash of references to authtypes...
 332     my %authtypes;
 333     my $dbh = C4::Context->dbh;
 334     my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
 335     $sth->execute;
 336     while ( my $IT = $sth->fetchrow_hashref ) {
 337         $authtypes{ $IT->{'authtypecode'} } = $IT;
 338     }
 339     return ( \%authtypes );
 340 }
 341
 342 sub getauthtype {
 343     my ($authtypecode) = @_;
 344
 345     # returns a reference to a hash of references to authtypes...
 346     my %authtypes;
 347     my $dbh = C4::Context->dbh;
 348     my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
 349     $sth->execute($authtypecode);
 350     my $res = $sth->fetchrow_hashref;
 351     return $res;
 352 }
 353
 354 =head2 getframework
 355
 356   $frameworks = &getframework();
 357
 358 Returns information about existing frameworks
 359
 360 build a HTML select with the following code :
 361
 362 =head3 in PERL SCRIPT
 363
 364   my $frameworks = getframeworks();
 365   my @frameworkloop;
 366   foreach my $thisframework (keys %$frameworks) {
 367     my $selected = 1 if $thisframework eq $frameworkcode;
 368     my %row =(
 369                 value       => $thisframework,
 370                 selected    => $selected,
 371                 description => $frameworks->{$thisframework}->{'frameworktext'},
 372             );
 373     push @frameworksloop, \%row;
 374   }
 375   $template->param(frameworkloop => \@frameworksloop);
 376
 377 =head3 in TEMPLATE
 378
 379   <form action="[% script_name %] method=post>
 380     <select name="frameworkcode">
 381         <option value="">Default</option>
 382         [% FOREACH framework IN frameworkloop %]
 383         [% IF ( framework.selected ) %]
 384         <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
 385         [% ELSE %]
 386         <option value="[% framework.value %]">[% framework.description %]</option>
 387         [% END %]
 388         [% END %]
 389     </select>
 390     <input type=text name=searchfield value="[% searchfield %]">
 391     <input type="submit" value="OK" class="button">
 392   </form>
 393
 394 =cut
 395
 396 sub getframeworks {
 397
 398     # returns a reference to a hash of references to branches...
 399     my %itemtypes;
 400     my $dbh = C4::Context->dbh;
 401     my $sth = $dbh->prepare("select * from biblio_framework");
 402     $sth->execute;
 403     while ( my $IT = $sth->fetchrow_hashref ) {
 404         $itemtypes{ $IT->{'frameworkcode'} } = $IT;
 405     }
 406     return ( \%itemtypes );
 407 }
 408
 409 =head2 GetFrameworksLoop
 410
 411   $frameworks = GetFrameworksLoop( $frameworkcode );
 412
 413 Returns the loop suggested on getframework(), but ordered by framework description.
 414
 415 build a HTML select with the following code :
 416
 417 =head3 in PERL SCRIPT
 418
 419   $template->param( frameworkloop => GetFrameworksLoop( $frameworkcode ) );
 420
 421 =head3 in TEMPLATE
 422
 423   Same as getframework()
 424
 425   <form action="[% script_name %] method=post>
 426     <select name="frameworkcode">
 427         <option value="">Default</option>
 428         [% FOREACH framework IN frameworkloop %]
 429         [% IF ( framework.selected ) %]
 430         <option value="[% framework.value %]" selected="selected">[% framework.description %]</option>
 431         [% ELSE %]
 432         <option value="[% framework.value %]">[% framework.description %]</option>
 433         [% END %]
 434         [% END %]
 435     </select>
 436     <input type=text name=searchfield value="[% searchfield %]">
 437     <input type="submit" value="OK" class="button">
 438   </form>
 439
 440 =cut
 441
 442 sub GetFrameworksLoop {
 443     my $frameworkcode = shift;
 444     my $frameworks = getframeworks();
 445     my @frameworkloop;
 446     foreach my $thisframework (sort { uc($frameworks->{$a}->{'frameworktext'}) cmp uc($frameworks->{$b}->{'frameworktext'}) } keys %$frameworks) {
 447         my $selected = ( $thisframework eq $frameworkcode ) ? 1 : undef;
 448         my %row = (
 449                 value       => $thisframework,
 450                 selected    => $selected,
 451                 description => $frameworks->{$thisframework}->{'frameworktext'},
 452             );
 453         push @frameworkloop, \%row;
 454   }
 455   return \@frameworkloop;
 456 }
 457
 458 =head2 getframeworkinfo
 459
 460   $frameworkinfo = &getframeworkinfo($frameworkcode);
 461
 462 Returns information about an frameworkcode.
 463
 464 =cut
 465
 466 sub getframeworkinfo {
 467     my ($frameworkcode) = @_;
 468     my $dbh             = C4::Context->dbh;
 469     my $sth             =
 470       $dbh->prepare("select * from biblio_framework where frameworkcode=?");
 471     $sth->execute($frameworkcode);
 472     my $res = $sth->fetchrow_hashref;
 473     return $res;
 474 }
 475
 476 =head2 getitemtypeinfo
 477
 478   $itemtype = &getitemtypeinfo($itemtype, [$interface]);
 479
 480 Returns information about an itemtype. The optional $interface argument
 481 sets which interface ('opac' or 'intranet') to return the imageurl for.
 482 Defaults to intranet.
 483
 484 =cut
 485
 486 sub getitemtypeinfo {
 487     my ($itemtype, $interface) = @_;
 488     my $dbh        = C4::Context->dbh;
 489     my $sth        = $dbh->prepare("select * from itemtypes where itemtype=?");
 490     $sth->execute($itemtype);
 491     my $res = $sth->fetchrow_hashref;
 492
 493     $res->{imageurl} = getitemtypeimagelocation( ( ( defined $interface && $interface eq 'opac' ) ? 'opac' : 'intranet' ), $res->{imageurl} );
 494
 495     return $res;
 496 }
 497
 498 =head2 getitemtypeimagedir
 499
 500   my $directory = getitemtypeimagedir( 'opac' );
 501
 502 pass in 'opac' or 'intranet'. Defaults to 'opac'.
 503
 504 returns the full path to the appropriate directory containing images.
 505
 506 =cut
 507
 508 sub getitemtypeimagedir {
 509         my $src = shift || 'opac';
 510         if ($src eq 'intranet') {
 511                 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
 512         } else {
 513                 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
 514         }
 515 }
 516
 517 sub getitemtypeimagesrc {
 518         my $src = shift || 'opac';
 519         if ($src eq 'intranet') {
 520                 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
 521         } else {
 522                 return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg';
 523         }
 524 }
 525
 526 sub getitemtypeimagelocation {
 527         my ( $src, $image ) = @_;
 528
 529         return '' if ( !$image );
 530     require URI::Split;
 531
 532         my $scheme = ( URI::Split::uri_split( $image ) )[0];
 533
 534         return $image if ( $scheme );
 535
 536         return getitemtypeimagesrc( $src ) . '/' . $image;
 537 }
 538
 539 =head3 _getImagesFromDirectory
 540
 541 Find all of the image files in a directory in the filesystem
 542
 543 parameters: a directory name
 544
 545 returns: a list of images in that directory.
 546
 547 Notes: this does not traverse into subdirectories. See
 548 _getSubdirectoryNames for help with that.
 549 Images are assumed to be files with .gif or .png file extensions.
 550 The image names returned do not have the directory name on them.
 551
 552 =cut
 553
 554 sub _getImagesFromDirectory {
 555     my $directoryname = shift;
 556     return unless defined $directoryname;
 557     return unless -d $directoryname;
 558
 559     if ( opendir ( my $dh, $directoryname ) ) {
 560         my @images = grep { /\.(gif|png)$/i } readdir( $dh );
 561         closedir $dh;
 562         @images = sort(@images);
 563         return @images;
 564     } else {
 565         warn "unable to opendir $directoryname: $!";
 566         return;
 567     }
 568 }
 569
 570 =head3 _getSubdirectoryNames
 571
 572 Find all of the directories in a directory in the filesystem
 573
 574 parameters: a directory name
 575
 576 returns: a list of subdirectories in that directory.
 577
 578 Notes: this does not traverse into subdirectories. Only the first
 579 level of subdirectories are returned.
 580 The directory names returned don't have the parent directory name on them.
 581
 582 =cut
 583
 584 sub _getSubdirectoryNames {
 585     my $directoryname = shift;
 586     return unless defined $directoryname;
 587     return unless -d $directoryname;
 588
 589     if ( opendir ( my $dh, $directoryname ) ) {
 590         my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
 591         closedir $dh;
 592         return @directories;
 593     } else {
 594         warn "unable to opendir $directoryname: $!";
 595         return;
 596     }
 597 }
 598
 599 =head3 getImageSets
 600
 601 returns: a listref of hashrefs. Each hash represents another collection of images.
 602
 603  { imagesetname => 'npl', # the name of the image set (npl is the original one)
 604          images => listref of image hashrefs
 605  }
 606
 607 each image is represented by a hashref like this:
 608
 609  { KohaImage     => 'npl/image.gif',
 610    StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
 611    OpacImageURL  => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
 612    checked       => 0 or 1: was this the image passed to this method?
 613                     Note: I'd like to remove this somehow.
 614  }
 615
 616 =cut
 617
 618 sub getImageSets {
 619     my %params = @_;
 620     my $checked = $params{'checked'} || '';
 621
 622     my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
 623                              url        => getitemtypeimagesrc('intranet'),
 624                         },
 625                   opac => { filesystem => getitemtypeimagedir('opac'),
 626                              url       => getitemtypeimagesrc('opac'),
 627                         }
 628                   };
 629
 630     my @imagesets = (); # list of hasrefs of image set data to pass to template
 631     my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
 632     foreach my $imagesubdir ( @subdirectories ) {
 633     warn $imagesubdir if $DEBUG;
 634         my @imagelist     = (); # hashrefs of image info
 635         my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
 636         my $imagesetactive = 0;
 637         foreach my $thisimage ( @imagenames ) {
 638             push( @imagelist,
 639                   { KohaImage     => "$imagesubdir/$thisimage",
 640                     StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
 641                     OpacImageUrl  => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
 642                     checked       => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
 643                }
 644              );
 645              $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked;
 646         }
 647         push @imagesets, { imagesetname => $imagesubdir,
 648                            imagesetactive => $imagesetactive,
 649                            images       => \@imagelist };
 650
 651     }
 652     return \@imagesets;
 653 }
 654
 655 =head2 GetPrinters
 656
 657   $printers = &GetPrinters();
 658   @queues = keys %$printers;
 659
 660 Returns information about existing printer queues.
 661
 662 C<$printers> is a reference-to-hash whose keys are the print queues
 663 defined in the printers table of the Koha database. The values are
 664 references-to-hash, whose keys are the fields in the printers table.
 665
 666 =cut
 667
 668 sub GetPrinters {
 669     my %printers;
 670     my $dbh = C4::Context->dbh;
 671     my $sth = $dbh->prepare("select * from printers");
 672     $sth->execute;
 673     while ( my $printer = $sth->fetchrow_hashref ) {
 674         $printers{ $printer->{'printqueue'} } = $printer;
 675     }
 676     return ( \%printers );
 677 }
 678
 679 =head2 GetPrinter
 680
 681   $printer = GetPrinter( $query, $printers );
 682
 683 =cut
 684
 685 sub GetPrinter {
 686     my ( $query, $printers ) = @_;    # get printer for this query from printers
 687     my $printer = $query->param('printer');
 688     my %cookie = $query->cookie('userenv');
 689     ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
 690     ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
 691     return $printer;
 692 }
 693
 694 =head2 getnbpages
 695
 696 Returns the number of pages to display in a pagination bar, given the number
 697 of items and the number of items per page.
 698
 699 =cut
 700
 701 sub getnbpages {
 702     my ( $nb_items, $nb_items_per_page ) = @_;
 703
 704     return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
 705 }
 706
 707 =head2 getallthemes
 708
 709   (@themes) = &getallthemes('opac');
 710   (@themes) = &getallthemes('intranet');
 711
 712 Returns an array of all available themes.
 713
 714 =cut
 715
 716 sub getallthemes {
 717     my $type = shift;
 718     my $htdocs;
 719     my @themes;
 720     if ( $type eq 'intranet' ) {
 721         $htdocs = C4::Context->config('intrahtdocs');
 722     }
 723     else {
 724         $htdocs = C4::Context->config('opachtdocs');
 725     }
 726     opendir D, "$htdocs";
 727     my @dirlist = readdir D;
 728     foreach my $directory (@dirlist) {
 729         next if $directory eq 'lib';
 730         -d "$htdocs/$directory/en" and push @themes, $directory;
 731     }
 732     return @themes;
 733 }
 734
 735 sub getFacets {
 736     my $facets;
 737     if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
 738         $facets = [
 739             {
 740                 idx   => 'su-to',
 741                 label => 'Topics',
 742                 tags  => [ qw/ 600ab 601ab 602a 604at 605a 606ax 610a / ],
 743                 sep   => ' - ',
 744             },
 745             {
 746                 idx   => 'su-geo',
 747                 label => 'Places',
 748                 tags  => [ qw/ 607a / ],
 749                 sep   => ' - ',
 750             },
 751             {
 752                 idx   => 'su-ut',
 753                 label => 'Titles',
 754                 tags  => [ qw/ 500a 501a 503a / ],
 755                 sep   => ', ',
 756             },
 757             {
 758                 idx   => 'au',
 759                 label => 'Authors',
 760                 tags  => [ qw/ 700ab 701ab 702ab / ],
 761                 sep   => C4::Context->preference("UNIMARCAuthorsFacetsSeparator"),
 762             },
 763             {
 764                 idx   => 'se',
 765                 label => 'Series',
 766                 tags  => [ qw/ 225a / ],
 767                 sep   => ', ',
 768             },
 769             {
 770                 idx  => 'location',
 771                 label => 'Location',
 772                 tags        => [ qw/ 995e / ],
 773             }
 774             ];
 775
 776             unless ( C4::Context->preference("singleBranchMode")
 777                 || GetBranchesCount() == 1 )
 778             {
 779                 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
 780                 if (   $DisplayLibraryFacets eq 'both'
 781                     || $DisplayLibraryFacets eq 'holding' )
 782                 {
 783                     push(
 784                         @$facets,
 785                         {
 786                             idx   => 'holdingbranch',
 787                             label => 'HoldingLibrary',
 788                             tags  => [qw / 995b /],
 789                         }
 790                     );
 791                 }
 792
 793                 if (   $DisplayLibraryFacets eq 'both'
 794                     || $DisplayLibraryFacets eq 'home' )
 795                 {
 796                 push(
 797                     @$facets,
 798                     {
 799                         idx   => 'homebranch',
 800                         label => 'HomeLibrary',
 801                         tags  => [qw / 995a /],
 802                     }
 803                 );
 804                 }
 805             }
 806     }
 807     else {
 808         $facets = [
 809             {
 810                 idx   => 'su-to',
 811                 label => 'Topics',
 812                 tags  => [ qw/ 650a / ],
 813                 sep   => '--',
 814             },
 815             #        {
 816             #        idx   => 'su-na',
 817             #        label => 'People and Organizations',
 818             #        tags  => [ qw/ 600a 610a 611a / ],
 819             #        sep   => 'a',
 820             #        },
 821             {
 822                 idx   => 'su-geo',
 823                 label => 'Places',
 824                 tags  => [ qw/ 651a / ],
 825                 sep   => '--',
 826             },
 827             {
 828                 idx   => 'su-ut',
 829                 label => 'Titles',
 830                 tags  => [ qw/ 630a / ],
 831                 sep   => '--',
 832             },
 833             {
 834                 idx   => 'au',
 835                 label => 'Authors',
 836                 tags  => [ qw/ 100a 110a 700a / ],
 837                 sep   => ', ',
 838             },
 839             {
 840                 idx   => 'se',
 841                 label => 'Series',
 842                 tags  => [ qw/ 440a 490a / ],
 843                 sep   => ', ',
 844             },
 845             {
 846                 idx   => 'itype',
 847                 label => 'ItemTypes',
 848                 tags  => [ qw/ 952y 942c / ],
 849                 sep   => ', ',
 850             },
 851             {
 852                 idx => 'location',
 853                 label => 'Location',
 854                 tags => [ qw / 952c / ],
 855             },
 856             ];
 857
 858             unless ( C4::Context->preference("singleBranchMode")
 859                 || GetBranchesCount() == 1 )
 860             {
 861                 my $DisplayLibraryFacets = C4::Context->preference('DisplayLibraryFacets');
 862                 if (   $DisplayLibraryFacets eq 'both'
 863                     || $DisplayLibraryFacets eq 'holding' )
 864                 {
 865                     push(
 866                         @$facets,
 867                         {
 868                             idx   => 'holdingbranch',
 869                             label => 'HoldingLibrary',
 870                             tags  => [qw / 952b /],
 871                         }
 872                     );
 873                 }
 874
 875                 if (   $DisplayLibraryFacets eq 'both'
 876                     || $DisplayLibraryFacets eq 'home' )
 877                 {
 878                 push(
 879                     @$facets,
 880                     {
 881                         idx   => 'homebranch',
 882                         label => 'HomeLibrary',
 883                         tags  => [qw / 952a /],
 884                     }
 885                 );
 886                 }
 887             }
 888     }
 889     return $facets;
 890 }
 891
 892 =head2 get_infos_of
 893
 894 Return a href where a key is associated to a href. You give a query,
 895 the name of the key among the fields returned by the query. If you
 896 also give as third argument the name of the value, the function
 897 returns a href of scalar. The optional 4th argument is an arrayref of
 898 items passed to the C<execute()> call. It is designed to bind
 899 parameters to any placeholders in your SQL.
 900
 901   my $query = '
 902 SELECT itemnumber,
 903        notforloan,
 904        barcode
 905   FROM items
 906 ';
 907
 908   # generic href of any information on the item, href of href.
 909   my $iteminfos_of = get_infos_of($query, 'itemnumber');
 910   print $iteminfos_of->{$itemnumber}{barcode};
 911
 912   # specific information, href of scalar
 913   my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
 914   print $barcode_of_item->{$itemnumber};
 915
 916 =cut
 917
 918 sub get_infos_of {
 919     my ( $query, $key_name, $value_name, $bind_params ) = @_;
 920
 921     my $dbh = C4::Context->dbh;
 922
 923     my $sth = $dbh->prepare($query);
 924     $sth->execute( @$bind_params );
 925
 926     my %infos_of;
 927     while ( my $row = $sth->fetchrow_hashref ) {
 928         if ( defined $value_name ) {
 929             $infos_of{ $row->{$key_name} } = $row->{$value_name};
 930         }
 931         else {
 932             $infos_of{ $row->{$key_name} } = $row;
 933         }
 934     }
 935     $sth->finish;
 936
 937     return \%infos_of;
 938 }
 939
 940 =head2 get_notforloan_label_of
 941
 942   my $notforloan_label_of = get_notforloan_label_of();
 943
 944 Each authorised value of notforloan (information available in items and
 945 itemtypes) is link to a single label.
 946
 947 Returns a href where keys are authorised values and values are corresponding
 948 labels.
 949
 950   foreach my $authorised_value (keys %{$notforloan_label_of}) {
 951     printf(
 952         "authorised_value: %s => %s\n",
 953         $authorised_value,
 954         $notforloan_label_of->{$authorised_value}
 955     );
 956   }
 957
 958 =cut
 959
 960 # FIXME - why not use GetAuthorisedValues ??
 961 #
 962 sub get_notforloan_label_of {
 963     my $dbh = C4::Context->dbh;
 964
 965     my $query = '
 966 SELECT authorised_value
 967   FROM marc_subfield_structure
 968   WHERE kohafield = \'items.notforloan\'
 969   LIMIT 0, 1
 970 ';
 971     my $sth = $dbh->prepare($query);
 972     $sth->execute();
 973     my ($statuscode) = $sth->fetchrow_array();
 974
 975     $query = '
 976 SELECT lib,
 977        authorised_value
 978   FROM authorised_values
 979   WHERE category = ?
 980 ';
 981     $sth = $dbh->prepare($query);
 982     $sth->execute($statuscode);
 983     my %notforloan_label_of;
 984     while ( my $row = $sth->fetchrow_hashref ) {
 985         $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
 986     }
 987     $sth->finish;
 988
 989     return \%notforloan_label_of;
 990 }
 991
 992 =head2 displayServers
 993
 994    my $servers = displayServers();
 995    my $servers = displayServers( $position );
 996    my $servers = displayServers( $position, $type );
 997
 998 displayServers returns a listref of hashrefs, each containing
 999 information about available z3950 servers. Each hashref has a format
1000 like:
1001
1002     {
1003       'checked'    => 'checked',
1004       'encoding'   => 'utf8',
1005       'icon'       => undef,
1006       'id'         => 'LIBRARY OF CONGRESS',
1007       'label'      => '',
1008       'name'       => 'server',
1009       'opensearch' => '',
1010       'value'      => 'lx2.loc.gov:210/',
1011       'zed'        => 1,
1012     },
1013
1014 =cut
1015
1016 sub displayServers {
1017     my ( $position, $type ) = @_;
1018     my $dbh = C4::Context->dbh;
1019
1020     my $strsth = 'SELECT * FROM z3950servers';
1021     my @where_clauses;
1022     my @bind_params;
1023
1024     if ($position) {
1025         push @bind_params,   $position;
1026         push @where_clauses, ' position = ? ';
1027     }
1028
1029     if ($type) {
1030         push @bind_params,   $type;
1031         push @where_clauses, ' type = ? ';
1032     }
1033
1034     # reassemble where clause from where clause pieces
1035     if (@where_clauses) {
1036         $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
1037     }
1038
1039     my $rq = $dbh->prepare($strsth);
1040     $rq->execute(@bind_params);
1041     my @primaryserverloop;
1042
1043     while ( my $data = $rq->fetchrow_hashref ) {
1044         push @primaryserverloop,
1045           { label    => $data->{description},
1046             id       => $data->{name},
1047             name     => "server",
1048             value    => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
1049             encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
1050             checked  => "checked",
1051             icon     => $data->{icon},
1052             zed        => $data->{type} eq 'zed',
1053             opensearch => $data->{type} eq 'opensearch'
1054           };
1055     }
1056     return \@primaryserverloop;
1057 }
1058
1059
1060 =head2 GetKohaImageurlFromAuthorisedValues
1061
1062 $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode );
1063
1064 Return the first url of the authorised value image represented by $lib.
1065
1066 =cut
1067
1068 sub GetKohaImageurlFromAuthorisedValues {
1069     my ( $category, $lib ) = @_;
1070     my $dbh = C4::Context->dbh;
1071     my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?");
1072     $sth->execute( $category, $lib );
1073     while ( my $data = $sth->fetchrow_hashref ) {
1074         return $data->{'imageurl'};
1075     }
1076 }
1077
1078 =head2 GetAuthValCode
1079
1080   $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
1081
1082 =cut
1083
1084 sub GetAuthValCode {
1085         my ($kohafield,$fwcode) = @_;
1086         my $dbh = C4::Context->dbh;
1087         $fwcode='' unless $fwcode;
1088         my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
1089         $sth->execute($kohafield,$fwcode);
1090         my ($authvalcode) = $sth->fetchrow_array;
1091         return $authvalcode;
1092 }
1093
1094 =head2 GetAuthValCodeFromField
1095
1096   $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode);
1097
1098 C<$subfield> can be undefined
1099
1100 =cut
1101
1102 sub GetAuthValCodeFromField {
1103         my ($field,$subfield,$fwcode) = @_;
1104         my $dbh = C4::Context->dbh;
1105         $fwcode='' unless $fwcode;
1106         my $sth;
1107         if (defined $subfield) {
1108             $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?');
1109             $sth->execute($field,$subfield,$fwcode);
1110         } else {
1111             $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?');
1112             $sth->execute($field,$fwcode);
1113         }
1114         my ($authvalcode) = $sth->fetchrow_array;
1115         return $authvalcode;
1116 }
1117
1118 =head2 GetAuthorisedValues
1119
1120   $authvalues = GetAuthorisedValues([$category], [$selected]);
1121
1122 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
1123
1124 C<$category> returns authorised values for just one category (optional).
1125
1126 C<$selected> adds a "selected => 1" entry to the hash if the
1127 authorised_value matches it. B<NOTE:> this feature should be considered
1128 deprecated as it may be removed in the future.
1129
1130 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1131
1132 =cut
1133
1134 sub GetAuthorisedValues {
1135     my ( $category, $selected, $opac ) = @_;
1136
1137     # TODO: the "selected" feature should be replaced by a utility function
1138     # somewhere else, it doesn't belong in here. For starters it makes
1139     # caching much more complicated. Or just let the UI logic handle it, it's
1140     # what it's for.
1141
1142     # Is this cached already?
1143     $opac = $opac ? 1 : 0;    # normalise to be safe
1144     my $branch_limit =
1145       C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1146     my $selected_key = defined($selected) ? $selected : '';
1147     my $cache_key =
1148       "AuthorisedValues-$category-$selected_key-$opac-$branch_limit";
1149     my $cache  = Koha::Cache->get_instance();
1150     my $result = $cache->get_from_cache($cache_key);
1151     return $result if $result;
1152
1153     my @results;
1154     my $dbh      = C4::Context->dbh;
1155     my $query = qq{
1156         SELECT *
1157         FROM authorised_values
1158     };
1159     $query .= qq{
1160           LEFT JOIN authorised_values_branches ON ( id = av_id )
1161     } if $branch_limit;
1162     my @where_strings;
1163     my @where_args;
1164     if($category) {
1165         push @where_strings, "category = ?";
1166         push @where_args, $category;
1167     }
1168     if($branch_limit) {
1169         push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
1170         push @where_args, $branch_limit;
1171     }
1172     if(@where_strings > 0) {
1173         $query .= " WHERE " . join(" AND ", @where_strings);
1174     }
1175     $query .= " GROUP BY lib";
1176     $query .= ' ORDER BY category, ' . (
1177                 $opac ? 'COALESCE(lib_opac, lib)'
1178                       : 'lib, lib_opac'
1179               );
1180
1181     my $sth = $dbh->prepare($query);
1182
1183     $sth->execute( @where_args );
1184     while (my $data=$sth->fetchrow_hashref) {
1185         if ( defined $selected and $selected eq $data->{authorised_value} ) {
1186             $data->{selected} = 1;
1187         }
1188         else {
1189             $data->{selected} = 0;
1190         }
1191
1192         if ($opac && $data->{lib_opac}) {
1193             $data->{lib} = $data->{lib_opac};
1194         }
1195         push @results, $data;
1196     }
1197     $sth->finish;
1198
1199     # We can't cache for long because of that "selected" thing which
1200     # makes it impossible to clear the cache without iterating through every
1201     # value, which sucks. This'll cover this request, and not a whole lot more.
1202     $cache->set_in_cache( $cache_key, \@results, { deepcopy => 1, expiry => 5 } );
1203     return \@results;
1204 }
1205
1206 =head2 GetAuthorisedValueCategories
1207
1208   $auth_categories = GetAuthorisedValueCategories();
1209
1210 Return an arrayref of all of the available authorised
1211 value categories.
1212
1213 =cut
1214
1215 sub GetAuthorisedValueCategories {
1216     my $dbh = C4::Context->dbh;
1217     my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1218     $sth->execute;
1219     my @results;
1220     while (defined (my $category  = $sth->fetchrow_array) ) {
1221         push @results, $category;
1222     }
1223     return \@results;
1224 }
1225
1226 =head2 IsAuthorisedValueCategory
1227
1228     $is_auth_val_category = IsAuthorisedValueCategory($category);
1229
1230 Returns whether a given category name is a valid one
1231
1232 =cut
1233
1234 sub IsAuthorisedValueCategory {
1235     my $category = shift;
1236     my $query = '
1237         SELECT category
1238         FROM authorised_values
1239         WHERE BINARY category=?
1240         LIMIT 1
1241     ';
1242     my $sth = C4::Context->dbh->prepare($query);
1243     $sth->execute($category);
1244     $sth->fetchrow ? return 1
1245                    : return 0;
1246 }
1247
1248 =head2 GetAuthorisedValueByCode
1249
1250 $authorised_value = GetAuthorisedValueByCode( $category, $authvalcode, $opac );
1251
1252 Return the lib attribute from authorised_values from the row identified
1253 by the passed category and code
1254
1255 =cut
1256
1257 sub GetAuthorisedValueByCode {
1258     my ( $category, $authvalcode, $opac ) = @_;
1259
1260     my $field = $opac ? 'lib_opac' : 'lib';
1261     my $dbh = C4::Context->dbh;
1262     my $sth = $dbh->prepare("SELECT $field FROM authorised_values WHERE category=? AND authorised_value =?");
1263     $sth->execute( $category, $authvalcode );
1264     while ( my $data = $sth->fetchrow_hashref ) {
1265         return $data->{ $field };
1266     }
1267 }
1268
1269 =head2 GetKohaAuthorisedValues
1270
1271 Takes $kohafield, $fwcode as parameters.
1272
1273 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1274
1275 Returns hashref of Code => description
1276
1277 Returns undef if no authorised value category is defined for the kohafield.
1278
1279 =cut
1280
1281 sub GetKohaAuthorisedValues {
1282   my ($kohafield,$fwcode,$opac) = @_;
1283   $fwcode='' unless $fwcode;
1284   my %values;
1285   my $dbh = C4::Context->dbh;
1286   my $avcode = GetAuthValCode($kohafield,$fwcode);
1287   if ($avcode) {
1288         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1289         $sth->execute($avcode);
1290         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1291                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1292         }
1293         return \%values;
1294   } else {
1295         return;
1296   }
1297 }
1298
1299 =head2 GetKohaAuthorisedValuesFromField
1300
1301 Takes $field, $subfield, $fwcode as parameters.
1302
1303 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1304 $subfield can be undefined
1305
1306 Returns hashref of Code => description
1307
1308 Returns undef if no authorised value category is defined for the given field and subfield
1309
1310 =cut
1311
1312 sub GetKohaAuthorisedValuesFromField {
1313   my ($field, $subfield, $fwcode,$opac) = @_;
1314   $fwcode='' unless $fwcode;
1315   my %values;
1316   my $dbh = C4::Context->dbh;
1317   my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode);
1318   if ($avcode) {
1319         my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? ");
1320         $sth->execute($avcode);
1321         while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) {
1322                 $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib;
1323         }
1324         return \%values;
1325   } else {
1326         return;
1327   }
1328 }
1329
1330 =head2 xml_escape
1331
1332   my $escaped_string = C4::Koha::xml_escape($string);
1333
1334 Convert &, <, >, ', and " in a string to XML entities
1335
1336 =cut
1337
1338 sub xml_escape {
1339     my $str = shift;
1340     return '' unless defined $str;
1341     $str =~ s/&/&amp;/g;
1342     $str =~ s/</&lt;/g;
1343     $str =~ s/>/&gt;/g;
1344     $str =~ s/'/&apos;/g;
1345     $str =~ s/"/&quot;/g;
1346     return $str;
1347 }
1348
1349 =head2 GetKohaAuthorisedValueLib
1350
1351 Takes $category, $authorised_value as parameters.
1352
1353 If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist.
1354
1355 Returns authorised value description
1356
1357 =cut
1358
1359 sub GetKohaAuthorisedValueLib {
1360   my ($category,$authorised_value,$opac) = @_;
1361   my $value;
1362   my $dbh = C4::Context->dbh;
1363   my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?");
1364   $sth->execute($category,$authorised_value);
1365   my $data = $sth->fetchrow_hashref;
1366   $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'};
1367   return $value;
1368 }
1369
1370 =head2 AddAuthorisedValue
1371
1372     AddAuthorisedValue($category, $authorised_value, $lib, $lib_opac, $imageurl);
1373
1374 Create a new authorised value.
1375
1376 =cut
1377
1378 sub AddAuthorisedValue {
1379     my ($category, $authorised_value, $lib, $lib_opac, $imageurl) = @_;
1380
1381     my $dbh = C4::Context->dbh;
1382     my $query = qq{
1383         INSERT INTO authorised_values (category, authorised_value, lib, lib_opac, imageurl)
1384         VALUES (?,?,?,?,?)
1385     };
1386     my $sth = $dbh->prepare($query);
1387     $sth->execute($category, $authorised_value, $lib, $lib_opac, $imageurl);
1388 }
1389
1390 =head2 display_marc_indicators
1391
1392   my $display_form = C4::Koha::display_marc_indicators($field);
1393
1394 C<$field> is a MARC::Field object
1395
1396 Generate a display form of the indicators of a variable
1397 MARC field, replacing any blanks with '#'.
1398
1399 =cut
1400
1401 sub display_marc_indicators {
1402     my $field = shift;
1403     my $indicators = '';
1404     if ($field->tag() >= 10) {
1405         $indicators = $field->indicator(1) . $field->indicator(2);
1406         $indicators =~ s/ /#/g;
1407     }
1408     return $indicators;
1409 }
1410
1411 sub GetNormalizedUPC {
1412  my ($record,$marcflavour) = @_;
1413     my (@fields,$upc);
1414
1415     if ($marcflavour eq 'UNIMARC') {
1416         @fields = $record->field('072');
1417         foreach my $field (@fields) {
1418             my $upc = _normalize_match_point($field->subfield('a'));
1419             if ($upc ne '') {
1420                 return $upc;
1421             }
1422         }
1423
1424     }
1425     else { # assume marc21 if not unimarc
1426         @fields = $record->field('024');
1427         foreach my $field (@fields) {
1428             my $indicator = $field->indicator(1);
1429             my $upc = _normalize_match_point($field->subfield('a'));
1430             if ($indicator == 1 and $upc ne '') {
1431                 return $upc;
1432             }
1433         }
1434     }
1435 }
1436
1437 # Normalizes and returns the first valid ISBN found in the record
1438 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
1439 sub GetNormalizedISBN {
1440     my ($isbn,$record,$marcflavour) = @_;
1441     my @fields;
1442     if ($isbn) {
1443         # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
1444         # anything after " | " should be removed, along with the delimiter
1445         $isbn =~ s/(.*)( \| )(.*)/$1/;
1446         return _isbn_cleanup($isbn);
1447     }
1448     return unless $record;
1449
1450     if ($marcflavour eq 'UNIMARC') {
1451         @fields = $record->field('010');
1452         foreach my $field (@fields) {
1453             my $isbn = $field->subfield('a');
1454             if ($isbn) {
1455                 return _isbn_cleanup($isbn);
1456             } else {
1457                 return;
1458             }
1459         }
1460     }
1461     else { # assume marc21 if not unimarc
1462         @fields = $record->field('020');
1463         foreach my $field (@fields) {
1464             $isbn = $field->subfield('a');
1465             if ($isbn) {
1466                 return _isbn_cleanup($isbn);
1467             } else {
1468                 return;
1469             }
1470         }
1471     }
1472 }
1473
1474 sub GetNormalizedEAN {
1475     my ($record,$marcflavour) = @_;
1476     my (@fields,$ean);
1477
1478     if ($marcflavour eq 'UNIMARC') {
1479         @fields = $record->field('073');
1480         foreach my $field (@fields) {
1481             $ean = _normalize_match_point($field->subfield('a'));
1482             if ($ean ne '') {
1483                 return $ean;
1484             }
1485         }
1486     }
1487     else { # assume marc21 if not unimarc
1488         @fields = $record->field('024');
1489         foreach my $field (@fields) {
1490             my $indicator = $field->indicator(1);
1491             $ean = _normalize_match_point($field->subfield('a'));
1492             if ($indicator == 3 and $ean ne '') {
1493                 return $ean;
1494             }
1495         }
1496     }
1497 }
1498 sub GetNormalizedOCLCNumber {
1499     my ($record,$marcflavour) = @_;
1500     my (@fields,$oclc);
1501
1502     if ($marcflavour eq 'UNIMARC') {
1503         # TODO: add UNIMARC fields
1504     }
1505     else { # assume marc21 if not unimarc
1506         @fields = $record->field('035');
1507         foreach my $field (@fields) {
1508             $oclc = $field->subfield('a');
1509             if ($oclc =~ /OCoLC/) {
1510                 $oclc =~ s/\(OCoLC\)//;
1511                 return $oclc;
1512             } else {
1513                 return;
1514             }
1515         }
1516     }
1517 }
1518
1519 sub GetAuthvalueDropbox {
1520     my ( $authcat, $default ) = @_;
1521     my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
1522     my $dbh = C4::Context->dbh;
1523
1524     my $query = qq{
1525         SELECT *
1526         FROM authorised_values
1527     };
1528     $query .= qq{
1529           LEFT JOIN authorised_values_branches ON ( id = av_id )
1530     } if $branch_limit;
1531     $query .= qq{
1532         WHERE category = ?
1533     };
1534     $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
1535     $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
1536     my $sth = $dbh->prepare($query);
1537     $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
1538
1539
1540     my $option_list = [];
1541     my @authorised_values = ( q{} );
1542     while (my $av = $sth->fetchrow_hashref) {
1543         push @{$option_list}, {
1544             value => $av->{authorised_value},
1545             label => $av->{lib},
1546             default => ($default eq $av->{authorised_value}),
1547         };
1548     }
1549
1550     if ( @{$option_list} ) {
1551         return $option_list;
1552     }
1553     return;
1554 }
1555
1556
1557 =head2 GetDailyQuote($opts)
1558
1559 Takes a hashref of options
1560
1561 Currently supported options are:
1562
1563 'id'        An exact quote id
1564 'random'    Select a random quote
1565 noop        When no option is passed in, this sub will return the quote timestamped for the current day
1566
1567 The function returns an anonymous hash following this format:
1568
1569         {
1570           'source' => 'source-of-quote',
1571           'timestamp' => 'timestamp-value',
1572           'text' => 'text-of-quote',
1573           'id' => 'quote-id'
1574         };
1575
1576 =cut
1577
1578 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1579 # at least for default option
1580
1581 sub GetDailyQuote {
1582     my %opts = @_;
1583     my $dbh = C4::Context->dbh;
1584     my $query = '';
1585     my $sth = undef;
1586     my $quote = undef;
1587     if ($opts{'id'}) {
1588         $query = 'SELECT * FROM quotes WHERE id = ?';
1589         $sth = $dbh->prepare($query);
1590         $sth->execute($opts{'id'});
1591         $quote = $sth->fetchrow_hashref();
1592     }
1593     elsif ($opts{'random'}) {
1594         # Fall through... we also return a random quote as a catch-all if all else fails
1595     }
1596     else {
1597         $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1598         $sth = $dbh->prepare($query);
1599         $sth->execute();
1600         $quote = $sth->fetchrow_hashref();
1601     }
1602     unless ($quote) {        # if there are not matches, choose a random quote
1603         # get a list of all available quote ids
1604         $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1605         $sth->execute;
1606         my $range = ($sth->fetchrow_array)[0];
1607         # chose a random id within that range if there is more than one quote
1608         my $offset = int(rand($range));
1609         # grab it
1610         $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1611         $sth = C4::Context->dbh->prepare($query);
1612         # see http://www.perlmonks.org/?node_id=837422 for why
1613         # we're being verbose and using bind_param
1614         $sth->bind_param(1, $offset, SQL_INTEGER);
1615         $sth->execute();
1616         $quote = $sth->fetchrow_hashref();
1617         # update the timestamp for that quote
1618         $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1619         $sth = C4::Context->dbh->prepare($query);
1620         $sth->execute(
1621             DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1622             $quote->{'id'}
1623         );
1624     }
1625     return $quote;
1626 }
1627
1628 sub _normalize_match_point {
1629     my $match_point = shift;
1630     (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1631     $normalized_match_point =~ s/-//g;
1632
1633     return $normalized_match_point;
1634 }
1635
1636 sub _isbn_cleanup {
1637     my ($isbn) = @_;
1638     return NormalizeISBN(
1639         {
1640             isbn          => $isbn,
1641             format        => 'ISBN-10',
1642             strip_hyphens => 1,
1643         }
1644     ) if $isbn;
1645 }
1646
1647 =head2 NormalizedISBN
1648
1649   my $isbns = NormalizedISBN({
1650     isbn => $isbn,
1651     strip_hyphens => [0,1],
1652     format => ['ISBN-10', 'ISBN-13']
1653   });
1654
1655   Returns an isbn validated by Business::ISBN.
1656   Optionally strips hyphens and/or forces the isbn
1657   to be of the specified format.
1658
1659   If the string cannot be validated as an isbn,
1660   it returns nothing.
1661
1662 =cut
1663
1664 sub NormalizeISBN {
1665     my ($params) = @_;
1666
1667     my $string        = $params->{isbn};
1668     my $strip_hyphens = $params->{strip_hyphens};
1669     my $format        = $params->{format};
1670
1671     return unless $string;
1672
1673     my $isbn = Business::ISBN->new($string);
1674
1675     if ( $isbn && $isbn->is_valid() ) {
1676
1677         if ( $format eq 'ISBN-10' ) {
1678             $isbn = $isbn->as_isbn10();
1679         }
1680         elsif ( $format eq 'ISBN-13' ) {
1681             $isbn = $isbn->as_isbn13();
1682         }
1683
1684         if ($strip_hyphens) {
1685             $string = $isbn->as_string( [] );
1686         } else {
1687             $string = $isbn->as_string();
1688         }
1689
1690         return $string;
1691     }
1692 }
1693
1694 =head2 GetVariationsOfISBN
1695
1696   my @isbns = GetVariationsOfISBN( $isbn );
1697
1698   Returns a list of varations of the given isbn in
1699   both ISBN-10 and ISBN-13 formats, with and without
1700   hyphens.
1701
1702   In a scalar context, the isbns are returned as a
1703   string delimited by ' | '.
1704
1705 =cut
1706
1707 sub GetVariationsOfISBN {
1708     my ($isbn) = @_;
1709
1710     return unless $isbn;
1711
1712     my @isbns;
1713
1714     push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1715     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1716     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1717     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1718     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1719
1720     # Strip out any "empty" strings from the array
1721     @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1722
1723     return wantarray ? @isbns : join( " | ", @isbns );
1724 }
1725
1726 =head2 GetVariationsOfISBNs
1727
1728   my @isbns = GetVariationsOfISBNs( @isbns );
1729
1730   Returns a list of varations of the given isbns in
1731   both ISBN-10 and ISBN-13 formats, with and without
1732   hyphens.
1733
1734   In a scalar context, the isbns are returned as a
1735   string delimited by ' | '.
1736
1737 =cut
1738
1739 sub GetVariationsOfISBNs {
1740     my (@isbns) = @_;
1741
1742     @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1743
1744     return wantarray ? @isbns : join( " | ", @isbns );
1745 }
1746
1747 =head2 IsKohaFieldLinked
1748
1749     my $is_linked = IsKohaFieldLinked({
1750         kohafield => $kohafield,
1751         frameworkcode => $frameworkcode,
1752     });
1753
1754     Return 1 if the field is linked
1755
1756 =cut
1757
1758 sub IsKohaFieldLinked {
1759     my ( $params ) = @_;
1760     my $kohafield = $params->{kohafield};
1761     my $frameworkcode = $params->{frameworkcode} || '';
1762     my $dbh = C4::Context->dbh;
1763     my $is_linked = $dbh->selectcol_arrayref( q|
1764         SELECT COUNT(*)
1765         FROM marc_subfield_structure
1766         WHERE frameworkcode = ?
1767         AND kohafield = ?
1768     |,{}, $frameworkcode, $kohafield );
1769     return $is_linked->[0];
1770 }
1771
1772 1;
1773
1774 __END__
1775
1776 =head1 AUTHOR
1777
1778 Koha Team
1779
1780 =cut