3 # Copyright 2000-2002 Katipo Communications
5 # This file is part of Koha.
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
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.
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
24 use vars qw($VERSION @ISA @EXPORT $DEBUG);
33 &subfield_is_koha_internal_p
34 &GetPrinters &GetPrinter
35 &GetItemTypes &getitemtypeinfo
38 &getframeworks &getframeworkinfo
39 &getauthtypes &getauthtype
44 &getitemtypeimagesrcfromurl
46 &get_notforloan_label_of
50 &GetKohaAuthorisedValues
52 &GetManagedTagSubfields
61 C4::Koha - Perl Module containing convenience functions for Koha scripts
70 Koha.pm provides many functions for Koha scripts.
79 $slash_date = &slashifyDate($dash_date);
81 Takes a string of the form "DD-MM-YYYY" (or anything separated by
82 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
88 # accepts a date of the form xx-xx-xx[xx] and returns it in the
90 my @dateOut = split( '-', shift );
91 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
97 my $string = DisplayISBN( $isbn );
103 if (length ($isbn)<13){
105 if ( substr( $isbn, 0, 1 ) <= 7 ) {
106 $seg1 = substr( $isbn, 0, 1 );
108 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
109 $seg1 = substr( $isbn, 0, 2 );
111 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
112 $seg1 = substr( $isbn, 0, 3 );
114 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
115 $seg1 = substr( $isbn, 0, 4 );
118 $seg1 = substr( $isbn, 0, 5 );
120 my $x = substr( $isbn, length($seg1) );
122 if ( substr( $x, 0, 2 ) <= 19 ) {
124 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
125 $seg2 = substr( $x, 0, 2 );
127 elsif ( substr( $x, 0, 3 ) <= 699 ) {
128 $seg2 = substr( $x, 0, 3 );
130 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
131 $seg2 = substr( $x, 0, 4 );
133 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
134 $seg2 = substr( $x, 0, 5 );
136 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
137 $seg2 = substr( $x, 0, 6 );
140 $seg2 = substr( $x, 0, 7 );
142 my $seg3 = substr( $x, length($seg2) );
143 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
144 my $seg4 = substr( $x, -1, 1 );
145 return "$seg1-$seg2-$seg3-$seg4";
148 $seg1 = substr( $isbn, 0, 3 );
150 if ( substr( $isbn, 3, 1 ) <= 7 ) {
151 $seg2 = substr( $isbn, 3, 1 );
153 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
154 $seg2 = substr( $isbn, 3, 2 );
156 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
157 $seg2 = substr( $isbn, 3, 3 );
159 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
160 $seg2 = substr( $isbn, 3, 4 );
163 $seg2 = substr( $isbn, 3, 5 );
165 my $x = substr( $isbn, length($seg2) +3);
167 if ( substr( $x, 0, 2 ) <= 19 ) {
169 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
170 $seg3 = substr( $x, 0, 2 );
172 elsif ( substr( $x, 0, 3 ) <= 699 ) {
173 $seg3 = substr( $x, 0, 3 );
175 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
176 $seg3 = substr( $x, 0, 4 );
178 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
179 $seg3 = substr( $x, 0, 5 );
181 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
182 $seg3 = substr( $x, 0, 6 );
185 $seg3 = substr( $x, 0, 7 );
187 my $seg4 = substr( $x, length($seg3) );
188 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
189 my $seg5 = substr( $x, -1, 1 );
190 return "$seg1-$seg2-$seg3-$seg4-$seg5";
194 # FIXME.. this should be moved to a MARC-specific module
195 sub subfield_is_koha_internal_p ($) {
198 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
199 # But real MARC subfields are always single-character
200 # so it really is safer just to check the length
202 return length $subfield != 1;
207 $itemtypes = &GetItemTypes();
209 Returns information about existing itemtypes.
211 build a HTML select with the following code :
213 =head3 in PERL SCRIPT
215 my $itemtypes = GetItemTypes;
217 foreach my $thisitemtype (sort keys %$itemtypes) {
218 my $selected = 1 if $thisitemtype eq $itemtype;
219 my %row =(value => $thisitemtype,
220 selected => $selected,
221 description => $itemtypes->{$thisitemtype}->{'description'},
223 push @itemtypesloop, \%row;
225 $template->param(itemtypeloop => \@itemtypesloop);
229 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
230 <select name="itemtype">
231 <option value="">Default</option>
232 <!-- TMPL_LOOP name="itemtypeloop" -->
233 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
236 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
237 <input type="submit" value="OK" class="button">
244 # returns a reference to a hash of references to branches...
246 my $dbh = C4::Context->dbh;
251 my $sth = $dbh->prepare($query);
253 while ( my $IT = $sth->fetchrow_hashref ) {
254 $itemtypes{ $IT->{'itemtype'} } = $IT;
256 return ( \%itemtypes );
259 sub get_itemtypeinfos_of {
268 WHERE itemtype IN (' . join( ',', map( { "'" . $_ . "'" } @itemtypes ) ) . ')
271 return get_infos_of( $query, 'itemtype' );
274 # this is temporary until we separate collection codes and item types
278 my $dbh = C4::Context->dbh;
281 "SELECT * FROM authorised_values ORDER BY authorised_value");
283 while ( my $data = $sth->fetchrow_hashref ) {
284 if ( $data->{category} eq "CCODE" ) {
286 $results[$count] = $data;
292 return ( $count, @results );
297 $authtypes = &getauthtypes();
299 Returns information about existing authtypes.
301 build a HTML select with the following code :
303 =head3 in PERL SCRIPT
305 my $authtypes = getauthtypes;
307 foreach my $thisauthtype (keys %$authtypes) {
308 my $selected = 1 if $thisauthtype eq $authtype;
309 my %row =(value => $thisauthtype,
310 selected => $selected,
311 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
313 push @authtypesloop, \%row;
315 $template->param(itemtypeloop => \@itemtypesloop);
319 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
320 <select name="authtype">
321 <!-- TMPL_LOOP name="authtypeloop" -->
322 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
325 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
326 <input type="submit" value="OK" class="button">
334 # returns a reference to a hash of references to authtypes...
336 my $dbh = C4::Context->dbh;
337 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
339 while ( my $IT = $sth->fetchrow_hashref ) {
340 $authtypes{ $IT->{'authtypecode'} } = $IT;
342 return ( \%authtypes );
346 my ($authtypecode) = @_;
348 # returns a reference to a hash of references to authtypes...
350 my $dbh = C4::Context->dbh;
351 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
352 $sth->execute($authtypecode);
353 my $res = $sth->fetchrow_hashref;
359 $frameworks = &getframework();
361 Returns information about existing frameworks
363 build a HTML select with the following code :
365 =head3 in PERL SCRIPT
367 my $frameworks = frameworks();
369 foreach my $thisframework (keys %$frameworks) {
370 my $selected = 1 if $thisframework eq $frameworkcode;
371 my %row =(value => $thisframework,
372 selected => $selected,
373 description => $frameworks->{$thisframework}->{'frameworktext'},
375 push @frameworksloop, \%row;
377 $template->param(frameworkloop => \@frameworksloop);
381 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
382 <select name="frameworkcode">
383 <option value="">Default</option>
384 <!-- TMPL_LOOP name="frameworkloop" -->
385 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
388 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
389 <input type="submit" value="OK" class="button">
397 # returns a reference to a hash of references to branches...
399 my $dbh = C4::Context->dbh;
400 my $sth = $dbh->prepare("select * from biblio_framework");
402 while ( my $IT = $sth->fetchrow_hashref ) {
403 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
405 return ( \%itemtypes );
408 =head2 getframeworkinfo
410 $frameworkinfo = &getframeworkinfo($frameworkcode);
412 Returns information about an frameworkcode.
416 sub getframeworkinfo {
417 my ($frameworkcode) = @_;
418 my $dbh = C4::Context->dbh;
420 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
421 $sth->execute($frameworkcode);
422 my $res = $sth->fetchrow_hashref;
426 =head2 getitemtypeinfo
428 $itemtype = &getitemtype($itemtype);
430 Returns information about an itemtype.
434 sub getitemtypeinfo {
436 my $dbh = C4::Context->dbh;
437 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
438 $sth->execute($itemtype);
439 my $res = $sth->fetchrow_hashref;
441 $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
446 sub getitemtypeimagesrcfromurl {
449 if ( defined $imageurl and $imageurl !~ m/^http/ ) {
450 $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
456 sub getitemtypeimagedir {
458 if ($src eq 'intranet') {
459 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
462 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
466 sub getitemtypeimagesrc {
468 if ($src eq 'intranet') {
469 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
472 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
478 $printers = &GetPrinters();
479 @queues = keys %$printers;
481 Returns information about existing printer queues.
483 C<$printers> is a reference-to-hash whose keys are the print queues
484 defined in the printers table of the Koha database. The values are
485 references-to-hash, whose keys are the fields in the printers table.
491 my $dbh = C4::Context->dbh;
492 my $sth = $dbh->prepare("select * from printers");
494 while ( my $printer = $sth->fetchrow_hashref ) {
495 $printers{ $printer->{'printqueue'} } = $printer;
497 return ( \%printers );
502 $printer = GetPrinter( $query, $printers );
506 sub GetPrinter ($$) {
507 my ( $query, $printers ) = @_; # get printer for this query from printers
508 my $printer = $query->param('printer');
509 my %cookie = $query->cookie('userenv');
510 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
511 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
517 Returns the number of pages to display in a pagination bar, given the number
518 of items and the number of items per page.
523 my ( $nb_items, $nb_items_per_page ) = @_;
525 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
530 (@themes) = &getallthemes('opac');
531 (@themes) = &getallthemes('intranet');
533 Returns an array of all available themes.
541 if ( $type eq 'intranet' ) {
542 $htdocs = C4::Context->config('intrahtdocs');
545 $htdocs = C4::Context->config('opachtdocs');
547 opendir D, "$htdocs";
548 my @dirlist = readdir D;
549 foreach my $directory (@dirlist) {
550 -d "$htdocs/$directory/en" and push @themes, $directory;
557 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
560 link_value => 'su-to',
561 label_value => 'Topics',
563 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
567 link_value => 'su-geo',
568 label_value => 'Places',
573 link_value => 'su-ut',
574 label_value => 'Titles',
575 tags => [ '500', '501', '502', '503', '504', ],
580 label_value => 'Authors',
581 tags => [ '700', '701', '702', ],
586 label_value => 'Series',
595 link_value => 'branch',
596 label_value => 'Libraries',
601 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
606 link_value => 'su-to',
607 label_value => 'Topics',
613 # link_value => 'su-na',
614 # label_value => 'People and Organizations',
615 # tags => ['600', '610', '611'],
619 link_value => 'su-geo',
620 label_value => 'Places',
625 link_value => 'su-ut',
626 label_value => 'Titles',
632 label_value => 'Authors',
633 tags => [ '100', '110', '700', ],
638 label_value => 'Series',
639 tags => [ '440', '490', ],
645 link_value => 'branch',
646 label_value => 'Libraries',
651 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
658 Return a href where a key is associated to a href. You give a query, the
659 name of the key among the fields returned by the query. If you also give as
660 third argument the name of the value, the function returns a href of scalar.
669 # generic href of any information on the item, href of href.
670 my $iteminfos_of = get_infos_of($query, 'itemnumber');
671 print $iteminfos_of->{$itemnumber}{barcode};
673 # specific information, href of scalar
674 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
675 print $barcode_of_item->{$itemnumber};
680 my ( $query, $key_name, $value_name ) = @_;
682 my $dbh = C4::Context->dbh;
684 my $sth = $dbh->prepare($query);
688 while ( my $row = $sth->fetchrow_hashref ) {
689 if ( defined $value_name ) {
690 $infos_of{ $row->{$key_name} } = $row->{$value_name};
693 $infos_of{ $row->{$key_name} } = $row;
701 =head2 get_notforloan_label_of
703 my $notforloan_label_of = get_notforloan_label_of();
705 Each authorised value of notforloan (information available in items and
706 itemtypes) is link to a single label.
708 Returns a href where keys are authorised values and values are corresponding
711 foreach my $authorised_value (keys %{$notforloan_label_of}) {
713 "authorised_value: %s => %s\n",
715 $notforloan_label_of->{$authorised_value}
721 # FIXME - why not use GetAuthorisedValues ??
723 sub get_notforloan_label_of {
724 my $dbh = C4::Context->dbh;
727 SELECT authorised_value
728 FROM marc_subfield_structure
729 WHERE kohafield = \'items.notforloan\'
732 my $sth = $dbh->prepare($query);
734 my ($statuscode) = $sth->fetchrow_array();
739 FROM authorised_values
742 $sth = $dbh->prepare($query);
743 $sth->execute($statuscode);
744 my %notforloan_label_of;
745 while ( my $row = $sth->fetchrow_hashref ) {
746 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
750 return \%notforloan_label_of;
754 my ( $position, $type ) = @_;
755 my $dbh = C4::Context->dbh;
756 my $strsth = "SELECT * FROM z3950servers where 1";
757 $strsth .= " AND position=\"$position\"" if ($position);
758 $strsth .= " AND type=\"$type\"" if ($type);
759 my $rq = $dbh->prepare($strsth);
761 my @primaryserverloop;
763 while ( my $data = $rq->fetchrow_hashref ) {
765 $cell{label} = $data->{'description'};
766 $cell{id} = $data->{'name'};
769 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
771 if ( $data->{host} );
772 $cell{checked} = $data->{checked};
773 push @primaryserverloop,
775 label => $data->{description},
778 value => $data->{host} . ":"
779 . $data->{port} . "/"
781 encoding => ($data->{encoding}?$data->{encoding}:"iso-5426"),
782 checked => "checked",
783 icon => $data->{icon},
784 zed => $data->{type} eq 'zed',
785 opensearch => $data->{type} eq 'opensearch'
788 return \@primaryserverloop;
791 sub displaySecondaryServers {
793 # my $secondary_servers_loop = [
794 # { inner_sup_servers_loop => [
795 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
796 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
797 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
798 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
802 return; #$secondary_servers_loop;
805 =head2 GetAuthValCode
807 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
812 my ($kohafield,$fwcode) = @_;
813 my $dbh = C4::Context->dbh;
814 $fwcode='' unless $fwcode;
815 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
816 $sth->execute($kohafield,$fwcode);
817 my ($authvalcode) = $sth->fetchrow_array;
821 =head2 GetAuthorisedValues
823 $authvalues = GetAuthorisedValues($category);
825 this function get all authorised values from 'authosied_value' table into a reference to array which
826 each value containt an hashref.
828 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
832 sub GetAuthorisedValues {
833 my ($category,$selected) = @_;
836 my $dbh = C4::Context->dbh;
837 my $query = "SELECT * FROM authorised_values";
838 $query .= " WHERE category = '" . $category . "'" if $category;
840 my $sth = $dbh->prepare($query);
842 while (my $data=$sth->fetchrow_hashref) {
843 if ($selected eq $data->{'authorised_value'} ) {
844 $data->{'selected'} = 1;
846 $results[$count] = $data;
849 #my $data = $sth->fetchall_arrayref({});
850 return \@results; #$data;
853 =head2 GetKohaAuthorisedValues
855 Takes $dbh , $kohafield as parameters.
856 returns hashref of authvalCode => liblibrarian
857 or undef if no authvals defined for kohafield.
861 sub GetKohaAuthorisedValues {
862 my ($kohafield,$fwcode) = @_;
863 $fwcode='' unless $fwcode;
865 my $dbh = C4::Context->dbh;
866 my $avcode = GetAuthValCode($kohafield,$fwcode);
868 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
869 $sth->execute($avcode);
870 while ( my ($val, $lib) = $sth->fetchrow_array ) {
877 =head2 GetManagedTagSubfields
881 $res = GetManagedTagSubfields();
885 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
887 NOTE: This function is used only by the (incomplete) bulk editing feature. Since
888 that feature currently does not deal with items and biblioitems changes
889 correctly, those tags are specifically excluded from the list prepared
892 For future reference, if a bulk item editing feature is implemented at some point, it
893 needs some design thought -- for example, circulation status fields should not
894 be changed willy-nilly.
898 sub GetManagedTagSubfields{
899 my $dbh=C4::Context->dbh;
900 my $rq=$dbh->prepare(qq|
902 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
903 marc_subfield_structure.liblibrarian as subfielddesc,
904 marc_tag_structure.liblibrarian as tagdesc
905 FROM marc_subfield_structure
906 LEFT JOIN marc_tag_structure
907 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
908 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
909 WHERE marc_subfield_structure.tab>=0
910 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield like 'items.%')
911 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield = 'biblioitems.itemtype')
912 AND marc_subfield_structure.kohafield <> 'biblio.biblionumber'
913 AND marc_subfield_structure.kohafield <> 'biblioitems.biblioitemnumber'
914 ORDER BY marc_subfield_structure.tagfield, tagsubfield|);
916 my $data=$rq->fetchall_arrayref({});