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