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
25 use MIME::Base64 qw(encode_base64 decode_base64);
26 use Encode qw(encode decode);
28 use vars qw($VERSION @ISA @EXPORT $DEBUG);
37 &subfield_is_koha_internal_p
38 &GetPrinters &GetPrinter
39 &GetItemTypes &getitemtypeinfo
42 &getframeworks &getframeworkinfo
43 &getauthtypes &getauthtype
48 &getitemtypeimagesrcfromurl
50 &get_notforloan_label_of
54 &GetKohaAuthorisedValues
56 &GetManagedTagSubfields
67 C4::Koha - Perl Module containing convenience functions for Koha scripts
76 Koha.pm provides many functions for Koha scripts.
85 $slash_date = &slashifyDate($dash_date);
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.
94 # accepts a date of the form xx-xx-xx[xx] and returns it in the
96 my @dateOut = split( '-', shift );
97 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
103 my $string = DisplayISBN( $isbn );
109 if (length ($isbn)<13){
111 if ( substr( $isbn, 0, 1 ) <= 7 ) {
112 $seg1 = substr( $isbn, 0, 1 );
114 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
115 $seg1 = substr( $isbn, 0, 2 );
117 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
118 $seg1 = substr( $isbn, 0, 3 );
120 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
121 $seg1 = substr( $isbn, 0, 4 );
124 $seg1 = substr( $isbn, 0, 5 );
126 my $x = substr( $isbn, length($seg1) );
128 if ( substr( $x, 0, 2 ) <= 19 ) {
130 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
131 $seg2 = substr( $x, 0, 2 );
133 elsif ( substr( $x, 0, 3 ) <= 699 ) {
134 $seg2 = substr( $x, 0, 3 );
136 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
137 $seg2 = substr( $x, 0, 4 );
139 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
140 $seg2 = substr( $x, 0, 5 );
142 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
143 $seg2 = substr( $x, 0, 6 );
146 $seg2 = substr( $x, 0, 7 );
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";
154 $seg1 = substr( $isbn, 0, 3 );
156 if ( substr( $isbn, 3, 1 ) <= 7 ) {
157 $seg2 = substr( $isbn, 3, 1 );
159 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
160 $seg2 = substr( $isbn, 3, 2 );
162 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
163 $seg2 = substr( $isbn, 3, 3 );
165 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
166 $seg2 = substr( $isbn, 3, 4 );
169 $seg2 = substr( $isbn, 3, 5 );
171 my $x = substr( $isbn, length($seg2) +3);
173 if ( substr( $x, 0, 2 ) <= 19 ) {
175 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
176 $seg3 = substr( $x, 0, 2 );
178 elsif ( substr( $x, 0, 3 ) <= 699 ) {
179 $seg3 = substr( $x, 0, 3 );
181 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
182 $seg3 = substr( $x, 0, 4 );
184 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
185 $seg3 = substr( $x, 0, 5 );
187 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
188 $seg3 = substr( $x, 0, 6 );
191 $seg3 = substr( $x, 0, 7 );
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";
200 # FIXME.. this should be moved to a MARC-specific module
201 sub subfield_is_koha_internal_p ($) {
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
208 return length $subfield != 1;
213 $itemtypes = &GetItemTypes();
215 Returns information about existing itemtypes.
217 build a HTML select with the following code :
219 =head3 in PERL SCRIPT
221 my $itemtypes = GetItemTypes;
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'},
229 push @itemtypesloop, \%row;
231 $template->param(itemtypeloop => \@itemtypesloop);
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>
242 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
243 <input type="submit" value="OK" class="button">
250 # returns a reference to a hash of references to branches...
252 my $dbh = C4::Context->dbh;
257 my $sth = $dbh->prepare($query);
259 while ( my $IT = $sth->fetchrow_hashref ) {
260 $itemtypes{ $IT->{'itemtype'} } = $IT;
262 return ( \%itemtypes );
265 sub get_itemtypeinfos_of {
274 WHERE itemtype IN (' . join( ',', map( { "'" . $_ . "'" } @itemtypes ) ) . ')
277 return get_infos_of( $query, 'itemtype' );
280 # this is temporary until we separate collection codes and item types
284 my $dbh = C4::Context->dbh;
287 "SELECT * FROM authorised_values ORDER BY authorised_value");
289 while ( my $data = $sth->fetchrow_hashref ) {
290 if ( $data->{category} eq "CCODE" ) {
292 $results[$count] = $data;
298 return ( $count, @results );
303 $authtypes = &getauthtypes();
305 Returns information about existing authtypes.
307 build a HTML select with the following code :
309 =head3 in PERL SCRIPT
311 my $authtypes = getauthtypes;
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'},
319 push @authtypesloop, \%row;
321 $template->param(itemtypeloop => \@itemtypesloop);
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>
331 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
332 <input type="submit" value="OK" class="button">
340 # returns a reference to a hash of references to authtypes...
342 my $dbh = C4::Context->dbh;
343 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
345 while ( my $IT = $sth->fetchrow_hashref ) {
346 $authtypes{ $IT->{'authtypecode'} } = $IT;
348 return ( \%authtypes );
352 my ($authtypecode) = @_;
354 # returns a reference to a hash of references to 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;
365 $frameworks = &getframework();
367 Returns information about existing frameworks
369 build a HTML select with the following code :
371 =head3 in PERL SCRIPT
373 my $frameworks = frameworks();
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'},
381 push @frameworksloop, \%row;
383 $template->param(frameworkloop => \@frameworksloop);
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>
394 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
395 <input type="submit" value="OK" class="button">
403 # returns a reference to a hash of references to branches...
405 my $dbh = C4::Context->dbh;
406 my $sth = $dbh->prepare("select * from biblio_framework");
408 while ( my $IT = $sth->fetchrow_hashref ) {
409 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
411 return ( \%itemtypes );
414 =head2 getframeworkinfo
416 $frameworkinfo = &getframeworkinfo($frameworkcode);
418 Returns information about an frameworkcode.
422 sub getframeworkinfo {
423 my ($frameworkcode) = @_;
424 my $dbh = C4::Context->dbh;
426 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
427 $sth->execute($frameworkcode);
428 my $res = $sth->fetchrow_hashref;
432 =head2 getitemtypeinfo
434 $itemtype = &getitemtype($itemtype);
436 Returns information about an itemtype.
440 sub getitemtypeinfo {
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;
447 $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
452 sub getitemtypeimagesrcfromurl {
455 if ( defined $imageurl and $imageurl !~ m/^http/ ) {
456 $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
462 sub getitemtypeimagedir {
464 if ($src eq 'intranet') {
465 return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg';
468 return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('template') . '/itemtypeimg';
472 sub getitemtypeimagesrc {
474 if ($src eq 'intranet') {
475 return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg';
478 return '/opac-tmpl' . '/' . C4::Context->preference('template') . '/itemtypeimg';
484 $printers = &GetPrinters();
485 @queues = keys %$printers;
487 Returns information about existing printer queues.
489 C<$printers> is a reference-to-hash whose keys are the print queues
490 defined in the printers table of the Koha database. The values are
491 references-to-hash, whose keys are the fields in the printers table.
497 my $dbh = C4::Context->dbh;
498 my $sth = $dbh->prepare("select * from printers");
500 while ( my $printer = $sth->fetchrow_hashref ) {
501 $printers{ $printer->{'printqueue'} } = $printer;
503 return ( \%printers );
508 $printer = GetPrinter( $query, $printers );
512 sub GetPrinter ($$) {
513 my ( $query, $printers ) = @_; # get printer for this query from printers
514 my $printer = $query->param('printer');
515 my %cookie = $query->cookie('userenv');
516 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
517 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
523 Returns the number of pages to display in a pagination bar, given the number
524 of items and the number of items per page.
529 my ( $nb_items, $nb_items_per_page ) = @_;
531 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
536 (@themes) = &getallthemes('opac');
537 (@themes) = &getallthemes('intranet');
539 Returns an array of all available themes.
547 if ( $type eq 'intranet' ) {
548 $htdocs = C4::Context->config('intrahtdocs');
551 $htdocs = C4::Context->config('opachtdocs');
553 opendir D, "$htdocs";
554 my @dirlist = readdir D;
555 foreach my $directory (@dirlist) {
556 -d "$htdocs/$directory/en" and push @themes, $directory;
563 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
566 link_value => 'su-to',
567 label_value => 'Topics',
569 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
573 link_value => 'su-geo',
574 label_value => 'Places',
579 link_value => 'su-ut',
580 label_value => 'Titles',
581 tags => [ '500', '501', '502', '503', '504', ],
586 label_value => 'Authors',
587 tags => [ '700', '701', '702', ],
592 label_value => 'Series',
601 link_value => 'branch',
602 label_value => 'Libraries',
607 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
612 link_value => 'su-to',
613 label_value => 'Topics',
619 # link_value => 'su-na',
620 # label_value => 'People and Organizations',
621 # tags => ['600', '610', '611'],
625 link_value => 'su-geo',
626 label_value => 'Places',
631 link_value => 'su-ut',
632 label_value => 'Titles',
638 label_value => 'Authors',
639 tags => [ '100', '110', '700', ],
644 label_value => 'Series',
645 tags => [ '440', '490', ],
651 link_value => 'branch',
652 label_value => 'Libraries',
657 push @$facets, $library_facet unless C4::Context->preference("singleBranchMode");
664 Return a href where a key is associated to a href. You give a query, the
665 name of the key among the fields returned by the query. If you also give as
666 third argument the name of the value, the function returns a href of scalar.
675 # generic href of any information on the item, href of href.
676 my $iteminfos_of = get_infos_of($query, 'itemnumber');
677 print $iteminfos_of->{$itemnumber}{barcode};
679 # specific information, href of scalar
680 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
681 print $barcode_of_item->{$itemnumber};
686 my ( $query, $key_name, $value_name ) = @_;
688 my $dbh = C4::Context->dbh;
690 my $sth = $dbh->prepare($query);
694 while ( my $row = $sth->fetchrow_hashref ) {
695 if ( defined $value_name ) {
696 $infos_of{ $row->{$key_name} } = $row->{$value_name};
699 $infos_of{ $row->{$key_name} } = $row;
707 =head2 get_notforloan_label_of
709 my $notforloan_label_of = get_notforloan_label_of();
711 Each authorised value of notforloan (information available in items and
712 itemtypes) is link to a single label.
714 Returns a href where keys are authorised values and values are corresponding
717 foreach my $authorised_value (keys %{$notforloan_label_of}) {
719 "authorised_value: %s => %s\n",
721 $notforloan_label_of->{$authorised_value}
727 # FIXME - why not use GetAuthorisedValues ??
729 sub get_notforloan_label_of {
730 my $dbh = C4::Context->dbh;
733 SELECT authorised_value
734 FROM marc_subfield_structure
735 WHERE kohafield = \'items.notforloan\'
738 my $sth = $dbh->prepare($query);
740 my ($statuscode) = $sth->fetchrow_array();
745 FROM authorised_values
748 $sth = $dbh->prepare($query);
749 $sth->execute($statuscode);
750 my %notforloan_label_of;
751 while ( my $row = $sth->fetchrow_hashref ) {
752 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
756 return \%notforloan_label_of;
760 my ( $position, $type ) = @_;
761 my $dbh = C4::Context->dbh;
762 my $strsth = "SELECT * FROM z3950servers where 1";
763 $strsth .= " AND position=\"$position\"" if ($position);
764 $strsth .= " AND type=\"$type\"" if ($type);
765 my $rq = $dbh->prepare($strsth);
767 my @primaryserverloop;
769 while ( my $data = $rq->fetchrow_hashref ) {
771 $cell{label} = $data->{'description'};
772 $cell{id} = $data->{'name'};
775 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
777 if ( $data->{host} );
778 $cell{checked} = $data->{checked};
779 push @primaryserverloop,
781 label => $data->{description},
784 value => $data->{host} . ":"
785 . $data->{port} . "/"
787 encoding => ($data->{encoding}?$data->{encoding}:"iso-5426"),
788 checked => "checked",
789 icon => $data->{icon},
790 zed => $data->{type} eq 'zed',
791 opensearch => $data->{type} eq 'opensearch'
794 return \@primaryserverloop;
797 sub displaySecondaryServers {
799 # my $secondary_servers_loop = [
800 # { inner_sup_servers_loop => [
801 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
802 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
803 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
804 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
808 return; #$secondary_servers_loop;
811 =head2 GetAuthValCode
813 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
818 my ($kohafield,$fwcode) = @_;
819 my $dbh = C4::Context->dbh;
820 $fwcode='' unless $fwcode;
821 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
822 $sth->execute($kohafield,$fwcode);
823 my ($authvalcode) = $sth->fetchrow_array;
827 =head2 GetAuthorisedValues
829 $authvalues = GetAuthorisedValues($category);
831 this function get all authorised values from 'authosied_value' table into a reference to array which
832 each value containt an hashref.
834 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
838 sub GetAuthorisedValues {
839 my ($category,$selected) = @_;
842 my $dbh = C4::Context->dbh;
843 my $query = "SELECT * FROM authorised_values";
844 $query .= " WHERE category = '" . $category . "'" if $category;
846 my $sth = $dbh->prepare($query);
848 while (my $data=$sth->fetchrow_hashref) {
849 if ($selected eq $data->{'authorised_value'} ) {
850 $data->{'selected'} = 1;
852 $results[$count] = $data;
855 #my $data = $sth->fetchall_arrayref({});
856 return \@results; #$data;
859 =head2 GetKohaAuthorisedValues
861 Takes $kohafield, $fwcode as parameters.
862 Returns hashref of Code => description
864 if no authorised value category is defined for the kohafield.
868 sub GetKohaAuthorisedValues {
869 my ($kohafield,$fwcode,$codedvalue) = @_;
870 $fwcode='' unless $fwcode;
872 my $dbh = C4::Context->dbh;
873 my $avcode = GetAuthValCode($kohafield,$fwcode);
875 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
876 $sth->execute($avcode);
877 while ( my ($val, $lib) = $sth->fetchrow_array ) {
886 =head2 GetManagedTagSubfields
890 $res = GetManagedTagSubfields();
894 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
896 NOTE: This function is used only by the (incomplete) bulk editing feature. Since
897 that feature currently does not deal with items and biblioitems changes
898 correctly, those tags are specifically excluded from the list prepared
901 For future reference, if a bulk item editing feature is implemented at some point, it
902 needs some design thought -- for example, circulation status fields should not
903 be changed willy-nilly.
907 sub GetManagedTagSubfields{
908 my $dbh=C4::Context->dbh;
909 my $rq=$dbh->prepare(qq|
911 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
912 marc_subfield_structure.liblibrarian as subfielddesc,
913 marc_tag_structure.liblibrarian as tagdesc
914 FROM marc_subfield_structure
915 LEFT JOIN marc_tag_structure
916 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
917 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
918 WHERE marc_subfield_structure.tab>=0
919 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield like 'items.%')
920 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield = 'biblioitems.itemtype')
921 AND marc_subfield_structure.kohafield <> 'biblio.biblionumber'
922 AND marc_subfield_structure.kohafield <> 'biblioitems.biblioitemnumber'
923 ORDER BY marc_subfield_structure.tagfield, tagsubfield|);
925 my $data=$rq->fetchall_arrayref({});
933 my $base64 = str_to_base64($string_containing_unicode);
937 Get a Base64 version of a string that is in UTF-8. This
938 function can be used to convert an arbitrary coded value
939 (like a branch code) into a form that can be safely concatenated
940 with similarly encoded values for a HTML form input name, as
941 in admin/issuingrules.pl.
947 return encode_base64(encode("UTF-8", $in), '');
954 my $base64 = base64_to_str($string_containing_unicode);
958 Converse of C<str_to_base64()>.
964 return decode("UTF-8", decode_base64($in));