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