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