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
26 our ($VERSION,@ISA,@EXPORT);
28 $VERSION = do { my @v = '$Revision$' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
32 C4::Koha - Perl Module containing convenience functions for Koha scripts
41 Koha.pm provides many functions for Koha scripts.
53 &subfield_is_koha_internal_p
54 &GetPrinters &GetPrinter
55 &GetItemTypes &getitemtypeinfo
60 &getframeworks &getframeworkinfo
61 &getauthtypes &getauthtype
66 &getitemtypeimagesrcfromurl
68 &get_notforloan_label_of
73 &GetKohaAuthorisedValues
74 &GetManagedTagSubfields
83 $slash_date = &slashifyDate($dash_date);
85 Takes a string of the form "DD-MM-YYYY" (or anything separated by
86 dashes), converts it to the form "YYYY/MM/DD", and returns the result.
92 # accepts a date of the form xx-xx-xx[xx] and returns it in the
94 my @dateOut = split( '-', shift );
95 return ("$dateOut[2]/$dateOut[1]/$dateOut[0]");
101 my $string = DisplayISBN( $isbn );
107 if (length ($isbn)<13){
109 if ( substr( $isbn, 0, 1 ) <= 7 ) {
110 $seg1 = substr( $isbn, 0, 1 );
112 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
113 $seg1 = substr( $isbn, 0, 2 );
115 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
116 $seg1 = substr( $isbn, 0, 3 );
118 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
119 $seg1 = substr( $isbn, 0, 4 );
122 $seg1 = substr( $isbn, 0, 5 );
124 my $x = substr( $isbn, length($seg1) );
126 if ( substr( $x, 0, 2 ) <= 19 ) {
128 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
129 $seg2 = substr( $x, 0, 2 );
131 elsif ( substr( $x, 0, 3 ) <= 699 ) {
132 $seg2 = substr( $x, 0, 3 );
134 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
135 $seg2 = substr( $x, 0, 4 );
137 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
138 $seg2 = substr( $x, 0, 5 );
140 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
141 $seg2 = substr( $x, 0, 6 );
144 $seg2 = substr( $x, 0, 7 );
146 my $seg3 = substr( $x, length($seg2) );
147 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
148 my $seg4 = substr( $x, -1, 1 );
149 return "$seg1-$seg2-$seg3-$seg4";
152 $seg1 = substr( $isbn, 0, 3 );
154 if ( substr( $isbn, 3, 1 ) <= 7 ) {
155 $seg2 = substr( $isbn, 3, 1 );
157 elsif ( substr( $isbn, 3, 2 ) <= 94 ) {
158 $seg2 = substr( $isbn, 3, 2 );
160 elsif ( substr( $isbn, 3, 3 ) <= 995 ) {
161 $seg2 = substr( $isbn, 3, 3 );
163 elsif ( substr( $isbn, 3, 4 ) <= 9989 ) {
164 $seg2 = substr( $isbn, 3, 4 );
167 $seg2 = substr( $isbn, 3, 5 );
169 my $x = substr( $isbn, length($seg2) +3);
171 if ( substr( $x, 0, 2 ) <= 19 ) {
173 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
174 $seg3 = substr( $x, 0, 2 );
176 elsif ( substr( $x, 0, 3 ) <= 699 ) {
177 $seg3 = substr( $x, 0, 3 );
179 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
180 $seg3 = substr( $x, 0, 4 );
182 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
183 $seg3 = substr( $x, 0, 5 );
185 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
186 $seg3 = substr( $x, 0, 6 );
189 $seg3 = substr( $x, 0, 7 );
191 my $seg4 = substr( $x, length($seg3) );
192 $seg4 = substr( $seg4, 0, length($seg4) - 1 );
193 my $seg5 = substr( $x, -1, 1 );
194 return "$seg1-$seg2-$seg3-$seg4-$seg5";
198 # FIXME.. this should be moved to a MARC-specific module
199 sub subfield_is_koha_internal_p ($) {
202 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
203 # But real MARC subfields are always single-character
204 # so it really is safer just to check the length
206 return length $subfield != 1;
211 $itemtypes = &GetItemTypes();
213 Returns information about existing itemtypes.
215 build a HTML select with the following code :
217 =head3 in PERL SCRIPT
219 my $itemtypes = GetItemTypes;
221 foreach my $thisitemtype (sort keys %$itemtypes) {
222 my $selected = 1 if $thisitemtype eq $itemtype;
223 my %row =(value => $thisitemtype,
224 selected => $selected,
225 description => $itemtypes->{$thisitemtype}->{'description'},
227 push @itemtypesloop, \%row;
229 $template->param(itemtypeloop => \@itemtypesloop);
233 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
234 <select name="itemtype">
235 <option value="">Default</option>
236 <!-- TMPL_LOOP name="itemtypeloop" -->
237 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
240 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
241 <input type="submit" value="OK" class="button">
248 # returns a reference to a hash of references to branches...
250 my $dbh = C4::Context->dbh;
255 my $sth = $dbh->prepare($query);
257 while ( my $IT = $sth->fetchrow_hashref ) {
258 $itemtypes{ $IT->{'itemtype'} } = $IT;
260 return ( \%itemtypes );
263 sub get_itemtypeinfos_of {
271 WHERE itemtype IN (' . join( ',', map( { "'" . $_ . "'" } @itemtypes ) ) . ')
274 return get_infos_of( $query, 'itemtype' );
277 # this is temporary until we separate collection codes and item types
281 my $dbh = C4::Context->dbh;
284 "SELECT * FROM authorised_values ORDER BY authorised_value");
286 while ( my $data = $sth->fetchrow_hashref ) {
287 if ( $data->{category} eq "CCODE" ) {
289 $results[$count] = $data;
295 return ( $count, @results );
300 grab itemlost authorized values
304 sub GetAuthItemlost {
305 my $itemlost = shift;
308 my $dbh = C4::Context->dbh;
311 "SELECT * FROM authorised_values ORDER BY authorised_value");
313 while ( my $data = $sth->fetchrow_hashref ) {
314 if ( $data->{category} eq "ITEMLOST" ) {
316 if ( $itemlost eq $data->{'authorised_value'} ) {
317 $data->{'selected'} = 1;
319 $results[$count] = $data;
325 return ( $count, @results );
330 $authtypes = &getauthtypes();
332 Returns information about existing authtypes.
334 build a HTML select with the following code :
336 =head3 in PERL SCRIPT
338 my $authtypes = getauthtypes;
340 foreach my $thisauthtype (keys %$authtypes) {
341 my $selected = 1 if $thisauthtype eq $authtype;
342 my %row =(value => $thisauthtype,
343 selected => $selected,
344 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
346 push @authtypesloop, \%row;
348 $template->param(itemtypeloop => \@itemtypesloop);
352 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
353 <select name="authtype">
354 <!-- TMPL_LOOP name="authtypeloop" -->
355 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
358 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
359 <input type="submit" value="OK" class="button">
367 # returns a reference to a hash of references to authtypes...
369 my $dbh = C4::Context->dbh;
370 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
372 while ( my $IT = $sth->fetchrow_hashref ) {
373 $authtypes{ $IT->{'authtypecode'} } = $IT;
375 return ( \%authtypes );
379 my ($authtypecode) = @_;
381 # returns a reference to a hash of references to authtypes...
383 my $dbh = C4::Context->dbh;
384 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
385 $sth->execute($authtypecode);
386 my $res = $sth->fetchrow_hashref;
392 $frameworks = &getframework();
394 Returns information about existing frameworks
396 build a HTML select with the following code :
398 =head3 in PERL SCRIPT
400 my $frameworks = frameworks();
402 foreach my $thisframework (keys %$frameworks) {
403 my $selected = 1 if $thisframework eq $frameworkcode;
404 my %row =(value => $thisframework,
405 selected => $selected,
406 description => $frameworks->{$thisframework}->{'frameworktext'},
408 push @frameworksloop, \%row;
410 $template->param(frameworkloop => \@frameworksloop);
414 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
415 <select name="frameworkcode">
416 <option value="">Default</option>
417 <!-- TMPL_LOOP name="frameworkloop" -->
418 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
421 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
422 <input type="submit" value="OK" class="button">
430 # returns a reference to a hash of references to branches...
432 my $dbh = C4::Context->dbh;
433 my $sth = $dbh->prepare("select * from biblio_framework");
435 while ( my $IT = $sth->fetchrow_hashref ) {
436 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
438 return ( \%itemtypes );
441 =head2 getframeworkinfo
443 $frameworkinfo = &getframeworkinfo($frameworkcode);
445 Returns information about an frameworkcode.
449 sub getframeworkinfo {
450 my ($frameworkcode) = @_;
451 my $dbh = C4::Context->dbh;
453 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
454 $sth->execute($frameworkcode);
455 my $res = $sth->fetchrow_hashref;
459 =head2 getitemtypeinfo
461 $itemtype = &getitemtype($itemtype);
463 Returns information about an itemtype.
467 sub getitemtypeinfo {
469 my $dbh = C4::Context->dbh;
470 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
471 $sth->execute($itemtype);
472 my $res = $sth->fetchrow_hashref;
474 $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
479 sub getitemtypeimagesrcfromurl {
482 if ( defined $imageurl and $imageurl !~ m/^http/ ) {
483 $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
489 sub getitemtypeimagedir {
490 return C4::Context->opachtdocs . '/'
491 . C4::Context->preference('template')
495 sub getitemtypeimagesrc {
496 return '/opac-tmpl' . '/'
497 . C4::Context->preference('template')
503 $printers = &GetPrinters();
504 @queues = keys %$printers;
506 Returns information about existing printer queues.
508 C<$printers> is a reference-to-hash whose keys are the print queues
509 defined in the printers table of the Koha database. The values are
510 references-to-hash, whose keys are the fields in the printers table.
516 my $dbh = C4::Context->dbh;
517 my $sth = $dbh->prepare("select * from printers");
519 while ( my $printer = $sth->fetchrow_hashref ) {
520 $printers{ $printer->{'printqueue'} } = $printer;
522 return ( \%printers );
527 $printer = GetPrinter( $query, $printers );
531 sub GetPrinter ($$) {
532 my ( $query, $printers ) = @_; # get printer for this query from printers
533 my $printer = $query->param('printer');
534 my %cookie = $query->cookie('userenv');
535 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
536 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
542 Returns the number of pages to display in a pagination bar, given the number
543 of items and the number of items per page.
548 my ( $nb_items, $nb_items_per_page ) = @_;
550 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
555 (@themes) = &getallthemes('opac');
556 (@themes) = &getallthemes('intranet');
558 Returns an array of all available themes.
566 if ( $type eq 'intranet' ) {
567 $htdocs = C4::Context->config('intrahtdocs');
570 $htdocs = C4::Context->config('opachtdocs');
572 opendir D, "$htdocs";
573 my @dirlist = readdir D;
574 foreach my $directory (@dirlist) {
575 -d "$htdocs/$directory/en" and push @themes, $directory;
582 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
585 link_value => 'su-to',
586 label_value => 'Topics',
588 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
592 link_value => 'su-geo',
593 label_value => 'Places',
598 link_value => 'su-ut',
599 label_value => 'Titles',
600 tags => [ '500', '501', '502', '503', '504', ],
605 label_value => 'Authors',
606 tags => [ '700', '701', '702', ],
611 label_value => 'Series',
616 link_value => 'branch',
617 label_value => 'Branches',
627 link_value => 'su-to',
628 label_value => 'Topics',
634 # link_value => 'su-na',
635 # label_value => 'People and Organizations',
636 # tags => ['600', '610', '611'],
640 link_value => 'su-geo',
641 label_value => 'Places',
646 link_value => 'su-ut',
647 label_value => 'Titles',
653 label_value => 'Authors',
654 tags => [ '100', '110', '700', ],
659 label_value => 'Series',
660 tags => [ '440', '490', ],
664 link_value => 'branch',
665 label_value => 'Branches',
677 Return a href where a key is associated to a href. You give a query, the
678 name of the key among the fields returned by the query. If you also give as
679 third argument the name of the value, the function returns a href of scalar.
688 # generic href of any information on the item, href of href.
689 my $iteminfos_of = get_infos_of($query, 'itemnumber');
690 print $iteminfos_of->{$itemnumber}{barcode};
692 # specific information, href of scalar
693 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
694 print $barcode_of_item->{$itemnumber};
699 my ( $query, $key_name, $value_name ) = @_;
701 my $dbh = C4::Context->dbh;
703 my $sth = $dbh->prepare($query);
707 while ( my $row = $sth->fetchrow_hashref ) {
708 if ( defined $value_name ) {
709 $infos_of{ $row->{$key_name} } = $row->{$value_name};
712 $infos_of{ $row->{$key_name} } = $row;
720 =head2 get_notforloan_label_of
722 my $notforloan_label_of = get_notforloan_label_of();
724 Each authorised value of notforloan (information available in items and
725 itemtypes) is link to a single label.
727 Returns a href where keys are authorised values and values are corresponding
730 foreach my $authorised_value (keys %{$notforloan_label_of}) {
732 "authorised_value: %s => %s\n",
734 $notforloan_label_of->{$authorised_value}
740 sub get_notforloan_label_of {
741 my $dbh = C4::Context->dbh;
744 SELECT authorised_value
745 FROM marc_subfield_structure
746 WHERE kohafield = \'items.notforloan\'
749 my $sth = $dbh->prepare($query);
751 my ($statuscode) = $sth->fetchrow_array();
756 FROM authorised_values
759 $sth = $dbh->prepare($query);
760 $sth->execute($statuscode);
761 my %notforloan_label_of;
762 while ( my $row = $sth->fetchrow_hashref ) {
763 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
767 return \%notforloan_label_of;
771 my ( $position, $type ) = @_;
772 my $dbh = C4::Context->dbh;
773 my $strsth = "SELECT * FROM z3950servers where 1";
774 $strsth .= " AND position=\"$position\"" if ($position);
775 $strsth .= " AND type=\"$type\"" if ($type);
776 my $rq = $dbh->prepare($strsth);
778 my @primaryserverloop;
780 while ( my $data = $rq->fetchrow_hashref ) {
782 $cell{label} = $data->{'description'};
783 $cell{id} = $data->{'name'};
786 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
788 if ( $data->{host} );
789 $cell{checked} = $data->{checked};
790 push @primaryserverloop,
792 label => $data->{description},
795 value => $data->{host} . ":"
796 . $data->{port} . "/"
798 checked => "checked",
799 icon => $data->{icon},
800 zed => $data->{type} eq 'zed',
801 opensearch => $data->{type} eq 'opensearch'
804 return \@primaryserverloop;
807 sub displaySecondaryServers {
809 # my $secondary_servers_loop = [
810 # { inner_sup_servers_loop => [
811 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
812 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
813 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
814 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
818 return; #$secondary_servers_loop;
821 =head2 GetAuthorisedValues
823 $authvalues = GetAuthorisedValues($category);
825 this function get all authorised values from 'authosied_value' table into a reference to array which
826 each value containt an hashref.
828 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
832 sub GetAuthorisedValues {
833 my $category = shift;
834 my $dbh = C4::Context->dbh;
835 my $query = "SELECT * FROM authorised_values";
836 $query .= " WHERE category = '" . $category . "'" if $category;
838 my $sth = $dbh->prepare($query);
840 my $data = $sth->fetchall_arrayref({});
846 $marcrecord = &fixEncoding($marcblob);
848 Returns a well encoded marcrecord.
853 my $record = MARC::Record->new_from_usmarc($marc);
854 if (C4::Context->preference("MARCFLAVOUR") eq "UNIMARC"){
856 my $targetcharset="utf8" if (C4::Context->preference("TemplateEncoding") eq "utf-8");
857 $targetcharset="latin1" if (C4::Context->preference("TemplateEncoding") eq "iso-8859-1");
858 my $decoder = guess_encoding($marc, qw/utf8 latin1/);
859 # die $decoder unless ref($decoder);
861 my $newRecord=MARC::Record->new();
862 foreach my $field ($record->fields()){
863 if ($field->tag()<'010'){
864 $newRecord->insert_grouped_field($field);
868 foreach my $subfield ($field->subfields()){
870 if (($newField->tag eq '100')) {
871 substr($subfield->[1],26,2,"0103") if ($targetcharset eq "latin1");
872 substr($subfield->[1],26,4,"5050") if ($targetcharset eq "utf8");
874 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
875 $newField->add_subfields($subfield->[0]=>$subfield->[1]);
877 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
878 $newField=MARC::Field->new($field->tag(),$field->indicator(1),$field->indicator(2),$subfield->[0]=>$subfield->[1]);
882 $newRecord->insert_grouped_field($newField);
885 # warn $newRecord->as_formatted();
895 =head2 GetKohaAuthorisedValues
897 Takes $dbh , $kohafield as parameters.
898 returns hashref of authvalCode => liblibrarian
899 or undef if no authvals defined for kohafield.
903 sub GetKohaAuthorisedValues {
904 my ($kohafield) = @_;
906 my $dbh = C4::Context->dbh;
907 my $sthnflstatus = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=?');
908 $sthnflstatus->execute($kohafield);
909 my $authorised_valuecode = $sthnflstatus->fetchrow;
910 if ($authorised_valuecode) {
911 $sthnflstatus = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
912 $sthnflstatus->execute($authorised_valuecode);
913 while ( my ($val, $lib) = $sthnflstatus->fetchrow_array ) {
920 =head2 GetManagedTagSubfields
924 $res = GetManagedTagSubfields();
926 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
927 $forlibrarian :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
928 $frameworkcode : the framework code to read
936 sub GetManagedTagSubfields{
937 my $dbh=C4::Context->dbh;
938 my $rq=$dbh->prepare(qq|
940 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
941 marc_subfield_structure.liblibrarian as subfielddesc,
942 marc_tag_structure.liblibrarian as tagdesc
943 FROM marc_subfield_structure
944 LEFT JOIN marc_tag_structure
945 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
946 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
947 WHERE marc_subfield_structure.tab>=0
948 ORDER BY tagsubfield|);
950 my $data=$rq->fetchall_arrayref({});