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