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