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