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',
591 link_value => 'branch',
592 label_value => 'Libraries',
602 link_value => 'su-to',
603 label_value => 'Topics',
609 # link_value => 'su-na',
610 # label_value => 'People and Organizations',
611 # tags => ['600', '610', '611'],
615 link_value => 'su-geo',
616 label_value => 'Places',
621 link_value => 'su-ut',
622 label_value => 'Titles',
628 label_value => 'Authors',
629 tags => [ '100', '110', '700', ],
634 label_value => 'Series',
635 tags => [ '440', '490', ],
639 link_value => 'branch',
640 label_value => 'Libraries',
652 Return a href where a key is associated to a href. You give a query, the
653 name of the key among the fields returned by the query. If you also give as
654 third argument the name of the value, the function returns a href of scalar.
663 # generic href of any information on the item, href of href.
664 my $iteminfos_of = get_infos_of($query, 'itemnumber');
665 print $iteminfos_of->{$itemnumber}{barcode};
667 # specific information, href of scalar
668 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
669 print $barcode_of_item->{$itemnumber};
674 my ( $query, $key_name, $value_name ) = @_;
676 my $dbh = C4::Context->dbh;
678 my $sth = $dbh->prepare($query);
682 while ( my $row = $sth->fetchrow_hashref ) {
683 if ( defined $value_name ) {
684 $infos_of{ $row->{$key_name} } = $row->{$value_name};
687 $infos_of{ $row->{$key_name} } = $row;
695 =head2 get_notforloan_label_of
697 my $notforloan_label_of = get_notforloan_label_of();
699 Each authorised value of notforloan (information available in items and
700 itemtypes) is link to a single label.
702 Returns a href where keys are authorised values and values are corresponding
705 foreach my $authorised_value (keys %{$notforloan_label_of}) {
707 "authorised_value: %s => %s\n",
709 $notforloan_label_of->{$authorised_value}
715 # FIXME - why not use GetAuthorisedValues ??
717 sub get_notforloan_label_of {
718 my $dbh = C4::Context->dbh;
721 SELECT authorised_value
722 FROM marc_subfield_structure
723 WHERE kohafield = \'items.notforloan\'
726 my $sth = $dbh->prepare($query);
728 my ($statuscode) = $sth->fetchrow_array();
733 FROM authorised_values
736 $sth = $dbh->prepare($query);
737 $sth->execute($statuscode);
738 my %notforloan_label_of;
739 while ( my $row = $sth->fetchrow_hashref ) {
740 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
744 return \%notforloan_label_of;
748 my ( $position, $type ) = @_;
749 my $dbh = C4::Context->dbh;
750 my $strsth = "SELECT * FROM z3950servers where 1";
751 $strsth .= " AND position=\"$position\"" if ($position);
752 $strsth .= " AND type=\"$type\"" if ($type);
753 my $rq = $dbh->prepare($strsth);
755 my @primaryserverloop;
757 while ( my $data = $rq->fetchrow_hashref ) {
759 $cell{label} = $data->{'description'};
760 $cell{id} = $data->{'name'};
763 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
765 if ( $data->{host} );
766 $cell{checked} = $data->{checked};
767 push @primaryserverloop,
769 label => $data->{description},
772 value => $data->{host} . ":"
773 . $data->{port} . "/"
775 encoding => ($data->{encoding}?$data->{encoding}:"iso-5426"),
776 checked => "checked",
777 icon => $data->{icon},
778 zed => $data->{type} eq 'zed',
779 opensearch => $data->{type} eq 'opensearch'
782 return \@primaryserverloop;
785 sub displaySecondaryServers {
787 # my $secondary_servers_loop = [
788 # { inner_sup_servers_loop => [
789 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
790 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
791 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
792 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
796 return; #$secondary_servers_loop;
799 =head2 GetAuthValCode
801 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
806 my ($kohafield,$fwcode) = @_;
807 my $dbh = C4::Context->dbh;
808 $fwcode='' unless $fwcode;
809 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
810 $sth->execute($kohafield,$fwcode);
811 my ($authvalcode) = $sth->fetchrow_array;
815 =head2 GetAuthorisedValues
817 $authvalues = GetAuthorisedValues($category);
819 this function get all authorised values from 'authosied_value' table into a reference to array which
820 each value containt an hashref.
822 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
826 sub GetAuthorisedValues {
827 my ($category,$selected) = @_;
830 my $dbh = C4::Context->dbh;
831 my $query = "SELECT * FROM authorised_values";
832 $query .= " WHERE category = '" . $category . "'" if $category;
834 my $sth = $dbh->prepare($query);
836 while (my $data=$sth->fetchrow_hashref) {
837 if ($selected eq $data->{'authorised_value'} ) {
838 $data->{'selected'} = 1;
840 $results[$count] = $data;
843 #my $data = $sth->fetchall_arrayref({});
844 return \@results; #$data;
847 =head2 GetKohaAuthorisedValues
849 Takes $dbh , $kohafield as parameters.
850 returns hashref of authvalCode => liblibrarian
851 or undef if no authvals defined for kohafield.
855 sub GetKohaAuthorisedValues {
856 my ($kohafield,$fwcode) = @_;
857 $fwcode='' unless $fwcode;
859 my $dbh = C4::Context->dbh;
860 my $avcode = GetAuthValCode($kohafield,$fwcode);
862 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
863 $sth->execute($avcode);
864 while ( my ($val, $lib) = $sth->fetchrow_array ) {
871 =head2 GetManagedTagSubfields
875 $res = GetManagedTagSubfields();
879 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
881 NOTE: This function is used only by the (incomplete) bulk editing feature. Since
882 that feature currently does not deal with items and biblioitems changes
883 correctly, those tags are specifically excluded from the list prepared
886 For future reference, if a bulk item editing feature is implemented at some point, it
887 needs some design thought -- for example, circulation status fields should not
888 be changed willy-nilly.
892 sub GetManagedTagSubfields{
893 my $dbh=C4::Context->dbh;
894 my $rq=$dbh->prepare(qq|
896 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
897 marc_subfield_structure.liblibrarian as subfielddesc,
898 marc_tag_structure.liblibrarian as tagdesc
899 FROM marc_subfield_structure
900 LEFT JOIN marc_tag_structure
901 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
902 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
903 WHERE marc_subfield_structure.tab>=0
904 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield like 'items.%')
905 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield = 'biblioitems.itemtype')
906 AND marc_subfield_structure.kohafield <> 'biblio.biblionumber'
907 AND marc_subfield_structure.kohafield <> 'biblioitems.biblioitemnumber'
908 ORDER BY marc_subfield_structure.tagfield, tagsubfield|);
910 my $data=$rq->fetchall_arrayref({});