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