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 our ($VERSION,@ISA,@EXPORT);
31 C4::Koha - Perl Module containing convenience functions for Koha scripts
40 Koha.pm provides many functions for Koha scripts.
52 &subfield_is_koha_internal_p
53 &GetPrinters &GetPrinter
54 &GetItemTypes &getitemtypeinfo
57 &getframeworks &getframeworkinfo
58 &getauthtypes &getauthtype
63 &getitemtypeimagesrcfromurl
65 &get_notforloan_label_of
70 &GetKohaAuthorisedValues
72 &GetManagedTagSubfields
81 $slash_date = &slashifyDate($dash_date);
83 Takes a string of the form "DD-MM-YYYY" (or anything separated by
84 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
90 # accepts a date of the form xx-xx-xx[xx] and returns it in the
92 my @dateOut = split( '-', shift );
93 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
99 my $string = DisplayISBN( $isbn );
105 if (length ($isbn)<13){
107 if ( substr( $isbn, 0, 1 ) <= 7 ) {
108 $seg1 = substr( $isbn, 0, 1 );
110 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
111 $seg1 = substr( $isbn, 0, 2 );
113 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
114 $seg1 = substr( $isbn, 0, 3 );
116 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
117 $seg1 = substr( $isbn, 0, 4 );
120 $seg1 = substr( $isbn, 0, 5 );
122 my $x = substr( $isbn, length($seg1) );
124 if ( substr( $x, 0, 2 ) <= 19 ) {
126 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
127 $seg2 = substr( $x, 0, 2 );
129 elsif ( substr( $x, 0, 3 ) <= 699 ) {
130 $seg2 = substr( $x, 0, 3 );
132 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
133 $seg2 = substr( $x, 0, 4 );
135 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
136 $seg2 = substr( $x, 0, 5 );
138 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
139 $seg2 = substr( $x, 0, 6 );
142 $seg2 = substr( $x, 0, 7 );
144 my $seg3 = substr( $x, length($seg2) );
145 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
146 my $seg4 = substr( $x, -1, 1 );
147 return "$seg1-$seg2-$seg3-$seg4";
150 $seg1 = substr( $isbn, 0, 3 );
152 if ( substr( $isbn, 3, 1 ) <= 7 ) {
153 $seg2 = substr( $isbn, 3, 1 );
155 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
156 $seg2 = substr( $isbn, 3, 2 );
158 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
159 $seg2 = substr( $isbn, 3, 3 );
161 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
162 $seg2 = substr( $isbn, 3, 4 );
165 $seg2 = substr( $isbn, 3, 5 );
167 my $x = substr( $isbn, length($seg2) +3);
169 if ( substr( $x, 0, 2 ) <= 19 ) {
171 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
172 $seg3 = substr( $x, 0, 2 );
174 elsif ( substr( $x, 0, 3 ) <= 699 ) {
175 $seg3 = substr( $x, 0, 3 );
177 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
178 $seg3 = substr( $x, 0, 4 );
180 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
181 $seg3 = substr( $x, 0, 5 );
183 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
184 $seg3 = substr( $x, 0, 6 );
187 $seg3 = substr( $x, 0, 7 );
189 my $seg4 = substr( $x, length($seg3) );
190 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
191 my $seg5 = substr( $x, -1, 1 );
192 return "$seg1-$seg2-$seg3-$seg4-$seg5";
196 # FIXME.. this should be moved to a MARC-specific module
197 sub subfield_is_koha_internal_p ($) {
200 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
201 # But real MARC subfields are always single-character
202 # so it really is safer just to check the length
204 return length $subfield != 1;
209 $itemtypes = &GetItemTypes();
211 Returns information about existing itemtypes.
213 build a HTML select with the following code :
215 =head3 in PERL SCRIPT
217 my $itemtypes = GetItemTypes;
219 foreach my $thisitemtype (sort keys %$itemtypes) {
220 my $selected = 1 if $thisitemtype eq $itemtype;
221 my %row =(value => $thisitemtype,
222 selected => $selected,
223 description => $itemtypes->{$thisitemtype}->{'description'},
225 push @itemtypesloop, \%row;
227 $template->param(itemtypeloop => \@itemtypesloop);
231 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
232 <select name="itemtype">
233 <option value="">Default</option>
234 <!-- TMPL_LOOP name="itemtypeloop" -->
235 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
238 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
239 <input type="submit" value="OK" class="button">
246 # returns a reference to a hash of references to branches...
248 my $dbh = C4::Context->dbh;
253 my $sth = $dbh->prepare($query);
255 while ( my $IT = $sth->fetchrow_hashref ) {
256 $itemtypes{ $IT->{'itemtype'} } = $IT;
258 return ( \%itemtypes );
261 sub get_itemtypeinfos_of {
269 WHERE itemtype IN (' . join( ',', map( { "'" . $_ . "'" } @itemtypes ) ) . ')
272 return get_infos_of( $query, 'itemtype' );
275 # this is temporary until we separate collection codes and item types
279 my $dbh = C4::Context->dbh;
282 "SELECT * FROM authorised_values ORDER BY authorised_value");
284 while ( my $data = $sth->fetchrow_hashref ) {
285 if ( $data->{category} eq "CCODE" ) {
287 $results[$count] = $data;
293 return ( $count, @results );
298 $authtypes = &getauthtypes();
300 Returns information about existing authtypes.
302 build a HTML select with the following code :
304 =head3 in PERL SCRIPT
306 my $authtypes = getauthtypes;
308 foreach my $thisauthtype (keys %$authtypes) {
309 my $selected = 1 if $thisauthtype eq $authtype;
310 my %row =(value => $thisauthtype,
311 selected => $selected,
312 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
314 push @authtypesloop, \%row;
316 $template->param(itemtypeloop => \@itemtypesloop);
320 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
321 <select name="authtype">
322 <!-- TMPL_LOOP name="authtypeloop" -->
323 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
326 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
327 <input type="submit" value="OK" class="button">
335 # returns a reference to a hash of references to authtypes...
337 my $dbh = C4::Context->dbh;
338 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
340 while ( my $IT = $sth->fetchrow_hashref ) {
341 $authtypes{ $IT->{'authtypecode'} } = $IT;
343 return ( \%authtypes );
347 my ($authtypecode) = @_;
349 # returns a reference to a hash of references to authtypes...
351 my $dbh = C4::Context->dbh;
352 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
353 $sth->execute($authtypecode);
354 my $res = $sth->fetchrow_hashref;
360 $frameworks = &getframework();
362 Returns information about existing frameworks
364 build a HTML select with the following code :
366 =head3 in PERL SCRIPT
368 my $frameworks = frameworks();
370 foreach my $thisframework (keys %$frameworks) {
371 my $selected = 1 if $thisframework eq $frameworkcode;
372 my %row =(value => $thisframework,
373 selected => $selected,
374 description => $frameworks->{$thisframework}->{'frameworktext'},
376 push @frameworksloop, \%row;
378 $template->param(frameworkloop => \@frameworksloop);
382 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
383 <select name="frameworkcode">
384 <option value="">Default</option>
385 <!-- TMPL_LOOP name="frameworkloop" -->
386 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
389 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
390 <input type="submit" value="OK" class="button">
398 # returns a reference to a hash of references to branches...
400 my $dbh = C4::Context->dbh;
401 my $sth = $dbh->prepare("select * from biblio_framework");
403 while ( my $IT = $sth->fetchrow_hashref ) {
404 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
406 return ( \%itemtypes );
409 =head2 getframeworkinfo
411 $frameworkinfo = &getframeworkinfo($frameworkcode);
413 Returns information about an frameworkcode.
417 sub getframeworkinfo {
418 my ($frameworkcode) = @_;
419 my $dbh = C4::Context->dbh;
421 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
422 $sth->execute($frameworkcode);
423 my $res = $sth->fetchrow_hashref;
427 =head2 getitemtypeinfo
429 $itemtype = &getitemtype($itemtype);
431 Returns information about an itemtype.
435 sub getitemtypeinfo {
437 my $dbh = C4::Context->dbh;
438 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
439 $sth->execute($itemtype);
440 my $res = $sth->fetchrow_hashref;
442 $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
447 sub getitemtypeimagesrcfromurl {
450 if ( defined $imageurl and $imageurl !~ m/^http/ ) {
451 $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
457 sub getitemtypeimagedir {
458 return C4::Context->opachtdocs . '/'
459 . C4::Context->preference('template')
463 sub getitemtypeimagesrc {
464 return '/opac-tmpl' . '/'
465 . C4::Context->preference('template')
471 $printers = &GetPrinters();
472 @queues = keys %$printers;
474 Returns information about existing printer queues.
476 C<$printers> is a reference-to-hash whose keys are the print queues
477 defined in the printers table of the Koha database. The values are
478 references-to-hash, whose keys are the fields in the printers table.
484 my $dbh = C4::Context->dbh;
485 my $sth = $dbh->prepare("select * from printers");
487 while ( my $printer = $sth->fetchrow_hashref ) {
488 $printers{ $printer->{'printqueue'} } = $printer;
490 return ( \%printers );
495 $printer = GetPrinter( $query, $printers );
499 sub GetPrinter ($$) {
500 my ( $query, $printers ) = @_; # get printer for this query from printers
501 my $printer = $query->param('printer');
502 my %cookie = $query->cookie('userenv');
503 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
504 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
510 Returns the number of pages to display in a pagination bar, given the number
511 of items and the number of items per page.
516 my ( $nb_items, $nb_items_per_page ) = @_;
518 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
523 (@themes) = &getallthemes('opac');
524 (@themes) = &getallthemes('intranet');
526 Returns an array of all available themes.
534 if ( $type eq 'intranet' ) {
535 $htdocs = C4::Context->config('intrahtdocs');
538 $htdocs = C4::Context->config('opachtdocs');
540 opendir D, "$htdocs";
541 my @dirlist = readdir D;
542 foreach my $directory (@dirlist) {
543 -d "$htdocs/$directory/en" and push @themes, $directory;
550 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
553 link_value => 'su-to',
554 label_value => 'Topics',
556 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
560 link_value => 'su-geo',
561 label_value => 'Places',
566 link_value => 'su-ut',
567 label_value => 'Titles',
568 tags => [ '500', '501', '502', '503', '504', ],
573 label_value => 'Authors',
574 tags => [ '700', '701', '702', ],
579 label_value => 'Series',
584 link_value => 'branch',
585 label_value => 'Libraries',
595 link_value => 'su-to',
596 label_value => 'Topics',
602 # link_value => 'su-na',
603 # label_value => 'People and Organizations',
604 # tags => ['600', '610', '611'],
608 link_value => 'su-geo',
609 label_value => 'Places',
614 link_value => 'su-ut',
615 label_value => 'Titles',
621 label_value => 'Authors',
622 tags => [ '100', '110', '700', ],
627 label_value => 'Series',
628 tags => [ '440', '490', ],
632 link_value => 'branch',
633 label_value => 'Libraries',
645 Return a href where a key is associated to a href. You give a query, the
646 name of the key among the fields returned by the query. If you also give as
647 third argument the name of the value, the function returns a href of scalar.
656 # generic href of any information on the item, href of href.
657 my $iteminfos_of = get_infos_of($query, 'itemnumber');
658 print $iteminfos_of->{$itemnumber}{barcode};
660 # specific information, href of scalar
661 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
662 print $barcode_of_item->{$itemnumber};
667 my ( $query, $key_name, $value_name ) = @_;
669 my $dbh = C4::Context->dbh;
671 my $sth = $dbh->prepare($query);
675 while ( my $row = $sth->fetchrow_hashref ) {
676 if ( defined $value_name ) {
677 $infos_of{ $row->{$key_name} } = $row->{$value_name};
680 $infos_of{ $row->{$key_name} } = $row;
688 =head2 get_notforloan_label_of
690 my $notforloan_label_of = get_notforloan_label_of();
692 Each authorised value of notforloan (information available in items and
693 itemtypes) is link to a single label.
695 Returns a href where keys are authorised values and values are corresponding
698 foreach my $authorised_value (keys %{$notforloan_label_of}) {
700 "authorised_value: %s => %s\n",
702 $notforloan_label_of->{$authorised_value}
708 # FIXME - why not use GetAuthorisedValues ??
710 sub get_notforloan_label_of {
711 my $dbh = C4::Context->dbh;
714 SELECT authorised_value
715 FROM marc_subfield_structure
716 WHERE kohafield = \'items.notforloan\'
719 my $sth = $dbh->prepare($query);
721 my ($statuscode) = $sth->fetchrow_array();
726 FROM authorised_values
729 $sth = $dbh->prepare($query);
730 $sth->execute($statuscode);
731 my %notforloan_label_of;
732 while ( my $row = $sth->fetchrow_hashref ) {
733 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
737 return \%notforloan_label_of;
741 my ( $position, $type ) = @_;
742 my $dbh = C4::Context->dbh;
743 my $strsth = "SELECT * FROM z3950servers where 1";
744 $strsth .= " AND position=\"$position\"" if ($position);
745 $strsth .= " AND type=\"$type\"" if ($type);
746 my $rq = $dbh->prepare($strsth);
748 my @primaryserverloop;
750 while ( my $data = $rq->fetchrow_hashref ) {
752 $cell{label} = $data->{'description'};
753 $cell{id} = $data->{'name'};
756 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
758 if ( $data->{host} );
759 $cell{checked} = $data->{checked};
760 push @primaryserverloop,
762 label => $data->{description},
765 value => $data->{host} . ":"
766 . $data->{port} . "/"
768 checked => "checked",
769 icon => $data->{icon},
770 zed => $data->{type} eq 'zed',
771 opensearch => $data->{type} eq 'opensearch'
774 return \@primaryserverloop;
777 sub displaySecondaryServers {
779 # my $secondary_servers_loop = [
780 # { inner_sup_servers_loop => [
781 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
782 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
783 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
784 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
788 return; #$secondary_servers_loop;
791 =head2 GetAuthValCode
793 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
798 my ($kohafield,$fwcode) = @_;
799 my $dbh = C4::Context->dbh;
800 $fwcode='' unless $fwcode;
801 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
802 $sth->execute($kohafield,$fwcode);
803 my ($authvalcode) = $sth->fetchrow_array;
807 =head2 GetAuthorisedValues
809 $authvalues = GetAuthorisedValues($category);
811 this function get all authorised values from 'authosied_value' table into a reference to array which
812 each value containt an hashref.
814 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
818 sub GetAuthorisedValues {
819 my ($category,$selected) = @_;
822 my $dbh = C4::Context->dbh;
823 my $query = "SELECT * FROM authorised_values";
824 $query .= " WHERE category = '" . $category . "'" if $category;
826 my $sth = $dbh->prepare($query);
828 while (my $data=$sth->fetchrow_hashref) {
829 if ($selected eq $data->{'authorised_value'} ) {
830 $data->{'selected'} = 1;
832 $results[$count] = $data;
835 #my $data = $sth->fetchall_arrayref({});
836 return \@results; #$data;
841 $marcrecord = &fixEncoding($marcblob);
843 Returns a well encoded marcrecord.
848 my $record = MARC::Record->new_from_usmarc($marc);
849 if (C4::Context->preference("MARCFLAVOUR") eq "UNIMARC"){
851 my $targetcharset="utf8" if (C4::Context->preference("TemplateEncoding") eq "utf-8");
852 $targetcharset="latin1" if (C4::Context->preference("TemplateEncoding") eq "iso-8859-1");
853 my $decoder = guess_encoding($marc, qw/utf8 latin1/);
854 # die $decoder unless ref($decoder);
856 my $newRecord=MARC::Record->new();
857 foreach my $field ($record->fields()){
858 if ($field->tag()<'010'){
859 $newRecord->insert_grouped_field($field);
863 foreach my $subfield ($field->subfields()){
865 if (($newField->tag eq '100')) {
866 substr($subfield->[1],26,2,"0103") if ($targetcharset eq "latin1");
867 substr($subfield->[1],26,4,"5050") if ($targetcharset eq "utf8");
869 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
870 $newField->add_subfields($subfield->[0]=>$subfield->[1]);
872 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
873 $newField=MARC::Field->new($field->tag(),$field->indicator(1),$field->indicator(2),$subfield->[0]=>$subfield->[1]);
877 $newRecord->insert_grouped_field($newField);
880 # warn $newRecord->as_formatted();
890 =head2 GetKohaAuthorisedValues
892 Takes $dbh , $kohafield as parameters.
893 returns hashref of authvalCode => liblibrarian
894 or undef if no authvals defined for kohafield.
898 sub GetKohaAuthorisedValues {
899 my ($kohafield,$fwcode) = @_;
900 $fwcode='' unless $fwcode;
902 my $dbh = C4::Context->dbh;
903 my $avcode = GetAuthValCode($kohafield,$fwcode);
905 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
906 $sth->execute($avcode);
907 while ( my ($val, $lib) = $sth->fetchrow_array ) {
914 =head2 GetManagedTagSubfields
918 $res = GetManagedTagSubfields();
920 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
921 $forlibrarian :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
922 $frameworkcode : the framework code to read
930 sub GetManagedTagSubfields{
931 my $dbh=C4::Context->dbh;
932 my $rq=$dbh->prepare(qq|
934 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
935 marc_subfield_structure.liblibrarian as subfielddesc,
936 marc_tag_structure.liblibrarian as tagdesc
937 FROM marc_subfield_structure
938 LEFT JOIN marc_tag_structure
939 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
940 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
941 WHERE marc_subfield_structure.tab>=0
942 ORDER BY tagsubfield|);
944 my $data=$rq->fetchall_arrayref({});