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
51 &GetKohaAuthorisedValues
53 &GetManagedTagSubfields
62 C4::Koha - Perl Module containing convenience functions for Koha scripts
71 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 {
457 return C4::Context->opachtdocs . '/'
458 . C4::Context->preference('template')
462 sub getitemtypeimagesrc {
463 return '/opac-tmpl' . '/'
464 . C4::Context->preference('template')
470 $printers = &GetPrinters();
471 @queues = keys %$printers;
473 Returns information about existing printer queues.
475 C<$printers> is a reference-to-hash whose keys are the print queues
476 defined in the printers table of the Koha database. The values are
477 references-to-hash, whose keys are the fields in the printers table.
483 my $dbh = C4::Context->dbh;
484 my $sth = $dbh->prepare("select * from printers");
486 while ( my $printer = $sth->fetchrow_hashref ) {
487 $printers{ $printer->{'printqueue'} } = $printer;
489 return ( \%printers );
494 $printer = GetPrinter( $query, $printers );
498 sub GetPrinter ($$) {
499 my ( $query, $printers ) = @_; # get printer for this query from printers
500 my $printer = $query->param('printer');
501 my %cookie = $query->cookie('userenv');
502 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
503 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
509 Returns the number of pages to display in a pagination bar, given the number
510 of items and the number of items per page.
515 my ( $nb_items, $nb_items_per_page ) = @_;
517 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
522 (@themes) = &getallthemes('opac');
523 (@themes) = &getallthemes('intranet');
525 Returns an array of all available themes.
533 if ( $type eq 'intranet' ) {
534 $htdocs = C4::Context->config('intrahtdocs');
537 $htdocs = C4::Context->config('opachtdocs');
539 opendir D, "$htdocs";
540 my @dirlist = readdir D;
541 foreach my $directory (@dirlist) {
542 -d "$htdocs/$directory/en" and push @themes, $directory;
549 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
552 link_value => 'su-to',
553 label_value => 'Topics',
555 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
559 link_value => 'su-geo',
560 label_value => 'Places',
565 link_value => 'su-ut',
566 label_value => 'Titles',
567 tags => [ '500', '501', '502', '503', '504', ],
572 label_value => 'Authors',
573 tags => [ '700', '701', '702', ],
578 label_value => 'Series',
583 link_value => 'branch',
584 label_value => 'Libraries',
594 link_value => 'su-to',
595 label_value => 'Topics',
601 # link_value => 'su-na',
602 # label_value => 'People and Organizations',
603 # tags => ['600', '610', '611'],
607 link_value => 'su-geo',
608 label_value => 'Places',
613 link_value => 'su-ut',
614 label_value => 'Titles',
620 label_value => 'Authors',
621 tags => [ '100', '110', '700', ],
626 label_value => 'Series',
627 tags => [ '440', '490', ],
631 link_value => 'branch',
632 label_value => 'Libraries',
644 Return a href where a key is associated to a href. You give a query, the
645 name of the key among the fields returned by the query. If you also give as
646 third argument the name of the value, the function returns a href of scalar.
655 # generic href of any information on the item, href of href.
656 my $iteminfos_of = get_infos_of($query, 'itemnumber');
657 print $iteminfos_of->{$itemnumber}{barcode};
659 # specific information, href of scalar
660 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
661 print $barcode_of_item->{$itemnumber};
666 my ( $query, $key_name, $value_name ) = @_;
668 my $dbh = C4::Context->dbh;
670 my $sth = $dbh->prepare($query);
674 while ( my $row = $sth->fetchrow_hashref ) {
675 if ( defined $value_name ) {
676 $infos_of{ $row->{$key_name} } = $row->{$value_name};
679 $infos_of{ $row->{$key_name} } = $row;
687 =head2 get_notforloan_label_of
689 my $notforloan_label_of = get_notforloan_label_of();
691 Each authorised value of notforloan (information available in items and
692 itemtypes) is link to a single label.
694 Returns a href where keys are authorised values and values are corresponding
697 foreach my $authorised_value (keys %{$notforloan_label_of}) {
699 "authorised_value: %s => %s\n",
701 $notforloan_label_of->{$authorised_value}
707 # FIXME - why not use GetAuthorisedValues ??
709 sub get_notforloan_label_of {
710 my $dbh = C4::Context->dbh;
713 SELECT authorised_value
714 FROM marc_subfield_structure
715 WHERE kohafield = \'items.notforloan\'
718 my $sth = $dbh->prepare($query);
720 my ($statuscode) = $sth->fetchrow_array();
725 FROM authorised_values
728 $sth = $dbh->prepare($query);
729 $sth->execute($statuscode);
730 my %notforloan_label_of;
731 while ( my $row = $sth->fetchrow_hashref ) {
732 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
736 return \%notforloan_label_of;
740 my ( $position, $type ) = @_;
741 my $dbh = C4::Context->dbh;
742 my $strsth = "SELECT * FROM z3950servers where 1";
743 $strsth .= " AND position=\"$position\"" if ($position);
744 $strsth .= " AND type=\"$type\"" if ($type);
745 my $rq = $dbh->prepare($strsth);
747 my @primaryserverloop;
749 while ( my $data = $rq->fetchrow_hashref ) {
751 $cell{label} = $data->{'description'};
752 $cell{id} = $data->{'name'};
755 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
757 if ( $data->{host} );
758 $cell{checked} = $data->{checked};
759 push @primaryserverloop,
761 label => $data->{description},
764 value => $data->{host} . ":"
765 . $data->{port} . "/"
767 checked => "checked",
768 icon => $data->{icon},
769 zed => $data->{type} eq 'zed',
770 opensearch => $data->{type} eq 'opensearch'
773 return \@primaryserverloop;
776 sub displaySecondaryServers {
778 # my $secondary_servers_loop = [
779 # { inner_sup_servers_loop => [
780 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
781 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
782 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
783 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
787 return; #$secondary_servers_loop;
790 =head2 GetAuthValCode
792 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
797 my ($kohafield,$fwcode) = @_;
798 my $dbh = C4::Context->dbh;
799 $fwcode='' unless $fwcode;
800 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
801 $sth->execute($kohafield,$fwcode);
802 my ($authvalcode) = $sth->fetchrow_array;
806 =head2 GetAuthorisedValues
808 $authvalues = GetAuthorisedValues($category);
810 this function get all authorised values from 'authosied_value' table into a reference to array which
811 each value containt an hashref.
813 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
817 sub GetAuthorisedValues {
818 my ($category,$selected) = @_;
821 my $dbh = C4::Context->dbh;
822 my $query = "SELECT * FROM authorised_values";
823 $query .= " WHERE category = '" . $category . "'" if $category;
825 my $sth = $dbh->prepare($query);
827 while (my $data=$sth->fetchrow_hashref) {
828 if ($selected eq $data->{'authorised_value'} ) {
829 $data->{'selected'} = 1;
831 $results[$count] = $data;
834 #my $data = $sth->fetchall_arrayref({});
835 return \@results; #$data;
840 $marcrecord = &fixEncoding($marcblob);
842 Returns a well encoded marcrecord.
847 my $record = MARC::Record->new_from_usmarc($marc);
848 if (C4::Context->preference("MARCFLAVOUR") eq "UNIMARC"){
850 my $targetcharset="utf8" if (C4::Context->preference("TemplateEncoding") eq "utf-8");
851 $targetcharset="latin1" if (C4::Context->preference("TemplateEncoding") eq "iso-8859-1");
852 my $decoder = guess_encoding($marc, qw/utf8 latin1/);
853 # die $decoder unless ref($decoder);
855 my $newRecord=MARC::Record->new();
856 foreach my $field ($record->fields()){
857 if ($field->tag()<'010'){
858 $newRecord->insert_grouped_field($field);
862 foreach my $subfield ($field->subfields()){
864 if (($newField->tag eq '100')) {
865 substr($subfield->[1],26,2,"0103") if ($targetcharset eq "latin1");
866 substr($subfield->[1],26,4,"5050") if ($targetcharset eq "utf8");
868 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
869 $newField->add_subfields($subfield->[0]=>$subfield->[1]);
871 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
872 $newField=MARC::Field->new($field->tag(),$field->indicator(1),$field->indicator(2),$subfield->[0]=>$subfield->[1]);
876 $newRecord->insert_grouped_field($newField);
879 # warn $newRecord->as_formatted();
889 =head2 GetKohaAuthorisedValues
891 Takes $dbh , $kohafield as parameters.
892 returns hashref of authvalCode => liblibrarian
893 or undef if no authvals defined for kohafield.
897 sub GetKohaAuthorisedValues {
898 my ($kohafield,$fwcode) = @_;
899 $fwcode='' unless $fwcode;
901 my $dbh = C4::Context->dbh;
902 my $avcode = GetAuthValCode($kohafield,$fwcode);
904 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
905 $sth->execute($avcode);
906 while ( my ($val, $lib) = $sth->fetchrow_array ) {
913 =head2 GetManagedTagSubfields
917 $res = GetManagedTagSubfields();
921 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
923 NOTE: This function is used only by the (incomplete) bulk editing feature. Since
924 that feature currently does not deal with items and biblioitems changes
925 correctly, those tags are specifically excluded from the list prepared
928 For future reference, if a bulk item editing feature is implemented at some point, it
929 needs some design thought -- for example, circulation status fields should not
930 be changed willy-nilly.
934 sub GetManagedTagSubfields{
935 my $dbh=C4::Context->dbh;
936 my $rq=$dbh->prepare(qq|
938 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
939 marc_subfield_structure.liblibrarian as subfielddesc,
940 marc_tag_structure.liblibrarian as tagdesc
941 FROM marc_subfield_structure
942 LEFT JOIN marc_tag_structure
943 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
944 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
945 WHERE marc_subfield_structure.tab>=0
946 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield like 'items.%')
947 AND marc_tag_structure.tagfield NOT IN (SELECT tagfield FROM marc_subfield_structure WHERE kohafield = 'biblioitems.itemtype')
948 AND marc_subfield_structure.kohafield <> 'biblio.biblionumber'
949 AND marc_subfield_structure.kohafield <> 'biblioitems.biblioitemnumber'
950 ORDER BY marc_subfield_structure.tagfield, tagsubfield|);
952 my $data=$rq->fetchall_arrayref({});