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 {
270 WHERE itemtype IN (' . join( ',', map( { "'" . $_ . "'" } @itemtypes ) ) . ')
273 return get_infos_of( $query, 'itemtype' );
276 # this is temporary until we separate collection codes and item types
280 my $dbh = C4::Context->dbh;
283 "SELECT * FROM authorised_values ORDER BY authorised_value");
285 while ( my $data = $sth->fetchrow_hashref ) {
286 if ( $data->{category} eq "CCODE" ) {
288 $results[$count] = $data;
294 return ( $count, @results );
299 $authtypes = &getauthtypes();
301 Returns information about existing authtypes.
303 build a HTML select with the following code :
305 =head3 in PERL SCRIPT
307 my $authtypes = getauthtypes;
309 foreach my $thisauthtype (keys %$authtypes) {
310 my $selected = 1 if $thisauthtype eq $authtype;
311 my %row =(value => $thisauthtype,
312 selected => $selected,
313 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
315 push @authtypesloop, \%row;
317 $template->param(itemtypeloop => \@itemtypesloop);
321 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
322 <select name="authtype">
323 <!-- TMPL_LOOP name="authtypeloop" -->
324 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
327 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
328 <input type="submit" value="OK" class="button">
336 # returns a reference to a hash of references to authtypes...
338 my $dbh = C4::Context->dbh;
339 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
341 while ( my $IT = $sth->fetchrow_hashref ) {
342 $authtypes{ $IT->{'authtypecode'} } = $IT;
344 return ( \%authtypes );
348 my ($authtypecode) = @_;
350 # returns a reference to a hash of references to authtypes...
352 my $dbh = C4::Context->dbh;
353 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
354 $sth->execute($authtypecode);
355 my $res = $sth->fetchrow_hashref;
361 $frameworks = &getframework();
363 Returns information about existing frameworks
365 build a HTML select with the following code :
367 =head3 in PERL SCRIPT
369 my $frameworks = frameworks();
371 foreach my $thisframework (keys %$frameworks) {
372 my $selected = 1 if $thisframework eq $frameworkcode;
373 my %row =(value => $thisframework,
374 selected => $selected,
375 description => $frameworks->{$thisframework}->{'frameworktext'},
377 push @frameworksloop, \%row;
379 $template->param(frameworkloop => \@frameworksloop);
383 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
384 <select name="frameworkcode">
385 <option value="">Default</option>
386 <!-- TMPL_LOOP name="frameworkloop" -->
387 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
390 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
391 <input type="submit" value="OK" class="button">
399 # returns a reference to a hash of references to branches...
401 my $dbh = C4::Context->dbh;
402 my $sth = $dbh->prepare("select * from biblio_framework");
404 while ( my $IT = $sth->fetchrow_hashref ) {
405 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
407 return ( \%itemtypes );
410 =head2 getframeworkinfo
412 $frameworkinfo = &getframeworkinfo($frameworkcode);
414 Returns information about an frameworkcode.
418 sub getframeworkinfo {
419 my ($frameworkcode) = @_;
420 my $dbh = C4::Context->dbh;
422 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
423 $sth->execute($frameworkcode);
424 my $res = $sth->fetchrow_hashref;
428 =head2 getitemtypeinfo
430 $itemtype = &getitemtype($itemtype);
432 Returns information about an itemtype.
436 sub getitemtypeinfo {
438 my $dbh = C4::Context->dbh;
439 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
440 $sth->execute($itemtype);
441 my $res = $sth->fetchrow_hashref;
443 $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
448 sub getitemtypeimagesrcfromurl {
451 if ( defined $imageurl and $imageurl !~ m/^http/ ) {
452 $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
458 sub getitemtypeimagedir {
459 return C4::Context->opachtdocs . '/'
460 . C4::Context->preference('template')
464 sub getitemtypeimagesrc {
465 return '/opac-tmpl' . '/'
466 . C4::Context->preference('template')
472 $printers = &GetPrinters();
473 @queues = keys %$printers;
475 Returns information about existing printer queues.
477 C<$printers> is a reference-to-hash whose keys are the print queues
478 defined in the printers table of the Koha database. The values are
479 references-to-hash, whose keys are the fields in the printers table.
485 my $dbh = C4::Context->dbh;
486 my $sth = $dbh->prepare("select * from printers");
488 while ( my $printer = $sth->fetchrow_hashref ) {
489 $printers{ $printer->{'printqueue'} } = $printer;
491 return ( \%printers );
496 $printer = GetPrinter( $query, $printers );
500 sub GetPrinter ($$) {
501 my ( $query, $printers ) = @_; # get printer for this query from printers
502 my $printer = $query->param('printer');
503 my %cookie = $query->cookie('userenv');
504 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
505 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
511 Returns the number of pages to display in a pagination bar, given the number
512 of items and the number of items per page.
517 my ( $nb_items, $nb_items_per_page ) = @_;
519 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
524 (@themes) = &getallthemes('opac');
525 (@themes) = &getallthemes('intranet');
527 Returns an array of all available themes.
535 if ( $type eq 'intranet' ) {
536 $htdocs = C4::Context->config('intrahtdocs');
539 $htdocs = C4::Context->config('opachtdocs');
541 opendir D, "$htdocs";
542 my @dirlist = readdir D;
543 foreach my $directory (@dirlist) {
544 -d "$htdocs/$directory/en" and push @themes, $directory;
551 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
554 link_value => 'su-to',
555 label_value => 'Topics',
557 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
561 link_value => 'su-geo',
562 label_value => 'Places',
567 link_value => 'su-ut',
568 label_value => 'Titles',
569 tags => [ '500', '501', '502', '503', '504', ],
574 label_value => 'Authors',
575 tags => [ '700', '701', '702', ],
580 label_value => 'Series',
585 link_value => 'branch',
586 label_value => 'Libraries',
596 link_value => 'su-to',
597 label_value => 'Topics',
603 # link_value => 'su-na',
604 # label_value => 'People and Organizations',
605 # tags => ['600', '610', '611'],
609 link_value => 'su-geo',
610 label_value => 'Places',
615 link_value => 'su-ut',
616 label_value => 'Titles',
622 label_value => 'Authors',
623 tags => [ '100', '110', '700', ],
628 label_value => 'Series',
629 tags => [ '440', '490', ],
633 link_value => 'branch',
634 label_value => 'Libraries',
646 Return a href where a key is associated to a href. You give a query, the
647 name of the key among the fields returned by the query. If you also give as
648 third argument the name of the value, the function returns a href of scalar.
657 # generic href of any information on the item, href of href.
658 my $iteminfos_of = get_infos_of($query, 'itemnumber');
659 print $iteminfos_of->{$itemnumber}{barcode};
661 # specific information, href of scalar
662 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
663 print $barcode_of_item->{$itemnumber};
668 my ( $query, $key_name, $value_name ) = @_;
670 my $dbh = C4::Context->dbh;
672 my $sth = $dbh->prepare($query);
676 while ( my $row = $sth->fetchrow_hashref ) {
677 if ( defined $value_name ) {
678 $infos_of{ $row->{$key_name} } = $row->{$value_name};
681 $infos_of{ $row->{$key_name} } = $row;
689 =head2 get_notforloan_label_of
691 my $notforloan_label_of = get_notforloan_label_of();
693 Each authorised value of notforloan (information available in items and
694 itemtypes) is link to a single label.
696 Returns a href where keys are authorised values and values are corresponding
699 foreach my $authorised_value (keys %{$notforloan_label_of}) {
701 "authorised_value: %s => %s\n",
703 $notforloan_label_of->{$authorised_value}
709 # FIXME - why not use GetAuthorisedValues ??
711 sub get_notforloan_label_of {
712 my $dbh = C4::Context->dbh;
715 SELECT authorised_value
716 FROM marc_subfield_structure
717 WHERE kohafield = \'items.notforloan\'
720 my $sth = $dbh->prepare($query);
722 my ($statuscode) = $sth->fetchrow_array();
727 FROM authorised_values
730 $sth = $dbh->prepare($query);
731 $sth->execute($statuscode);
732 my %notforloan_label_of;
733 while ( my $row = $sth->fetchrow_hashref ) {
734 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
738 return \%notforloan_label_of;
742 my ( $position, $type ) = @_;
743 my $dbh = C4::Context->dbh;
744 my $strsth = "SELECT * FROM z3950servers where 1";
745 $strsth .= " AND position=\"$position\"" if ($position);
746 $strsth .= " AND type=\"$type\"" if ($type);
747 my $rq = $dbh->prepare($strsth);
749 my @primaryserverloop;
751 while ( my $data = $rq->fetchrow_hashref ) {
753 $cell{label} = $data->{'description'};
754 $cell{id} = $data->{'name'};
757 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
759 if ( $data->{host} );
760 $cell{checked} = $data->{checked};
761 push @primaryserverloop,
763 label => $data->{description},
766 value => $data->{host} . ":"
767 . $data->{port} . "/"
769 checked => "checked",
770 icon => $data->{icon},
771 zed => $data->{type} eq 'zed',
772 opensearch => $data->{type} eq 'opensearch'
775 return \@primaryserverloop;
778 sub displaySecondaryServers {
780 # my $secondary_servers_loop = [
781 # { inner_sup_servers_loop => [
782 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
783 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
784 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
785 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
789 return; #$secondary_servers_loop;
792 =head2 GetAuthValCode
794 $authvalcode = GetAuthValCode($kohafield,$frameworkcode);
799 my ($kohafield,$fwcode) = @_;
800 my $dbh = C4::Context->dbh;
801 $fwcode='' unless $fwcode;
802 my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?');
803 $sth->execute($kohafield,$fwcode);
804 my ($authvalcode) = $sth->fetchrow_array;
808 =head2 GetAuthorisedValues
810 $authvalues = GetAuthorisedValues($category);
812 this function get all authorised values from 'authosied_value' table into a reference to array which
813 each value containt an hashref.
815 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
819 sub GetAuthorisedValues {
820 my ($category,$selected) = @_;
823 my $dbh = C4::Context->dbh;
824 my $query = "SELECT * FROM authorised_values";
825 $query .= " WHERE category = '" . $category . "'" if $category;
827 my $sth = $dbh->prepare($query);
829 while (my $data=$sth->fetchrow_hashref) {
830 if ($selected eq $data->{'authorised_value'} ) {
831 $data->{'selected'} = 1;
833 $results[$count] = $data;
836 #my $data = $sth->fetchall_arrayref({});
837 return \@results; #$data;
842 $marcrecord = &fixEncoding($marcblob);
844 Returns a well encoded marcrecord.
849 my $record = MARC::Record->new_from_usmarc($marc);
850 if (C4::Context->preference("MARCFLAVOUR") eq "UNIMARC"){
852 my $targetcharset="utf8" if (C4::Context->preference("TemplateEncoding") eq "utf-8");
853 $targetcharset="latin1" if (C4::Context->preference("TemplateEncoding") eq "iso-8859-1");
854 my $decoder = guess_encoding($marc, qw/utf8 latin1/);
855 # die $decoder unless ref($decoder);
857 my $newRecord=MARC::Record->new();
858 foreach my $field ($record->fields()){
859 if ($field->tag()<'010'){
860 $newRecord->insert_grouped_field($field);
864 foreach my $subfield ($field->subfields()){
866 if (($newField->tag eq '100')) {
867 substr($subfield->[1],26,2,"0103") if ($targetcharset eq "latin1");
868 substr($subfield->[1],26,4,"5050") if ($targetcharset eq "utf8");
870 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
871 $newField->add_subfields($subfield->[0]=>$subfield->[1]);
873 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
874 $newField=MARC::Field->new($field->tag(),$field->indicator(1),$field->indicator(2),$subfield->[0]=>$subfield->[1]);
878 $newRecord->insert_grouped_field($newField);
881 # warn $newRecord->as_formatted();
891 =head2 GetKohaAuthorisedValues
893 Takes $dbh , $kohafield as parameters.
894 returns hashref of authvalCode => liblibrarian
895 or undef if no authvals defined for kohafield.
899 sub GetKohaAuthorisedValues {
900 my ($kohafield,$fwcode) = @_;
901 $fwcode='' unless $fwcode;
903 my $dbh = C4::Context->dbh;
904 my $avcode = GetAuthValCode($kohafield,$fwcode);
906 my $sth = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
907 $sth->execute($avcode);
908 while ( my ($val, $lib) = $sth->fetchrow_array ) {
915 =head2 GetManagedTagSubfields
919 $res = GetManagedTagSubfields();
921 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
922 $forlibrarian :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
923 $frameworkcode : the framework code to read
931 sub GetManagedTagSubfields{
932 my $dbh=C4::Context->dbh;
933 my $rq=$dbh->prepare(qq|
935 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
936 marc_subfield_structure.liblibrarian as subfielddesc,
937 marc_tag_structure.liblibrarian as tagdesc
938 FROM marc_subfield_structure
939 LEFT JOIN marc_tag_structure
940 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
941 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
942 WHERE marc_subfield_structure.tab>=0
943 ORDER BY tagsubfield|);
945 my $data=$rq->fetchall_arrayref({});