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_infos_of
 642
 643 Return a href where a key is associated to a href. You give a query,
 644 the name of the key among the fields returned by the query. If you
 645 also give as third argument the name of the value, the function
 646 returns a href of scalar. The optional 4th argument is an arrayref of
 647 items passed to the C<execute()> call. It is designed to bind
 648 parameters to any placeholders in your SQL.
 649
 650   my $query = '
 651 SELECT itemnumber,
 652        notforloan,
 653        barcode
 654   FROM items
 655 ';
 656
 657   # generic href of any information on the item, href of href.
 658   my $iteminfos_of = get_infos_of($query, 'itemnumber');
 659   print $iteminfos_of->{$itemnumber}{barcode};
 660
 661   # specific information, href of scalar
 662   my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
 663   print $barcode_of_item->{$itemnumber};
 664
 665 =cut
 666
 667 sub get_infos_of {
 668     my ( $query, $key_name, $value_name, $bind_params ) = @_;
 669
 670     my $dbh = C4::Context->dbh;
 671
 672     my $sth = $dbh->prepare($query);
 673     $sth->execute( @$bind_params );
 674
 675     my %infos_of;
 676     while ( my $row = $sth->fetchrow_hashref ) {
 677         if ( defined $value_name ) {
 678             $infos_of{ $row->{$key_name} } = $row->{$value_name};
 679         }
 680         else {
 681             $infos_of{ $row->{$key_name} } = $row;
 682         }
 683     }
 684     $sth->finish;
 685
 686     return \%infos_of;
 687 }
 688
 689 =head2 get_notforloan_label_of
 690
 691   my $notforloan_label_of = get_notforloan_label_of();
 692
 693 Each authorised value of notforloan (information available in items and
 694 itemtypes) is link to a single label.
 695
 696 Returns a href where keys are authorised values and values are corresponding
 697 labels.
 698
 699   foreach my $authorised_value (keys %{$notforloan_label_of}) {
 700     printf(
 701         "authorised_value: %s => %s\n",
 702         $authorised_value,
 703         $notforloan_label_of->{$authorised_value}
 704     );
 705   }
 706
 707 =cut
 708
 709 # FIXME - why not use GetAuthorisedValues ??
 710 #
 711 sub get_notforloan_label_of {
 712     my $dbh = C4::Context->dbh;
 713
 714     my $query = '
 715 SELECT authorised_value
 716   FROM marc_subfield_structure
 717   WHERE kohafield = \'items.notforloan\'
 718   LIMIT 0, 1
 719 ';
 720     my $sth = $dbh->prepare($query);
 721     $sth->execute();
 722     my ($statuscode) = $sth->fetchrow_array();
 723
 724     $query = '
 725 SELECT lib,
 726        authorised_value
 727   FROM authorised_values
 728   WHERE category = ?
 729 ';
 730     $sth = $dbh->prepare($query);
 731     $sth->execute($statuscode);
 732     my %notforloan_label_of;
 733     while ( my $row = $sth->fetchrow_hashref ) {
 734         $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
 735     }
 736     $sth->finish;
 737
 738     return \%notforloan_label_of;
 739 }
 740
 741 =head2 GetAuthorisedValues
 742
 743   $authvalues = GetAuthorisedValues([$category]);
 744
 745 This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs.
 746
 747 C<$category> returns authorised values for just one category (optional).
 748
 749 C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist.
 750
 751 =cut
 752
 753 sub GetAuthorisedValues {
 754     my ( $category, $opac ) = @_;
 755
 756     # Is this cached already?
 757     $opac = $opac ? 1 : 0;    # normalise to be safe
 758     my $branch_limit =
 759       C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
 760     my $cache_key =
 761       "AuthorisedValues-$category-$opac-$branch_limit";
 762     my $cache  = Koha::Caches->get_instance();
 763     my $result = $cache->get_from_cache($cache_key);
 764     return $result if $result;
 765
 766     my @results;
 767     my $dbh      = C4::Context->dbh;
 768     my $query = qq{
 769         SELECT DISTINCT av.*
 770         FROM authorised_values av
 771     };
 772     $query .= qq{
 773           LEFT JOIN authorised_values_branches ON ( id = av_id )
 774     } if $branch_limit;
 775     my @where_strings;
 776     my @where_args;
 777     if($category) {
 778         push @where_strings, "category = ?";
 779         push @where_args, $category;
 780     }
 781     if($branch_limit) {
 782         push @where_strings, "( branchcode = ? OR branchcode IS NULL )";
 783         push @where_args, $branch_limit;
 784     }
 785     if(@where_strings > 0) {
 786         $query .= " WHERE " . join(" AND ", @where_strings);
 787     }
 788     $query .= ' ORDER BY category, ' . (
 789                 $opac ? 'COALESCE(lib_opac, lib)'
 790                       : 'lib, lib_opac'
 791               );
 792
 793     my $sth = $dbh->prepare($query);
 794
 795     $sth->execute( @where_args );
 796     while (my $data=$sth->fetchrow_hashref) {
 797         if ($opac && $data->{lib_opac}) {
 798             $data->{lib} = $data->{lib_opac};
 799         }
 800         push @results, $data;
 801     }
 802     $sth->finish;
 803
 804     $cache->set_in_cache( $cache_key, \@results, { expiry => 5 } );
 805     return \@results;
 806 }
 807
 808 =head2 xml_escape
 809
 810   my $escaped_string = C4::Koha::xml_escape($string);
 811
 812 Convert &, <, >, ', and " in a string to XML entities
 813
 814 =cut
 815
 816 sub xml_escape {
 817     my $str = shift;
 818     return '' unless defined $str;
 819     $str =~ s/&/&amp;/g;
 820     $str =~ s/</&lt;/g;
 821     $str =~ s/>/&gt;/g;
 822     $str =~ s/'/&apos;/g;
 823     $str =~ s/"/&quot;/g;
 824     return $str;
 825 }
 826
 827 =head2 display_marc_indicators
 828
 829   my $display_form = C4::Koha::display_marc_indicators($field);
 830
 831 C<$field> is a MARC::Field object
 832
 833 Generate a display form of the indicators of a variable
 834 MARC field, replacing any blanks with '#'.
 835
 836 =cut
 837
 838 sub display_marc_indicators {
 839     my $field = shift;
 840     my $indicators = '';
 841     if ($field && $field->tag() >= 10) {
 842         $indicators = $field->indicator(1) . $field->indicator(2);
 843         $indicators =~ s/ /#/g;
 844     }
 845     return $indicators;
 846 }
 847
 848 sub GetNormalizedUPC {
 849     my ($marcrecord,$marcflavour) = @_;
 850
 851     return unless $marcrecord;
 852     if ($marcflavour eq 'UNIMARC') {
 853         my @fields = $marcrecord->field('072');
 854         foreach my $field (@fields) {
 855             my $upc = _normalize_match_point($field->subfield('a'));
 856             if ($upc) {
 857                 return $upc;
 858             }
 859         }
 860
 861     }
 862     else { # assume marc21 if not unimarc
 863         my @fields = $marcrecord->field('024');
 864         foreach my $field (@fields) {
 865             my $indicator = $field->indicator(1);
 866             my $upc = _normalize_match_point($field->subfield('a'));
 867             if ($upc && $indicator == 1 ) {
 868                 return $upc;
 869             }
 870         }
 871     }
 872 }
 873
 874 # Normalizes and returns the first valid ISBN found in the record
 875 # ISBN13 are converted into ISBN10. This is required to get some book cover images.
 876 sub GetNormalizedISBN {
 877     my ($isbn,$marcrecord,$marcflavour) = @_;
 878     if ($isbn) {
 879         # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | "
 880         # anything after " | " should be removed, along with the delimiter
 881         ($isbn) = split(/\|/, $isbn );
 882         return _isbn_cleanup($isbn);
 883     }
 884
 885     return unless $marcrecord;
 886
 887     if ($marcflavour eq 'UNIMARC') {
 888         my @fields = $marcrecord->field('010');
 889         foreach my $field (@fields) {
 890             my $isbn = $field->subfield('a');
 891             if ($isbn) {
 892                 return _isbn_cleanup($isbn);
 893             }
 894         }
 895     }
 896     else { # assume marc21 if not unimarc
 897         my @fields = $marcrecord->field('020');
 898         foreach my $field (@fields) {
 899             $isbn = $field->subfield('a');
 900             if ($isbn) {
 901                 return _isbn_cleanup($isbn);
 902             }
 903         }
 904     }
 905 }
 906
 907 sub GetNormalizedEAN {
 908     my ($marcrecord,$marcflavour) = @_;
 909
 910     return unless $marcrecord;
 911
 912     if ($marcflavour eq 'UNIMARC') {
 913         my @fields = $marcrecord->field('073');
 914         foreach my $field (@fields) {
 915             my $ean = _normalize_match_point($field->subfield('a'));
 916             if ( $ean ) {
 917                 return $ean;
 918             }
 919         }
 920     }
 921     else { # assume marc21 if not unimarc
 922         my @fields = $marcrecord->field('024');
 923         foreach my $field (@fields) {
 924             my $indicator = $field->indicator(1);
 925             my $ean = _normalize_match_point($field->subfield('a'));
 926             if ( $ean && $indicator == 3  ) {
 927                 return $ean;
 928             }
 929         }
 930     }
 931 }
 932
 933 sub GetNormalizedOCLCNumber {
 934     my ($marcrecord,$marcflavour) = @_;
 935     return unless $marcrecord;
 936
 937     if ($marcflavour ne 'UNIMARC' ) {
 938         my @fields = $marcrecord->field('035');
 939         foreach my $field (@fields) {
 940             my $oclc = $field->subfield('a');
 941             if ($oclc =~ /OCoLC/) {
 942                 $oclc =~ s/\(OCoLC\)//;
 943                 return $oclc;
 944             }
 945         }
 946     } else {
 947         # TODO for UNIMARC
 948     }
 949     return
 950 }
 951
 952 sub GetAuthvalueDropbox {
 953     my ( $authcat, $default ) = @_;
 954     my $branch_limit = C4::Context->userenv ? C4::Context->userenv->{"branch"} : "";
 955     my $dbh = C4::Context->dbh;
 956
 957     my $query = qq{
 958         SELECT *
 959         FROM authorised_values
 960     };
 961     $query .= qq{
 962           LEFT JOIN authorised_values_branches ON ( id = av_id )
 963     } if $branch_limit;
 964     $query .= qq{
 965         WHERE category = ?
 966     };
 967     $query .= " AND ( branchcode = ? OR branchcode IS NULL )" if $branch_limit;
 968     $query .= " GROUP BY lib ORDER BY category, lib, lib_opac";
 969     my $sth = $dbh->prepare($query);
 970     $sth->execute( $authcat, $branch_limit ? $branch_limit : () );
 971
 972
 973     my $option_list = [];
 974     my @authorised_values = ( q{} );
 975     while (my $av = $sth->fetchrow_hashref) {
 976         push @{$option_list}, {
 977             value => $av->{authorised_value},
 978             label => $av->{lib},
 979             default => ($default eq $av->{authorised_value}),
 980         };
 981     }
 982
 983     if ( @{$option_list} ) {
 984         return $option_list;
 985     }
 986     return;
 987 }
 988
 989
 990 =head2 GetDailyQuote($opts)
 991
 992 Takes a hashref of options
 993
 994 Currently supported options are:
 995
 996 'id'        An exact quote id
 997 'random'    Select a random quote
 998 noop        When no option is passed in, this sub will return the quote timestamped for the current day
 999
1000 The function returns an anonymous hash following this format:
1001
1002         {
1003           'source' => 'source-of-quote',
1004           'timestamp' => 'timestamp-value',
1005           'text' => 'text-of-quote',
1006           'id' => 'quote-id'
1007         };
1008
1009 =cut
1010
1011 # This is definitely a candidate for some sort of caching once we finally settle caching/persistence issues...
1012 # at least for default option
1013
1014 sub GetDailyQuote {
1015     my %opts = @_;
1016     my $dbh = C4::Context->dbh;
1017     my $query = '';
1018     my $sth = undef;
1019     my $quote = undef;
1020     if ($opts{'id'}) {
1021         $query = 'SELECT * FROM quotes WHERE id = ?';
1022         $sth = $dbh->prepare($query);
1023         $sth->execute($opts{'id'});
1024         $quote = $sth->fetchrow_hashref();
1025     }
1026     elsif ($opts{'random'}) {
1027         # Fall through... we also return a random quote as a catch-all if all else fails
1028     }
1029     else {
1030         $query = 'SELECT * FROM quotes WHERE timestamp LIKE CONCAT(CURRENT_DATE,\'%\') ORDER BY timestamp DESC LIMIT 0,1';
1031         $sth = $dbh->prepare($query);
1032         $sth->execute();
1033         $quote = $sth->fetchrow_hashref();
1034     }
1035     unless ($quote) {        # if there are not matches, choose a random quote
1036         # get a list of all available quote ids
1037         $sth = C4::Context->dbh->prepare('SELECT count(*) FROM quotes;');
1038         $sth->execute;
1039         my $range = ($sth->fetchrow_array)[0];
1040         # chose a random id within that range if there is more than one quote
1041         my $offset = int(rand($range));
1042         # grab it
1043         $query = 'SELECT * FROM quotes ORDER BY id LIMIT 1 OFFSET ?';
1044         $sth = C4::Context->dbh->prepare($query);
1045         # see http://www.perlmonks.org/?node_id=837422 for why
1046         # we're being verbose and using bind_param
1047         $sth->bind_param(1, $offset, SQL_INTEGER);
1048         $sth->execute();
1049         $quote = $sth->fetchrow_hashref();
1050         # update the timestamp for that quote
1051         $query = 'UPDATE quotes SET timestamp = ? WHERE id = ?';
1052         $sth = C4::Context->dbh->prepare($query);
1053         $sth->execute(
1054             DateTime::Format::MySQL->format_datetime( dt_from_string() ),
1055             $quote->{'id'}
1056         );
1057     }
1058     return $quote;
1059 }
1060
1061 sub _normalize_match_point {
1062     my $match_point = shift;
1063     (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1064     $normalized_match_point =~ s/-//g;
1065
1066     return $normalized_match_point;
1067 }
1068
1069 sub _isbn_cleanup {
1070     my ($isbn) = @_;
1071     return NormalizeISBN(
1072         {
1073             isbn          => $isbn,
1074             format        => 'ISBN-10',
1075             strip_hyphens => 1,
1076         }
1077     ) if $isbn;
1078 }
1079
1080 =head2 NormalizedISBN
1081
1082   my $isbns = NormalizedISBN({
1083     isbn => $isbn,
1084     strip_hyphens => [0,1],
1085     format => ['ISBN-10', 'ISBN-13']
1086   });
1087
1088   Returns an isbn validated by Business::ISBN.
1089   Optionally strips hyphens and/or forces the isbn
1090   to be of the specified format.
1091
1092   If the string cannot be validated as an isbn,
1093   it returns nothing.
1094
1095 =cut
1096
1097 sub NormalizeISBN {
1098     my ($params) = @_;
1099
1100     my $string        = $params->{isbn};
1101     my $strip_hyphens = $params->{strip_hyphens};
1102     my $format        = $params->{format};
1103
1104     return unless $string;
1105
1106     my $isbn = Business::ISBN->new($string);
1107
1108     if ( $isbn && $isbn->is_valid() ) {
1109
1110         if ( $format eq 'ISBN-10' ) {
1111             $isbn = $isbn->as_isbn10();
1112         }
1113         elsif ( $format eq 'ISBN-13' ) {
1114             $isbn = $isbn->as_isbn13();
1115         }
1116         return unless $isbn;
1117
1118         if ($strip_hyphens) {
1119             $string = $isbn->as_string( [] );
1120         } else {
1121             $string = $isbn->as_string();
1122         }
1123
1124         return $string;
1125     }
1126 }
1127
1128 =head2 GetVariationsOfISBN
1129
1130   my @isbns = GetVariationsOfISBN( $isbn );
1131
1132   Returns a list of variations of the given isbn in
1133   both ISBN-10 and ISBN-13 formats, with and without
1134   hyphens.
1135
1136   In a scalar context, the isbns are returned as a
1137   string delimited by ' | '.
1138
1139 =cut
1140
1141 sub GetVariationsOfISBN {
1142     my ($isbn) = @_;
1143
1144     return unless $isbn;
1145
1146     my @isbns;
1147
1148     push( @isbns, NormalizeISBN({ isbn => $isbn }) );
1149     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10' }) );
1150     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13' }) );
1151     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-10', strip_hyphens => 1 }) );
1152     push( @isbns, NormalizeISBN({ isbn => $isbn, format => 'ISBN-13', strip_hyphens => 1 }) );
1153
1154     # Strip out any "empty" strings from the array
1155     @isbns = grep { defined($_) && $_ =~ /\S/ } @isbns;
1156
1157     return wantarray ? @isbns : join( " | ", @isbns );
1158 }
1159
1160 =head2 GetVariationsOfISBNs
1161
1162   my @isbns = GetVariationsOfISBNs( @isbns );
1163
1164   Returns a list of variations of the given isbns in
1165   both ISBN-10 and ISBN-13 formats, with and without
1166   hyphens.
1167
1168   In a scalar context, the isbns are returned as a
1169   string delimited by ' | '.
1170
1171 =cut
1172
1173 sub GetVariationsOfISBNs {
1174     my (@isbns) = @_;
1175
1176     @isbns = map { GetVariationsOfISBN( $_ ) } @isbns;
1177
1178     return wantarray ? @isbns : join( " | ", @isbns );
1179 }
1180
1181 =head2 NormalizedISSN
1182
1183   my $issns = NormalizedISSN({
1184           issn => $issn,
1185           strip_hyphen => [0,1]
1186           });
1187
1188   Returns an issn validated by Business::ISSN.
1189   Optionally strips hyphen.
1190
1191   If the string cannot be validated as an issn,
1192   it returns nothing.
1193
1194 =cut
1195
1196 sub NormalizeISSN {
1197     my ($params) = @_;
1198
1199     my $string        = $params->{issn};
1200     my $strip_hyphen  = $params->{strip_hyphen};
1201
1202     my $issn = Business::ISSN->new($string);
1203
1204     if ( $issn && $issn->is_valid ){
1205
1206         if ($strip_hyphen) {
1207             $string = $issn->_issn;
1208         }
1209         else {
1210             $string = $issn->as_string;
1211         }
1212         return $string;
1213     }
1214
1215 }
1216
1217 =head2 GetVariationsOfISSN
1218
1219   my @issns = GetVariationsOfISSN( $issn );
1220
1221   Returns a list of variations of the given issn in
1222   with and without a hyphen.
1223
1224   In a scalar context, the issns are returned as a
1225   string delimited by ' | '.
1226
1227 =cut
1228
1229 sub GetVariationsOfISSN {
1230     my ( $issn ) = @_;
1231
1232     return unless $issn;
1233
1234     my @issns;
1235     my $str = NormalizeISSN({ issn => $issn });
1236     if( $str ) {
1237         push @issns, $str;
1238         push @issns, NormalizeISSN({ issn => $issn, strip_hyphen => 1 });
1239     }  else {
1240         push @issns, $issn;
1241     }
1242
1243     # Strip out any "empty" strings from the array
1244     @issns = grep { defined($_) && $_ =~ /\S/ } @issns;
1245
1246     return wantarray ? @issns : join( " | ", @issns );
1247 }
1248
1249 =head2 GetVariationsOfISSNs
1250
1251   my @issns = GetVariationsOfISSNs( @issns );
1252
1253   Returns a list of variations of the given issns in
1254   with and without a hyphen.
1255
1256   In a scalar context, the issns are returned as a
1257   string delimited by ' | '.
1258
1259 =cut
1260
1261 sub GetVariationsOfISSNs {
1262     my (@issns) = @_;
1263
1264     @issns = map { GetVariationsOfISSN( $_ ) } @issns;
1265
1266     return wantarray ? @issns : join( " | ", @issns );
1267 }
1268
1269
1270 =head2 IsKohaFieldLinked
1271
1272     my $is_linked = IsKohaFieldLinked({
1273         kohafield => $kohafield,
1274         frameworkcode => $frameworkcode,
1275     });
1276
1277     Return 1 if the field is linked
1278
1279 =cut
1280
1281 sub IsKohaFieldLinked {
1282     my ( $params ) = @_;
1283     my $kohafield = $params->{kohafield};
1284     my $frameworkcode = $params->{frameworkcode} || '';
1285     my $dbh = C4::Context->dbh;
1286     my $is_linked = $dbh->selectcol_arrayref( q|
1287         SELECT COUNT(*)
1288         FROM marc_subfield_structure
1289         WHERE frameworkcode = ?
1290         AND kohafield = ?
1291     |,{}, $frameworkcode, $kohafield );
1292     return $is_linked->[0];
1293 }
1294
1295 1;
1296
1297 __END__
1298
1299 =head1 AUTHOR
1300
1301 Koha Team
1302
1303 =cut