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 );
108 if ( substr( $isbn, 0, 1 ) <= 7 ) {
109 $seg1 = substr( $isbn, 0, 1 );
111 elsif ( substr( $isbn, 0, 2 ) <= 94 ) {
112 $seg1 = substr( $isbn, 0, 2 );
114 elsif ( substr( $isbn, 0, 3 ) <= 995 ) {
115 $seg1 = substr( $isbn, 0, 3 );
117 elsif ( substr( $isbn, 0, 4 ) <= 9989 ) {
118 $seg1 = substr( $isbn, 0, 4 );
121 $seg1 = substr( $isbn, 0, 5 );
123 my $x = substr( $isbn, length($seg1) );
125 if ( substr( $x, 0, 2 ) <= 19 ) {
127 # if(sTmp2 < 10) sTmp2 = "0" sTmp2;
128 $seg2 = substr( $x, 0, 2 );
130 elsif ( substr( $x, 0, 3 ) <= 699 ) {
131 $seg2 = substr( $x, 0, 3 );
133 elsif ( substr( $x, 0, 4 ) <= 8399 ) {
134 $seg2 = substr( $x, 0, 4 );
136 elsif ( substr( $x, 0, 5 ) <= 89999 ) {
137 $seg2 = substr( $x, 0, 5 );
139 elsif ( substr( $x, 0, 6 ) <= 9499999 ) {
140 $seg2 = substr( $x, 0, 6 );
143 $seg2 = substr( $x, 0, 7 );
145 my $seg3 = substr( $x, length($seg2) );
146 $seg3 = substr( $seg3, 0, length($seg3) - 1 );
147 my $seg4 = substr( $x, -1, 1 );
148 return "$seg1-$seg2-$seg3-$seg4";
151 # FIXME.. this should be moved to a MARC-specific module
152 sub subfield_is_koha_internal_p ($) {
155 # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!)
156 # But real MARC subfields are always single-character
157 # so it really is safer just to check the length
159 return length $subfield != 1;
164 $itemtypes = &GetItemTypes();
166 Returns information about existing itemtypes.
168 build a HTML select with the following code :
170 =head3 in PERL SCRIPT
172 my $itemtypes = GetItemTypes;
174 foreach my $thisitemtype (sort keys %$itemtypes) {
175 my $selected = 1 if $thisitemtype eq $itemtype;
176 my %row =(value => $thisitemtype,
177 selected => $selected,
178 description => $itemtypes->{$thisitemtype}->{'description'},
180 push @itemtypesloop, \%row;
182 $template->param(itemtypeloop => \@itemtypesloop);
186 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
187 <select name="itemtype">
188 <option value="">Default</option>
189 <!-- TMPL_LOOP name="itemtypeloop" -->
190 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
193 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
194 <input type="submit" value="OK" class="button">
201 # returns a reference to a hash of references to branches...
203 my $dbh = C4::Context->dbh;
208 my $sth = $dbh->prepare($query);
210 while ( my $IT = $sth->fetchrow_hashref ) {
211 $itemtypes{ $IT->{'itemtype'} } = $IT;
213 return ( \%itemtypes );
216 sub get_itemtypeinfos_of {
224 WHERE itemtype IN (' . join( ',', map( { "'" . $_ . "'" } @itemtypes ) ) . ')
227 return get_infos_of( $query, 'itemtype' );
230 # this is temporary until we separate collection codes and item types
234 my $dbh = C4::Context->dbh;
237 "SELECT * FROM authorised_values ORDER BY authorised_value");
239 while ( my $data = $sth->fetchrow_hashref ) {
240 if ( $data->{category} eq "CCODE" ) {
242 $results[$count] = $data;
248 return ( $count, @results );
253 grab itemlost authorized values
257 sub GetAuthItemlost {
258 my $itemlost = shift;
261 my $dbh = C4::Context->dbh;
264 "SELECT * FROM authorised_values ORDER BY authorised_value");
266 while ( my $data = $sth->fetchrow_hashref ) {
267 if ( $data->{category} eq "ITEMLOST" ) {
269 if ( $itemlost eq $data->{'authorised_value'} ) {
270 $data->{'selected'} = 1;
272 $results[$count] = $data;
278 return ( $count, @results );
283 $authtypes = &getauthtypes();
285 Returns information about existing authtypes.
287 build a HTML select with the following code :
289 =head3 in PERL SCRIPT
291 my $authtypes = getauthtypes;
293 foreach my $thisauthtype (keys %$authtypes) {
294 my $selected = 1 if $thisauthtype eq $authtype;
295 my %row =(value => $thisauthtype,
296 selected => $selected,
297 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
299 push @authtypesloop, \%row;
301 $template->param(itemtypeloop => \@itemtypesloop);
305 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
306 <select name="authtype">
307 <!-- TMPL_LOOP name="authtypeloop" -->
308 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
311 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
312 <input type="submit" value="OK" class="button">
320 # returns a reference to a hash of references to authtypes...
322 my $dbh = C4::Context->dbh;
323 my $sth = $dbh->prepare("select * from auth_types order by authtypetext");
325 while ( my $IT = $sth->fetchrow_hashref ) {
326 $authtypes{ $IT->{'authtypecode'} } = $IT;
328 return ( \%authtypes );
332 my ($authtypecode) = @_;
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 where authtypecode=?");
338 $sth->execute($authtypecode);
339 my $res = $sth->fetchrow_hashref;
345 $frameworks = &getframework();
347 Returns information about existing frameworks
349 build a HTML select with the following code :
351 =head3 in PERL SCRIPT
353 my $frameworks = frameworks();
355 foreach my $thisframework (keys %$frameworks) {
356 my $selected = 1 if $thisframework eq $frameworkcode;
357 my %row =(value => $thisframework,
358 selected => $selected,
359 description => $frameworks->{$thisframework}->{'frameworktext'},
361 push @frameworksloop, \%row;
363 $template->param(frameworkloop => \@frameworksloop);
367 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
368 <select name="frameworkcode">
369 <option value="">Default</option>
370 <!-- TMPL_LOOP name="frameworkloop" -->
371 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
374 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
375 <input type="submit" value="OK" class="button">
383 # returns a reference to a hash of references to branches...
385 my $dbh = C4::Context->dbh;
386 my $sth = $dbh->prepare("select * from biblio_framework");
388 while ( my $IT = $sth->fetchrow_hashref ) {
389 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
391 return ( \%itemtypes );
394 =head2 getframeworkinfo
396 $frameworkinfo = &getframeworkinfo($frameworkcode);
398 Returns information about an frameworkcode.
402 sub getframeworkinfo {
403 my ($frameworkcode) = @_;
404 my $dbh = C4::Context->dbh;
406 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
407 $sth->execute($frameworkcode);
408 my $res = $sth->fetchrow_hashref;
412 =head2 getitemtypeinfo
414 $itemtype = &getitemtype($itemtype);
416 Returns information about an itemtype.
420 sub getitemtypeinfo {
422 my $dbh = C4::Context->dbh;
423 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
424 $sth->execute($itemtype);
425 my $res = $sth->fetchrow_hashref;
427 $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
432 sub getitemtypeimagesrcfromurl {
435 if ( defined $imageurl and $imageurl !~ m/^http/ ) {
436 $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
442 sub getitemtypeimagedir {
443 return C4::Context->opachtdocs . '/'
444 . C4::Context->preference('template')
448 sub getitemtypeimagesrc {
449 return '/opac-tmpl' . '/'
450 . C4::Context->preference('template')
456 $printers = &GetPrinters();
457 @queues = keys %$printers;
459 Returns information about existing printer queues.
461 C<$printers> is a reference-to-hash whose keys are the print queues
462 defined in the printers table of the Koha database. The values are
463 references-to-hash, whose keys are the fields in the printers table.
469 my $dbh = C4::Context->dbh;
470 my $sth = $dbh->prepare("select * from printers");
472 while ( my $printer = $sth->fetchrow_hashref ) {
473 $printers{ $printer->{'printqueue'} } = $printer;
475 return ( \%printers );
480 $printer = GetPrinter( $query, $printers );
484 sub GetPrinter ($$) {
485 my ( $query, $printers ) = @_; # get printer for this query from printers
486 my $printer = $query->param('printer');
487 my %cookie = $query->cookie('userenv');
488 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
489 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
495 Returns the number of pages to display in a pagination bar, given the number
496 of items and the number of items per page.
501 my ( $nb_items, $nb_items_per_page ) = @_;
503 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
508 (@themes) = &getallthemes('opac');
509 (@themes) = &getallthemes('intranet');
511 Returns an array of all available themes.
519 if ( $type eq 'intranet' ) {
520 $htdocs = C4::Context->config('intrahtdocs');
523 $htdocs = C4::Context->config('opachtdocs');
525 opendir D, "$htdocs";
526 my @dirlist = readdir D;
527 foreach my $directory (@dirlist) {
528 -d "$htdocs/$directory/en" and push @themes, $directory;
535 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
538 link_value => 'su-to',
539 label_value => 'Topics',
541 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
545 link_value => 'su-geo',
546 label_value => 'Places',
551 link_value => 'su-ut',
552 label_value => 'Titles',
553 tags => [ '500', '501', '502', '503', '504', ],
558 label_value => 'Authors',
559 tags => [ '700', '701', '702', ],
564 label_value => 'Series',
569 link_value => 'branch',
570 label_value => 'Branches',
580 link_value => 'su-to',
581 label_value => 'Topics',
587 # link_value => 'su-na',
588 # label_value => 'People and Organizations',
589 # tags => ['600', '610', '611'],
593 link_value => 'su-geo',
594 label_value => 'Places',
599 link_value => 'su-ut',
600 label_value => 'Titles',
606 label_value => 'Authors',
607 tags => [ '100', '110', '700', ],
612 label_value => 'Series',
613 tags => [ '440', '490', ],
617 link_value => 'branch',
618 label_value => 'Branches',
630 Return a href where a key is associated to a href. You give a query, the
631 name of the key among the fields returned by the query. If you also give as
632 third argument the name of the value, the function returns a href of scalar.
641 # generic href of any information on the item, href of href.
642 my $iteminfos_of = get_infos_of($query, 'itemnumber');
643 print $iteminfos_of->{$itemnumber}{barcode};
645 # specific information, href of scalar
646 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
647 print $barcode_of_item->{$itemnumber};
652 my ( $query, $key_name, $value_name ) = @_;
654 my $dbh = C4::Context->dbh;
656 my $sth = $dbh->prepare($query);
660 while ( my $row = $sth->fetchrow_hashref ) {
661 if ( defined $value_name ) {
662 $infos_of{ $row->{$key_name} } = $row->{$value_name};
665 $infos_of{ $row->{$key_name} } = $row;
673 =head2 get_notforloan_label_of
675 my $notforloan_label_of = get_notforloan_label_of();
677 Each authorised value of notforloan (information available in items and
678 itemtypes) is link to a single label.
680 Returns a href where keys are authorised values and values are corresponding
683 foreach my $authorised_value (keys %{$notforloan_label_of}) {
685 "authorised_value: %s => %s\n",
687 $notforloan_label_of->{$authorised_value}
693 sub get_notforloan_label_of {
694 my $dbh = C4::Context->dbh;
697 SELECT authorised_value
698 FROM marc_subfield_structure
699 WHERE kohafield = \'items.notforloan\'
702 my $sth = $dbh->prepare($query);
704 my ($statuscode) = $sth->fetchrow_array();
709 FROM authorised_values
712 $sth = $dbh->prepare($query);
713 $sth->execute($statuscode);
714 my %notforloan_label_of;
715 while ( my $row = $sth->fetchrow_hashref ) {
716 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
720 return \%notforloan_label_of;
724 my ( $position, $type ) = @_;
725 my $dbh = C4::Context->dbh;
726 my $strsth = "SELECT * FROM z3950servers where 1";
727 $strsth .= " AND position=\"$position\"" if ($position);
728 $strsth .= " AND type=\"$type\"" if ($type);
729 my $rq = $dbh->prepare($strsth);
731 my @primaryserverloop;
733 while ( my $data = $rq->fetchrow_hashref ) {
735 $cell{label} = $data->{'description'};
736 $cell{id} = $data->{'name'};
739 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
741 if ( $data->{host} );
742 $cell{checked} = $data->{checked};
743 push @primaryserverloop,
745 label => $data->{description},
748 value => $data->{host} . ":"
749 . $data->{port} . "/"
751 checked => "checked",
752 icon => $data->{icon},
753 zed => $data->{type} eq 'zed',
754 opensearch => $data->{type} eq 'opensearch'
757 return \@primaryserverloop;
760 sub displaySecondaryServers {
762 # my $secondary_servers_loop = [
763 # { inner_sup_servers_loop => [
764 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
765 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
766 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
767 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
771 return; #$secondary_servers_loop;
774 =head2 GetAuthorisedValues
776 $authvalues = GetAuthorisedValues($category);
778 this function get all authorised values from 'authosied_value' table into a reference to array which
779 each value containt an hashref.
781 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
785 sub GetAuthorisedValues {
786 my $category = shift;
787 my $dbh = C4::Context->dbh;
788 my $query = "SELECT * FROM authorised_values";
789 $query .= " WHERE category = '" . $category . "'" if $category;
791 my $sth = $dbh->prepare($query);
793 my $data = $sth->fetchall_arrayref({});
799 $marcrecord = &fixEncoding($marcblob);
801 Returns a well encoded marcrecord.
806 my $record = MARC::Record->new_from_usmarc($marc);
807 if (C4::Context->preference("MARCFLAVOUR") eq "UNIMARC"){
809 my $targetcharset="utf8" if (C4::Context->preference("TemplateEncoding") eq "utf-8");
810 $targetcharset="latin1" if (C4::Context->preference("TemplateEncoding") eq "iso-8859-1");
811 my $decoder = guess_encoding($marc, qw/utf8 latin1/);
812 # die $decoder unless ref($decoder);
814 my $newRecord=MARC::Record->new();
815 foreach my $field ($record->fields()){
816 if ($field->tag()<'010'){
817 $newRecord->insert_grouped_field($field);
821 foreach my $subfield ($field->subfields()){
823 if (($newField->tag eq '100')) {
824 substr($subfield->[1],26,2,"0103") if ($targetcharset eq "latin1");
825 substr($subfield->[1],26,4,"5050") if ($targetcharset eq "utf8");
827 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
828 $newField->add_subfields($subfield->[0]=>$subfield->[1]);
830 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
831 $newField=MARC::Field->new($field->tag(),$field->indicator(1),$field->indicator(2),$subfield->[0]=>$subfield->[1]);
835 $newRecord->insert_grouped_field($newField);
838 # warn $newRecord->as_formatted();
848 =head2 GetKohaAuthorisedValues
850 Takes $dbh , $kohafield as parameters.
851 returns hashref of authvalCode => liblibrarian
852 or undef if no authvals defined for kohafield.
856 sub GetKohaAuthorisedValues {
857 my ($kohafield) = @_;
859 my $dbh = C4::Context->dbh;
860 my $sthnflstatus = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=?');
861 $sthnflstatus->execute($kohafield);
862 my $authorised_valuecode = $sthnflstatus->fetchrow;
863 if ($authorised_valuecode) {
864 $sthnflstatus = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
865 $sthnflstatus->execute($authorised_valuecode);
866 while ( my ($val, $lib) = $sthnflstatus->fetchrow_array ) {
873 =head2 GetManagedTagSubfields
877 $res = GetManagedTagSubfields();
879 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
880 $forlibrarian :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
881 $frameworkcode : the framework code to read
889 sub GetManagedTagSubfields{
890 my $dbh=C4::Context->dbh;
891 my $rq=$dbh->prepare(qq|
893 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
894 marc_subfield_structure.liblibrarian as subfielddesc,
895 marc_tag_structure.liblibrarian as tagdesc
896 FROM marc_subfield_structure
897 LEFT JOIN marc_tag_structure
898 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
899 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
900 WHERE marc_subfield_structure.tab>=0
901 ORDER BY tagsubfield|);
903 my $data=$rq->fetchall_arrayref({});