C4/Koha.pm

   1 package C4::Koha;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it under the
   8 # terms of the GNU General Public License as published by the Free Software
   9 # Foundation; either version 2 of the License, or (at your option) any later
  10 # version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
  13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU General Public License along with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  19
  20
  21 use strict;
  22 use C4::Context;
  23 use C4::Output;
  24 use URI::Split qw(uri_split);
  25 use Memoize;
  26
  27 use vars qw($VERSION @ISA @EXPORT $DEBUG);
  28
  29 BEGIN {
  30         $VERSION = 3.01;
  31         require Exporter;
  32         @ISA    = qw(Exporter);
  33         @EXPORT = qw(
  34                 &slashifyDate
  35                 &DisplayISBN
  36                 &subfield_is_koha_internal_p
  37                 &GetPrinters &GetPrinter
  38                 &GetItemTypes &getitemtypeinfo
  39                 &GetCcodes
  40                 &get_itemtypeinfos_of
  41                 &getframeworks &getframeworkinfo
  42                 &getauthtypes &getauthtype
  43                 &getallthemes
  44                 &getFacets
  45                 &displayServers
  46                 &getnbpages
  47                 &get_infos_of
  48                 &get_notforloan_label_of
  49                 &getitemtypeimagedir
  50                 &getitemtypeimagesrc
  51                 &getitemtypeimagelocation
  52                 &GetAuthorisedValues
  53                 &GetAuthorisedValueCategories
  54                 &GetKohaAuthorisedValues
  55                 &GetAuthValCode
  56                 &GetNormalizedUPC
  57                 &GetNormalizedISBN
  58                 &GetNormalizedEAN
  59                 &GetNormalizedOCLCNumber
  60
  61                 $DEBUG
  62         );
  63         $DEBUG = 0;
  64 }
  65
  66 # expensive functions
  67 memoize('GetAuthorisedValues');
  68
  69 =head1 NAME
  70
  71     C4::Koha - Perl Module containing convenience functions for Koha scripts
  72
  73 =head1 SYNOPSIS
  74
  75   use C4::Koha;
  76
  77
  78 =head1 DESCRIPTION
  79
  80     Koha.pm provides many functions for Koha scripts.
  81
  82 =head1 FUNCTIONS
  83
  84 =cut
  85
  86 =head2 slashifyDate
  87
  88   $slash_date = &slashifyDate($dash_date);
  89
  90     Takes a string of the form "DD-MM-YYYY" (or anything separated by
  91     dashes), converts it to the form "YYYY/MM/DD", and returns the result.
  92
  93 =cut
  94
  95 sub slashifyDate {
  96
  97     # accepts a date of the form xx-xx-xx[xx] and returns it in the
  98     # form xx/xx/xx[xx]
  99     my @dateOut = split( '-', shift );
 100     return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
 101 }
 102
 103
 104 =head2 DisplayISBN
 105
 106     my $string = DisplayISBN( $isbn );
 107
 108 =cut
 109
 110 sub DisplayISBN {
 111     my ($isbn) = @_;
 112     if (length ($isbn)<13){
 113     my $seg1;
 114     if ( substr( $isbn, 0, 1 ) <= 7 ) {
 115         $seg1 = substr( $isbn, 0, 1 );
 116     }
 117     elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
 118         $seg1 = substr( $isbn, 0, 2 );
 119     }
 120     elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
 121         $seg1 = substr( $isbn, 0, 3 );
 122     }
 123     elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
 124         $seg1 = substr( $isbn, 0, 4 );
 125     }
 126     else {
 127         $seg1 = substr( $isbn, 0, 5 );
 128     }
 129     my $x = substr( $isbn, length($seg1) );
 130     my $seg2;
 131     if ( substr( $x, 0, 2 ) <= 19 ) {
 132
 133         # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
 134         $seg2 = substr( $x, 0, 2 );
 135     }
 136     elsif ( substr( $x, 0, 3 ) <= 699 ) {
 137         $seg2 = substr( $x, 0, 3 );
 138     }
 139     elsif ( substr( $x, 0, 4 ) <= 8399 ) {
 140         $seg2 = substr( $x, 0, 4 );
 141     }
 142     elsif ( substr( $x, 0, 5 ) <= 89999 ) {
 143         $seg2 = substr( $x, 0, 5 );
 144     }
 145     elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
 146         $seg2 = substr( $x, 0, 6 );
 147     }
 148     else {
 149         $seg2 = substr( $x, 0, 7 );
 150     }
 151     my $seg3 = substr( $x, length($seg2) );
 152     $seg3 = substr( $seg3, 0, length($seg3) - 1 );
 153     my $seg4 = substr( $x, -1, 1 );
 154     return "$seg1-$seg2-$seg3-$seg4";
 155     } else {
 156       my $seg1;
 157       $seg1 = substr( $isbn, 0, 3 );
 158       my $seg2;
 159       if ( substr( $isbn, 3, 1 ) <= 7 ) {
 160           $seg2 = substr( $isbn, 3, 1 );
 161       }
 162       elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
 163           $seg2 = substr( $isbn, 3, 2 );
 164       }
 165       elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
 166           $seg2 = substr( $isbn, 3, 3 );
 167       }
 168       elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
 169           $seg2 = substr( $isbn, 3, 4 );
 170       }
 171       else {
 172           $seg2 = substr( $isbn, 3, 5 );
 173       }
 174       my $x = substr( $isbn, length($seg2) +3);
 175       my $seg3;
 176       if ( substr( $x, 0, 2 ) <= 19 ) {
 177
 178           # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
 179           $seg3 = substr( $x, 0, 2 );
 180       }
 181       elsif ( substr( $x, 0, 3 ) <= 699 ) {
 182           $seg3 = substr( $x, 0, 3 );
 183       }
 184       elsif ( substr( $x, 0, 4 ) <= 8399 ) {
 185           $seg3 = substr( $x, 0, 4 );
 186       }
 187       elsif ( substr( $x, 0, 5 ) <= 89999 ) {
 188           $seg3 = substr( $x, 0, 5 );
 189       }
 190       elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
 191           $seg3 = substr( $x, 0, 6 );
 192       }
 193       else {
 194           $seg3 = substr( $x, 0, 7 );
 195       }
 196       my $seg4 = substr( $x, length($seg3) );
 197       $seg4 = substr( $seg4, 0, length($seg4) - 1 );
 198       my $seg5 = substr( $x, -1, 1 );
 199       return "$seg1-$seg2-$seg3-$seg4-$seg5";
 200     }
 201 }
 202
 203 # FIXME.. this should be moved to a MARC-specific module
 204 sub subfield_is_koha_internal_p ($) {
 205     my ($subfield) = @_;
 206
 207     # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
 208     # But real MARC subfields are always single-character
 209     # so it really is safer just to check the length
 210
 211     return length $subfield != 1;
 212 }
 213
 214 =head2 GetItemTypes
 215
 216   $itemtypes = &GetItemTypes();
 217
 218 Returns information about existing itemtypes.
 219
 220 build a HTML select with the following code :
 221
 222 =head3 in PERL SCRIPT
 223
 224     my $itemtypes = GetItemTypes;
 225     my @itemtypesloop;
 226     foreach my $thisitemtype (sort keys %$itemtypes) {
 227         my $selected = 1 if $thisitemtype eq $itemtype;
 228         my %row =(value => $thisitemtype,
 229                     selected => $selected,
 230                     description => $itemtypes->{$thisitemtype}->{'description'},
 231                 );
 232         push @itemtypesloop, \%row;
 233     }
 234     $template->param(itemtypeloop => \@itemtypesloop);
 235
 236 =head3 in TEMPLATE
 237
 238     <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 239         <select name="itemtype">
 240             <option value="">Default</option>
 241         <!-- TMPL_LOOP name="itemtypeloop" -->
 242             <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
 243         <!-- /TMPL_LOOP -->
 244         </select>
 245         <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 246         <input type="submit" value="OK" class="button">
 247     </form>
 248
 249 =cut
 250
 251 sub GetItemTypes {
 252
 253     # returns a reference to a hash of references to itemtypes...
 254     my %itemtypes;
 255     my $dbh   = C4::Context->dbh;
 256     my $query = qq|
 257         SELECT *
 258         FROM   itemtypes
 259     |;
 260     my $sth = $dbh->prepare($query);
 261     $sth->execute;
 262     while ( my $IT = $sth->fetchrow_hashref ) {
 263         $itemtypes{ $IT->{'itemtype'} } = $IT;
 264     }
 265     return ( \%itemtypes );
 266 }
 267
 268 sub get_itemtypeinfos_of {
 269     my @itemtypes = @_;
 270
 271     my $placeholders = join( ', ', map { '?' } @itemtypes );
 272     my $query = <<"END_SQL";
 273 SELECT itemtype,
 274        description,
 275        imageurl,
 276        notforloan
 277   FROM itemtypes
 278   WHERE itemtype IN ( $placeholders )
 279 END_SQL
 280
 281     return get_infos_of( $query, 'itemtype', undef, \@itemtypes );
 282 }
 283
 284 # this is temporary until we separate collection codes and item types
 285 sub GetCcodes {
 286     my $count = 0;
 287     my @results;
 288     my $dbh = C4::Context->dbh;
 289     my $sth =
 290       $dbh->prepare(
 291         "SELECT * FROM authorised_values ORDER BY authorised_value");
 292     $sth->execute;
 293     while ( my $data = $sth->fetchrow_hashref ) {
 294         if ( $data->{category} eq "CCODE" ) {
 295             $count++;
 296             $results[$count] = $data;
 297
 298             #warn "data: $data";
 299         }
 300     }
 301     $sth->finish;
 302     return ( $count, @results );
 303 }
 304
 305 =head2 getauthtypes
 306
 307   $authtypes = &getauthtypes();
 308
 309 Returns information about existing authtypes.
 310
 311 build a HTML select with the following code :
 312
 313 =head3 in PERL SCRIPT
 314
 315 my $authtypes = getauthtypes;
 316 my @authtypesloop;
 317 foreach my $thisauthtype (keys %$authtypes) {
 318     my $selected = 1 if $thisauthtype eq $authtype;
 319     my %row =(value => $thisauthtype,
 320                 selected => $selected,
 321                 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
 322             );
 323     push @authtypesloop, \%row;
 324 }
 325 $template->param(itemtypeloop => \@itemtypesloop);
 326
 327 =head3 in TEMPLATE
 328
 329 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 330     <select name="authtype">
 331     <!-- TMPL_LOOP name="authtypeloop" -->
 332         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
 333     <!-- /TMPL_LOOP -->
 334     </select>
 335     <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 336     <input type="submit" value="OK" class="button">
 337 </form>
 338
 339
 340 =cut
 341
 342 sub getauthtypes {
 343
 344     # returns a reference to a hash of references to authtypes...
 345     my %authtypes;
 346     my $dbh = C4::Context->dbh;
 347     my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
 348     $sth->execute;
 349     while ( my $IT = $sth->fetchrow_hashref ) {
 350         $authtypes{ $IT->{'authtypecode'} } = $IT;
 351     }
 352     return ( \%authtypes );
 353 }
 354
 355 sub getauthtype {
 356     my ($authtypecode) = @_;
 357
 358     # returns a reference to a hash of references to authtypes...
 359     my %authtypes;
 360     my $dbh = C4::Context->dbh;
 361     my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
 362     $sth->execute($authtypecode);
 363     my $res = $sth->fetchrow_hashref;
 364     return $res;
 365 }
 366
 367 =head2 getframework
 368
 369   $frameworks = &getframework();
 370
 371 Returns information about existing frameworks
 372
 373 build a HTML select with the following code :
 374
 375 =head3 in PERL SCRIPT
 376
 377 my $frameworks = frameworks();
 378 my @frameworkloop;
 379 foreach my $thisframework (keys %$frameworks) {
 380     my $selected = 1 if $thisframework eq $frameworkcode;
 381     my %row =(value => $thisframework,
 382                 selected => $selected,
 383                 description => $frameworks->{$thisframework}->{'frameworktext'},
 384             );
 385     push @frameworksloop, \%row;
 386 }
 387 $template->param(frameworkloop => \@frameworksloop);
 388
 389 =head3 in TEMPLATE
 390
 391 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
 392     <select name="frameworkcode">
 393         <option value="">Default</option>
 394     <!-- TMPL_LOOP name="frameworkloop" -->
 395         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
 396     <!-- /TMPL_LOOP -->
 397     </select>
 398     <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
 399     <input type="submit" value="OK" class="button">
 400 </form>
 401
 402
 403 =cut
 404
 405 sub getframeworks {
 406
 407     # returns a reference to a hash of references to branches...
 408     my %itemtypes;
 409     my $dbh = C4::Context->dbh;
 410     my $sth = $dbh->prepare("select * from biblio_framework");
 411     $sth->execute;
 412     while ( my $IT = $sth->fetchrow_hashref ) {
 413         $itemtypes{ $IT->{'frameworkcode'} } = $IT;
 414     }
 415     return ( \%itemtypes );
 416 }
 417
 418 =head2 getframeworkinfo
 419
 420   $frameworkinfo = &getframeworkinfo($frameworkcode);
 421
 422 Returns information about an frameworkcode.
 423
 424 =cut
 425
 426 sub getframeworkinfo {
 427     my ($frameworkcode) = @_;
 428     my $dbh             = C4::Context->dbh;
 429     my $sth             =
 430       $dbh->prepare("select * from biblio_framework where frameworkcode=?");
 431     $sth->execute($frameworkcode);
 432     my $res = $sth->fetchrow_hashref;
 433     return $res;
 434 }
 435
 436 =head2 getitemtypeinfo
 437
 438   $itemtype = &getitemtype($itemtype);
 439
 440 Returns information about an itemtype.
 441
 442 =cut
 443
 444 sub getitemtypeinfo {
 445     my ($itemtype) = @_;
 446     my $dbh        = C4::Context->dbh;
 447     my $sth        = $dbh->prepare("select * from itemtypes where itemtype=?");
 448     $sth->execute($itemtype);
 449     my $res = $sth->fetchrow_hashref;
 450
 451     $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} );
 452
 453     return $res;
 454 }
 455
 456 =head2 getitemtypeimagedir
 457
 458 =over
 459
 460 =item 4
 461
 462   my $directory = getitemtypeimagedir( 'opac' );
 463
 464 pass in 'opac' or 'intranet'. Defaults to 'opac'.
 465
 466 returns the full path to the appropriate directory containing images.
 467
 468 =back
 469
 470 =cut
 471
 472 sub getitemtypeimagedir {
 473         my $src = shift || 'opac';
 474         if ($src eq 'intranet') {
 475                 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
 476         } else {
 477                 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
 478         }
 479 }
 480
 481 sub getitemtypeimagesrc {
 482         my $src = shift || 'opac';
 483         if ($src eq 'intranet') {
 484                 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
 485         } else {
 486                 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
 487         }
 488 }
 489
 490 sub getitemtypeimagelocation($$) {
 491         my ( $src, $image ) = @_;
 492
 493         return '' if ( !$image );
 494
 495         my $scheme = ( uri_split( $image ) )[0];
 496
 497         return $image if ( $scheme );
 498
 499         return getitemtypeimagesrc( $src ) . '/' . $image;
 500 }
 501
 502 =head3 _getImagesFromDirectory
 503
 504   Find all of the image files in a directory in the filesystem
 505
 506   parameters:
 507     a directory name
 508
 509   returns: a list of images in that directory.
 510
 511   Notes: this does not traverse into subdirectories. See
 512       _getSubdirectoryNames for help with that.
 513     Images are assumed to be files with .gif or .png file extensions.
 514     The image names returned do not have the directory name on them.
 515
 516 =cut
 517
 518 sub _getImagesFromDirectory {
 519     my $directoryname = shift;
 520     return unless defined $directoryname;
 521     return unless -d $directoryname;
 522
 523     if ( opendir ( my $dh, $directoryname ) ) {
 524         my @images = grep { /\.(gif|png)$/i } readdir( $dh );
 525         closedir $dh;
 526         return @images;
 527     } else {
 528         warn "unable to opendir $directoryname: $!";
 529         return;
 530     }
 531 }
 532
 533 =head3 _getSubdirectoryNames
 534
 535   Find all of the directories in a directory in the filesystem
 536
 537   parameters:
 538     a directory name
 539
 540   returns: a list of subdirectories in that directory.
 541
 542   Notes: this does not traverse into subdirectories. Only the first
 543       level of subdirectories are returned.
 544     The directory names returned don't have the parent directory name
 545       on them.
 546
 547 =cut
 548
 549 sub _getSubdirectoryNames {
 550     my $directoryname = shift;
 551     return unless defined $directoryname;
 552     return unless -d $directoryname;
 553
 554     if ( opendir ( my $dh, $directoryname ) ) {
 555         my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh );
 556         closedir $dh;
 557         return @directories;
 558     } else {
 559         warn "unable to opendir $directoryname: $!";
 560         return;
 561     }
 562 }
 563
 564 =head3 getImageSets
 565
 566   returns: a listref of hashrefs. Each hash represents another collection of images.
 567            { imagesetname => 'npl', # the name of the image set (npl is the original one)
 568              images => listref of image hashrefs
 569            }
 570
 571     each image is represented by a hashref like this:
 572       { KohaImage     => 'npl/image.gif',
 573         StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
 574         OpacImageURL  => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
 575         checked       => 0 or 1: was this the image passed to this method?
 576                          Note: I'd like to remove this somehow.
 577       }
 578
 579 =cut
 580
 581 sub getImageSets {
 582     my %params = @_;
 583     my $checked = $params{'checked'} || '';
 584
 585     my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'),
 586                              url        => getitemtypeimagesrc('intranet'),
 587                         },
 588                   opac => { filesystem => getitemtypeimagedir('opac'),
 589                              url       => getitemtypeimagesrc('opac'),
 590                         }
 591                   };
 592
 593     my @imagesets = (); # list of hasrefs of image set data to pass to template
 594     my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} );
 595
 596     foreach my $imagesubdir ( @subdirectories ) {
 597         my @imagelist     = (); # hashrefs of image info
 598         my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) );
 599         foreach my $thisimage ( @imagenames ) {
 600             push( @imagelist,
 601                   { KohaImage     => "$imagesubdir/$thisimage",
 602                     StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ),
 603                     OpacImageUrl  => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ),
 604                     checked       => "$imagesubdir/$thisimage" eq $checked ? 1 : 0,
 605                }
 606              );
 607         }
 608         push @imagesets, { imagesetname => $imagesubdir,
 609                            images       => \@imagelist };
 610
 611     }
 612     return \@imagesets;
 613 }
 614
 615 =head2 GetPrinters
 616
 617   $printers = &GetPrinters();
 618   @queues = keys %$printers;
 619
 620 Returns information about existing printer queues.
 621
 622 C<$printers> is a reference-to-hash whose keys are the print queues
 623 defined in the printers table of the Koha database. The values are
 624 references-to-hash, whose keys are the fields in the printers table.
 625
 626 =cut
 627
 628 sub GetPrinters {
 629     my %printers;
 630     my $dbh = C4::Context->dbh;
 631     my $sth = $dbh->prepare("select * from printers");
 632     $sth->execute;
 633     while ( my $printer = $sth->fetchrow_hashref ) {
 634         $printers{ $printer->{'printqueue'} } = $printer;
 635     }
 636     return ( \%printers );
 637 }
 638
 639 =head2 GetPrinter
 640
 641 $printer = GetPrinter( $query, $printers );
 642
 643 =cut
 644
 645 sub GetPrinter ($$) {
 646     my ( $query, $printers ) = @_;    # get printer for this query from printers
 647     my $printer = $query->param('printer');
 648     my %cookie = $query->cookie('userenv');
 649     ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
 650     ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
 651     return $printer;
 652 }
 653
 654 =head2 getnbpages
 655
 656 Returns the number of pages to display in a pagination bar, given the number
 657 of items and the number of items per page.
 658
 659 =cut
 660
 661 sub getnbpages {
 662     my ( $nb_items, $nb_items_per_page ) = @_;
 663
 664     return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
 665 }
 666
 667 =head2 getallthemes
 668
 669   (@themes) = &getallthemes('opac');
 670   (@themes) = &getallthemes('intranet');
 671
 672 Returns an array of all available themes.
 673
 674 =cut
 675
 676 sub getallthemes {
 677     my $type = shift;
 678     my $htdocs;
 679     my @themes;
 680     if ( $type eq 'intranet' ) {
 681         $htdocs = C4::Context->config('intrahtdocs');
 682     }
 683     else {
 684         $htdocs = C4::Context->config('opachtdocs');
 685     }
 686     opendir D, "$htdocs";
 687     my @dirlist = readdir D;
 688     foreach my $directory (@dirlist) {
 689         -d "$htdocs/$directory/en" and push @themes, $directory;
 690     }
 691     return @themes;
 692 }
 693
 694 sub getFacets {
 695     my $facets;
 696     if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
 697         $facets = [
 698             {
 699                 link_value  => 'su-to',
 700                 label_value => 'Topics',
 701                 tags        =>
 702                   [ '600', '601', '602', '603', '604', '605', '606', '610' ],
 703                 subfield => 'a',
 704             },
 705             {
 706                 link_value  => 'su-geo',
 707                 label_value => 'Places',
 708                 tags        => ['651'],
 709                 subfield    => 'a',
 710             },
 711             {
 712                 link_value  => 'su-ut',
 713                 label_value => 'Titles',
 714                 tags        => [ '500', '501', '502', '503', '504', ],
 715                 subfield    => 'a',
 716             },
 717             {
 718                 link_value  => 'au',
 719                 label_value => 'Authors',
 720                 tags        => [ '700', '701', '702', ],
 721                 subfield    => 'a',
 722             },
 723             {
 724                 link_value  => 'se',
 725                 label_value => 'Series',
 726                 tags        => ['225'],
 727                 subfield    => 'a',
 728             },
 729             ];
 730
 731             my $library_facet;
 732
 733             $library_facet = {
 734                 link_value  => 'branch',
 735                 label_value => 'Libraries',
 736                 tags        => [ '995', ],
 737                 subfield    => 'b',
 738                 expanded    => '1',
 739             };
 740             push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 741     }
 742     else {
 743         $facets = [
 744             {
 745                 link_value  => 'su-to',
 746                 label_value => 'Topics',
 747                 tags        => ['650'],
 748                 subfield    => 'a',
 749             },
 750
 751             #        {
 752             #        link_value => 'su-na',
 753             #        label_value => 'People and Organizations',
 754             #        tags => ['600', '610', '611'],
 755             #        subfield => 'a',
 756             #        },
 757             {
 758                 link_value  => 'su-geo',
 759                 label_value => 'Places',
 760                 tags        => ['651'],
 761                 subfield    => 'a',
 762             },
 763             {
 764                 link_value  => 'su-ut',
 765                 label_value => 'Titles',
 766                 tags        => ['630'],
 767                 subfield    => 'a',
 768             },
 769             {
 770                 link_value  => 'au',
 771                 label_value => 'Authors',
 772                 tags        => [ '100', '110', '700', ],
 773                 subfield    => 'a',
 774             },
 775             {
 776                 link_value  => 'se',
 777                 label_value => 'Series',
 778                 tags        => [ '440', '490', ],
 779                 subfield    => 'a',
 780             },
 781             ];
 782             my $library_facet;
 783             $library_facet = {
 784                 link_value  => 'branch',
 785                 label_value => 'Libraries',
 786                 tags        => [ '952', ],
 787                 subfield    => 'b',
 788                 expanded    => '1',
 789             };
 790             push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
 791     }
 792     return $facets;
 793 }
 794
 795 =head2 get_infos_of
 796
 797 Return a href where a key is associated to a href. You give a query,
 798 the name of the key among the fields returned by the query. If you
 799 also give as third argument the name of the value, the function
 800 returns a href of scalar. The optional 4th argument is an arrayref of
 801 items passed to the C<execute()> call. It is designed to bind
 802 parameters to any placeholders in your SQL.
 803
 804   my $query = '
 805 SELECT itemnumber,
 806        notforloan,
 807        barcode
 808   FROM items
 809 ';
 810
 811   # generic href of any information on the item, href of href.
 812   my $iteminfos_of = get_infos_of($query, 'itemnumber');
 813   print $iteminfos_of->{$itemnumber}{barcode};
 814
 815   # specific information, href of scalar
 816   my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
 817   print $barcode_of_item->{$itemnumber};
 818
 819 =cut
 820
 821 sub get_infos_of {
 822     my ( $query, $key_name, $value_name, $bind_params ) = @_;
 823
 824     my $dbh = C4::Context->dbh;
 825
 826     my $sth = $dbh->prepare($query);
 827     $sth->execute( @$bind_params );
 828
 829     my %infos_of;
 830     while ( my $row = $sth->fetchrow_hashref ) {
 831         if ( defined $value_name ) {
 832             $infos_of{ $row->{$key_name} } = $row->{$value_name};
 833         }
 834         else {
 835             $infos_of{ $row->{$key_name} } = $row;
 836         }
 837     }
 838     $sth->finish;
 839
 840     return \%infos_of;
 841 }
 842
 843 =head2 get_notforloan_label_of
 844
 845   my $notforloan_label_of = get_notforloan_label_of();
 846
 847 Each authorised value of notforloan (information available in items and
 848 itemtypes) is link to a single label.
 849
 850 Returns a href where keys are authorised values and values are corresponding
 851 labels.
 852
 853   foreach my $authorised_value (keys %{$notforloan_label_of}) {
 854     printf(
 855         "authorised_value: %s => %s\n",
 856         $authorised_value,
 857         $notforloan_label_of->{$authorised_value}
 858     );
 859   }
 860
 861 =cut
 862
 863 # FIXME - why not use GetAuthorisedValues ??
 864 #
 865 sub get_notforloan_label_of {
 866     my $dbh = C4::Context->dbh;
 867
 868     my $query = '
 869 SELECT authorised_value
 870   FROM marc_subfield_structure
 871   WHERE kohafield = \'items.notforloan\'
 872   LIMIT 0, 1
 873 ';
 874     my $sth = $dbh->prepare($query);
 875     $sth->execute();
 876     my ($statuscode) = $sth->fetchrow_array();
 877
 878     $query = '
 879 SELECT lib,
 880        authorised_value
 881   FROM authorised_values
 882   WHERE category = ?
 883 ';
 884     $sth = $dbh->prepare($query);
 885     $sth->execute($statuscode);
 886     my %notforloan_label_of;
 887     while ( my $row = $sth->fetchrow_hashref ) {
 888         $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
 889     }
 890     $sth->finish;
 891
 892     return \%notforloan_label_of;
 893 }
 894
 895 =head2 displayServers
 896
 897 =over 4
 898
 899 my $servers = displayServers();
 900
 901 my $servers = displayServers( $position );
 902
 903 my $servers = displayServers( $position, $type );
 904
 905 =back
 906
 907 displayServers returns a listref of hashrefs, each containing
 908 information about available z3950 servers. Each hashref has a format
 909 like:
 910
 911     {
 912       'checked'    => 'checked',
 913       'encoding'   => 'MARC-8'
 914       'icon'       => undef,
 915       'id'         => 'LIBRARY OF CONGRESS',
 916       'label'      => '',
 917       'name'       => 'server',
 918       'opensearch' => '',
 919       'value'      => 'z3950.loc.gov:7090/',
 920       'zed'        => 1,
 921     },
 922
 923
 924 =cut
 925
 926 sub displayServers {
 927     my ( $position, $type ) = @_;
 928     my $dbh = C4::Context->dbh;
 929
 930     my $strsth = 'SELECT * FROM z3950servers';
 931     my @where_clauses;
 932     my @bind_params;
 933
 934     if ($position) {
 935         push @bind_params,   $position;
 936         push @where_clauses, ' position = ? ';
 937     }
 938
 939     if ($type) {
 940         push @bind_params,   $type;
 941         push @where_clauses, ' type = ? ';
 942     }
 943
 944     # reassemble where clause from where clause pieces
 945     if (@where_clauses) {
 946         $strsth .= ' WHERE ' . join( ' AND ', @where_clauses );
 947     }
 948
 949     my $rq = $dbh->prepare($strsth);
 950     $rq->execute(@bind_params);
 951     my @primaryserverloop;
 952
 953     while ( my $data = $rq->fetchrow_hashref ) {
 954         push @primaryserverloop,
 955           { label    => $data->{description},
 956             id       => $data->{name},
 957             name     => "server",
 958             value    => $data->{host} . ":" . $data->{port} . "/" . $data->{database},
 959             encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ),
 960             checked  => "checked",
 961             icon     => $data->{icon},
 962             zed        => $data->{type} eq 'zed',
 963             opensearch => $data->{type} eq 'opensearch'
 964           };
 965     }
 966     return \@primaryserverloop;
 967 }
 968
 969 sub displaySecondaryServers {
 970
 971 #       my $secondary_servers_loop = [
 972 #               { inner_sup_servers_loop => [
 973 #               {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
 974 #               {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
 975 #               {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
 976 #               {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
 977 #       ],
 978 #       },
 979 #       ];
 980     return;    #$secondary_servers_loop;
 981 }
 982
 983 =head2 GetAuthValCode
 984
 985 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
 986
 987 =cut
 988
 989 sub GetAuthValCode {
 990         my ($kohafield,$fwcode) = @_;
 991         my $dbh = C4::Context->dbh;
 992         $fwcode='' unless $fwcode;
 993         my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
 994         $sth->execute($kohafield,$fwcode);
 995         my ($authvalcode) = $sth->fetchrow_array;
 996         return $authvalcode;
 997 }
 998
 999 =head2 GetAuthorisedValues
1000
1001 $authvalues = GetAuthorisedValues([$category], [$selected]);
1002
1003 This function returns all authorised values from the'authosied_value' table in a reference to array of hashrefs.
1004
1005 C<$category> returns authorised values for just one category (optional).
1006
1007 =cut
1008
1009 sub GetAuthorisedValues {
1010     my ($category,$selected) = @_;
1011         my @results;
1012     my $dbh      = C4::Context->dbh;
1013     my $query    = "SELECT * FROM authorised_values";
1014     $query .= " WHERE category = '" . $category . "'" if $category;
1015
1016     my $sth = $dbh->prepare($query);
1017     $sth->execute;
1018         while (my $data=$sth->fetchrow_hashref) {
1019                 if ($selected eq $data->{'authorised_value'} ) {
1020                         $data->{'selected'} = 1;
1021                 }
1022         push @results, $data;
1023         }
1024     #my $data = $sth->fetchall_arrayref({});
1025     return \@results; #$data;
1026 }
1027
1028 =head2 GetAuthorisedValueCategories
1029
1030 $auth_categories = GetAuthorisedValueCategories();
1031
1032 Return an arrayref of all of the available authorised
1033 value categories.
1034
1035 =cut
1036
1037 sub GetAuthorisedValueCategories {
1038     my $dbh = C4::Context->dbh;
1039     my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category");
1040     $sth->execute;
1041     my @results;
1042     while (my $category = $sth->fetchrow_array) {
1043         push @results, $category;
1044     }
1045     return \@results;
1046 }
1047
1048 =head2 GetKohaAuthorisedValues
1049
1050         Takes $kohafield, $fwcode as parameters.
1051         Returns hashref of Code => description
1052         Returns undef
1053           if no authorised value category is defined for the kohafield.
1054
1055 =cut
1056
1057 sub GetKohaAuthorisedValues {
1058   my ($kohafield,$fwcode,$codedvalue) = @_;
1059   $fwcode='' unless $fwcode;
1060   my %values;
1061   my $dbh = C4::Context->dbh;
1062   my $avcode = GetAuthValCode($kohafield,$fwcode);
1063   if ($avcode) {
1064         my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
1065         $sth->execute($avcode);
1066         while ( my ($val, $lib) = $sth->fetchrow_array ) {
1067                 $values{$val}= $lib;
1068         }
1069         return \%values;
1070   } else {
1071         return undef;
1072   }
1073 }
1074
1075 =head2 display_marc_indicators
1076
1077 =over 4
1078
1079 # field is a MARC::Field object
1080 my $display_form = C4::Koha::display_marc_indicators($field);
1081
1082 =back
1083
1084 Generate a display form of the indicators of a variable
1085 MARC field, replacing any blanks with '#'.
1086
1087 =cut
1088
1089 sub display_marc_indicators {
1090     my $field = shift;
1091     my $indicators = '';
1092     if ($field->tag() >= 10) {
1093         $indicators = $field->indicator(1) . $field->indicator(2);
1094         $indicators =~ s/ /#/g;
1095     }
1096     return $indicators;
1097 }
1098
1099 sub GetNormalizedUPC {
1100  my ($record,$marcflavour) = @_;
1101     my (@fields,$upc);
1102
1103     if ($marcflavour eq 'MARC21') {
1104         @fields = $record->field('024');
1105         foreach my $field (@fields) {
1106             my $indicator = $field->indicator(1);
1107             my $upc = _normalize_match_point($field->subfield('a'));
1108             if ($indicator == 1 and $upc ne '') {
1109                 return $upc;
1110             }
1111         }
1112     }
1113     else { # assume unimarc if not marc21
1114         @fields = $record->field('072');
1115         foreach my $field (@fields) {
1116             my $upc = _normalize_match_point($field->subfield('a'));
1117             if ($upc ne '') {
1118                 return $upc;
1119             }
1120         }
1121     }
1122 }
1123
1124 # Normalizes and returns the first valid ISBN found in the record
1125 sub GetNormalizedISBN {
1126     my ($isbn,$record,$marcflavour) = @_;
1127     my @fields;
1128     if ($isbn) {
1129         return _isbn_cleanup($isbn);
1130     }
1131     return undef unless $record;
1132
1133     if ($marcflavour eq 'MARC21') {
1134         @fields = $record->field('020');
1135         foreach my $field (@fields) {
1136             $isbn = $field->subfield('a');
1137             if ($isbn) {
1138                 return _isbn_cleanup($isbn);
1139             } else {
1140                 return undef;
1141             }
1142         }
1143     }
1144     else { # assume unimarc if not marc21
1145         @fields = $record->field('010');
1146         foreach my $field (@fields) {
1147             my $isbn = $field->subfield('a');
1148             if ($isbn) {
1149                 return _isbn_cleanup($isbn);
1150             } else {
1151                 return undef;
1152             }
1153         }
1154     }
1155
1156 }
1157
1158 sub GetNormalizedEAN {
1159     my ($record,$marcflavour) = @_;
1160     my (@fields,$ean);
1161
1162     if ($marcflavour eq 'MARC21') {
1163         @fields = $record->field('024');
1164         foreach my $field (@fields) {
1165             my $indicator = $field->indicator(1);
1166             $ean = _normalize_match_point($field->subfield('a'));
1167             if ($indicator == 3 and $ean ne '') {
1168                 return $ean;
1169             }
1170         }
1171     }
1172     else { # assume unimarc if not marc21
1173         @fields = $record->field('073');
1174         foreach my $field (@fields) {
1175             $ean = _normalize_match_point($field->subfield('a'));
1176             if ($ean ne '') {
1177                 return $ean;
1178             }
1179         }
1180     }
1181 }
1182 sub GetNormalizedOCLCNumber {
1183     my ($record,$marcflavour) = @_;
1184     my (@fields,$oclc);
1185
1186     if ($marcflavour eq 'MARC21') {
1187         @fields = $record->field('035');
1188         foreach my $field (@fields) {
1189             $oclc = $field->subfield('a');
1190             if ($oclc =~ /OCoLC/) {
1191                 $oclc =~ s/\(OCoLC\)//;
1192                 return $oclc;
1193             } else {
1194                 return undef;
1195             }
1196         }
1197     }
1198     else { # TODO: add UNIMARC fields
1199     }
1200 }
1201
1202 sub _normalize_match_point {
1203     my $match_point = shift;
1204     (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/;
1205     $normalized_match_point =~ s/-//g;
1206
1207     return $normalized_match_point;
1208 }
1209
1210 sub _isbn_cleanup ($) {
1211     my $normalized_isbn = shift;
1212     $normalized_isbn =~ s/-//g;
1213     $normalized_isbn =~/([0-9x]{1,})/i;
1214     $normalized_isbn = $1;
1215     if (
1216         $normalized_isbn =~ /\b(\d{13})\b/ or
1217         $normalized_isbn =~ /\b(\d{12})\b/i or
1218         $normalized_isbn =~ /\b(\d{10})\b/ or
1219         $normalized_isbn =~ /\b(\d{9}X)\b/i
1220     ) {
1221         return $1;
1222     }
1223     return undef;
1224 }
1225
1226 1;
1227
1228 __END__
1229
1230 =head1 AUTHOR
1231
1232 Koha Team
1233
1234 =cut