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 );
281 =head2 GetAuthItembinding
283 grab itemlost authorized values
287 sub GetAuthItembinding {
288 my $itembinding = shift;
291 my $dbh = C4::Context->dbh;
294 "SELECT * FROM authorised_values ORDER BY authorised_value");
296 while ( my $data = $sth->fetchrow_hashref ) {
297 if ( $data->{category} eq "BINDING" ) {
299 if ( $itembinding eq $data->{'authorised_value'} ) {
300 $data->{'selected'} = 1;
302 $results[$count] = $data;
308 return ( $count, @results );
313 $authtypes = &getauthtypes();
315 Returns information about existing authtypes.
317 build a HTML select with the following code :
319 =head3 in PERL SCRIPT
321 my $authtypes = getauthtypes;
323 foreach my $thisauthtype (keys %$authtypes) {
324 my $selected = 1 if $thisauthtype eq $authtype;
325 my %row =(value => $thisauthtype,
326 selected => $selected,
327 authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
329 push @authtypesloop, \%row;
331 $template->param(itemtypeloop => \@itemtypesloop);
335 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
336 <select name="authtype">
337 <!-- TMPL_LOOP name="authtypeloop" -->
338 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
341 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
342 <input type="submit" value="OK" class="button">
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 order by authtypetext");
355 while ( my $IT = $sth->fetchrow_hashref ) {
356 $authtypes{ $IT->{'authtypecode'} } = $IT;
358 return ( \%authtypes );
362 my ($authtypecode) = @_;
364 # returns a reference to a hash of references to authtypes...
366 my $dbh = C4::Context->dbh;
367 my $sth = $dbh->prepare("select * from auth_types where authtypecode=?");
368 $sth->execute($authtypecode);
369 my $res = $sth->fetchrow_hashref;
375 $frameworks = &getframework();
377 Returns information about existing frameworks
379 build a HTML select with the following code :
381 =head3 in PERL SCRIPT
383 my $frameworks = frameworks();
385 foreach my $thisframework (keys %$frameworks) {
386 my $selected = 1 if $thisframework eq $frameworkcode;
387 my %row =(value => $thisframework,
388 selected => $selected,
389 description => $frameworks->{$thisframework}->{'frameworktext'},
391 push @frameworksloop, \%row;
393 $template->param(frameworkloop => \@frameworksloop);
397 <form action='<!-- TMPL_VAR name="script_name" -->' method=post>
398 <select name="frameworkcode">
399 <option value="">Default</option>
400 <!-- TMPL_LOOP name="frameworkloop" -->
401 <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
404 <input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
405 <input type="submit" value="OK" class="button">
413 # returns a reference to a hash of references to branches...
415 my $dbh = C4::Context->dbh;
416 my $sth = $dbh->prepare("select * from biblio_framework");
418 while ( my $IT = $sth->fetchrow_hashref ) {
419 $itemtypes{ $IT->{'frameworkcode'} } = $IT;
421 return ( \%itemtypes );
424 =head2 getframeworkinfo
426 $frameworkinfo = &getframeworkinfo($frameworkcode);
428 Returns information about an frameworkcode.
432 sub getframeworkinfo {
433 my ($frameworkcode) = @_;
434 my $dbh = C4::Context->dbh;
436 $dbh->prepare("select * from biblio_framework where frameworkcode=?");
437 $sth->execute($frameworkcode);
438 my $res = $sth->fetchrow_hashref;
442 =head2 getitemtypeinfo
444 $itemtype = &getitemtype($itemtype);
446 Returns information about an itemtype.
450 sub getitemtypeinfo {
452 my $dbh = C4::Context->dbh;
453 my $sth = $dbh->prepare("select * from itemtypes where itemtype=?");
454 $sth->execute($itemtype);
455 my $res = $sth->fetchrow_hashref;
457 $res->{imageurl} = getitemtypeimagesrcfromurl( $res->{imageurl} );
462 sub getitemtypeimagesrcfromurl {
465 if ( defined $imageurl and $imageurl !~ m/^http/ ) {
466 $imageurl = getitemtypeimagesrc() . '/' . $imageurl;
472 sub getitemtypeimagedir {
473 return C4::Context->opachtdocs . '/'
474 . C4::Context->preference('template')
478 sub getitemtypeimagesrc {
479 return '/opac-tmpl' . '/'
480 . C4::Context->preference('template')
486 $printers = &GetPrinters();
487 @queues = keys %$printers;
489 Returns information about existing printer queues.
491 C<$printers> is a reference-to-hash whose keys are the print queues
492 defined in the printers table of the Koha database. The values are
493 references-to-hash, whose keys are the fields in the printers table.
499 my $dbh = C4::Context->dbh;
500 my $sth = $dbh->prepare("select * from printers");
502 while ( my $printer = $sth->fetchrow_hashref ) {
503 $printers{ $printer->{'printqueue'} } = $printer;
505 return ( \%printers );
510 $printer = GetPrinter( $query, $printers );
514 sub GetPrinter ($$) {
515 my ( $query, $printers ) = @_; # get printer for this query from printers
516 my $printer = $query->param('printer');
517 my %cookie = $query->cookie('userenv');
518 ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' );
519 ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] );
525 Returns the number of pages to display in a pagination bar, given the number
526 of items and the number of items per page.
531 my ( $nb_items, $nb_items_per_page ) = @_;
533 return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1;
538 (@themes) = &getallthemes('opac');
539 (@themes) = &getallthemes('intranet');
541 Returns an array of all available themes.
549 if ( $type eq 'intranet' ) {
550 $htdocs = C4::Context->config('intrahtdocs');
553 $htdocs = C4::Context->config('opachtdocs');
555 opendir D, "$htdocs";
556 my @dirlist = readdir D;
557 foreach my $directory (@dirlist) {
558 -d "$htdocs/$directory/en" and push @themes, $directory;
565 if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
568 link_value => 'su-to',
569 label_value => 'Topics',
571 [ '600', '601', '602', '603', '604', '605', '606', '610' ],
575 link_value => 'su-geo',
576 label_value => 'Places',
581 link_value => 'su-ut',
582 label_value => 'Titles',
583 tags => [ '500', '501', '502', '503', '504', ],
588 label_value => 'Authors',
589 tags => [ '700', '701', '702', ],
594 label_value => 'Series',
599 link_value => 'branch',
600 label_value => 'Branches',
610 link_value => 'su-to',
611 label_value => 'Topics',
617 # link_value => 'su-na',
618 # label_value => 'People and Organizations',
619 # tags => ['600', '610', '611'],
623 link_value => 'su-geo',
624 label_value => 'Places',
629 link_value => 'su-ut',
630 label_value => 'Titles',
636 label_value => 'Authors',
637 tags => [ '100', '110', '700', ],
642 label_value => 'Series',
643 tags => [ '440', '490', ],
647 link_value => 'branch',
648 label_value => 'Branches',
660 Return a href where a key is associated to a href. You give a query, the
661 name of the key among the fields returned by the query. If you also give as
662 third argument the name of the value, the function returns a href of scalar.
671 # generic href of any information on the item, href of href.
672 my $iteminfos_of = get_infos_of($query, 'itemnumber');
673 print $iteminfos_of->{$itemnumber}{barcode};
675 # specific information, href of scalar
676 my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
677 print $barcode_of_item->{$itemnumber};
682 my ( $query, $key_name, $value_name ) = @_;
684 my $dbh = C4::Context->dbh;
686 my $sth = $dbh->prepare($query);
690 while ( my $row = $sth->fetchrow_hashref ) {
691 if ( defined $value_name ) {
692 $infos_of{ $row->{$key_name} } = $row->{$value_name};
695 $infos_of{ $row->{$key_name} } = $row;
703 =head2 get_notforloan_label_of
705 my $notforloan_label_of = get_notforloan_label_of();
707 Each authorised value of notforloan (information available in items and
708 itemtypes) is link to a single label.
710 Returns a href where keys are authorised values and values are corresponding
713 foreach my $authorised_value (keys %{$notforloan_label_of}) {
715 "authorised_value: %s => %s\n",
717 $notforloan_label_of->{$authorised_value}
723 sub get_notforloan_label_of {
724 my $dbh = C4::Context->dbh;
727 SELECT authorised_value
728 FROM marc_subfield_structure
729 WHERE kohafield = \'items.notforloan\'
732 my $sth = $dbh->prepare($query);
734 my ($statuscode) = $sth->fetchrow_array();
739 FROM authorised_values
742 $sth = $dbh->prepare($query);
743 $sth->execute($statuscode);
744 my %notforloan_label_of;
745 while ( my $row = $sth->fetchrow_hashref ) {
746 $notforloan_label_of{ $row->{authorised_value} } = $row->{lib};
750 return \%notforloan_label_of;
754 my ( $position, $type ) = @_;
755 my $dbh = C4::Context->dbh;
756 my $strsth = "SELECT * FROM z3950servers where 1";
757 $strsth .= " AND position=\"$position\"" if ($position);
758 $strsth .= " AND type=\"$type\"" if ($type);
759 my $rq = $dbh->prepare($strsth);
761 my @primaryserverloop;
763 while ( my $data = $rq->fetchrow_hashref ) {
765 $cell{label} = $data->{'description'};
766 $cell{id} = $data->{'name'};
769 . ( $data->{port} ? ":" . $data->{port} : "" ) . "/"
771 if ( $data->{host} );
772 $cell{checked} = $data->{checked};
773 push @primaryserverloop,
775 label => $data->{description},
778 value => $data->{host} . ":"
779 . $data->{port} . "/"
781 checked => "checked",
782 icon => $data->{icon},
783 zed => $data->{type} eq 'zed',
784 opensearch => $data->{type} eq 'opensearch'
787 return \@primaryserverloop;
790 sub displaySecondaryServers {
792 # my $secondary_servers_loop = [
793 # { inner_sup_servers_loop => [
794 # {label => "Google", id=>"GOOG", value=>"google",icon => "google.ico",opensearch => "1"},
795 # {label => "Yahoo", id=>"YAH", value=>"yahoo", icon =>"yahoo.ico", zed => "1"},
796 # {label => "Worldcat", id=>"WCT", value=>"worldcat", icon => "worldcat.gif", zed => "1"},
797 # {label => "Library of Congress", id=>"LOC", name=> "server", value=>"z3950.loc.gov:7090/Voyager", icon =>"loc.ico", zed => "1"},
801 return; #$secondary_servers_loop;
804 =head2 GetAuthorisedValues
806 $authvalues = GetAuthorisedValues($category);
808 this function get all authorised values from 'authosied_value' table into a reference to array which
809 each value containt an hashref.
811 Set C<$category> on input args if you want to limits your query to this one. This params is not mandatory.
815 sub GetAuthorisedValues {
816 my $category = shift;
817 my $dbh = C4::Context->dbh;
818 my $query = "SELECT * FROM authorised_values";
819 $query .= " WHERE category = '" . $category . "'" if $category;
821 my $sth = $dbh->prepare($query);
823 my $data = $sth->fetchall_arrayref({});
829 $marcrecord = &fixEncoding($marcblob);
831 Returns a well encoded marcrecord.
836 my $record = MARC::Record->new_from_usmarc($marc);
837 if (C4::Context->preference("MARCFLAVOUR") eq "UNIMARC"){
839 my $targetcharset="utf8" if (C4::Context->preference("TemplateEncoding") eq "utf-8");
840 $targetcharset="latin1" if (C4::Context->preference("TemplateEncoding") eq "iso-8859-1");
841 my $decoder = guess_encoding($marc, qw/utf8 latin1/);
842 # die $decoder unless ref($decoder);
844 my $newRecord=MARC::Record->new();
845 foreach my $field ($record->fields()){
846 if ($field->tag()<'010'){
847 $newRecord->insert_grouped_field($field);
851 foreach my $subfield ($field->subfields()){
853 if (($newField->tag eq '100')) {
854 substr($subfield->[1],26,2,"0103") if ($targetcharset eq "latin1");
855 substr($subfield->[1],26,4,"5050") if ($targetcharset eq "utf8");
857 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
858 $newField->add_subfields($subfield->[0]=>$subfield->[1]);
860 map {C4::Biblio::char_decode($_,"UNIMARC")} @$subfield;
861 $newField=MARC::Field->new($field->tag(),$field->indicator(1),$field->indicator(2),$subfield->[0]=>$subfield->[1]);
865 $newRecord->insert_grouped_field($newField);
868 # warn $newRecord->as_formatted();
878 =head2 GetKohaAuthorisedValues
880 Takes $dbh , $kohafield as parameters.
881 returns hashref of authvalCode => liblibrarian
882 or undef if no authvals defined for kohafield.
886 sub GetKohaAuthorisedValues {
887 my ($kohafield) = @_;
889 my $dbh = C4::Context->dbh;
890 my $sthnflstatus = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=?');
891 $sthnflstatus->execute($kohafield);
892 my $authorised_valuecode = $sthnflstatus->fetchrow;
893 if ($authorised_valuecode) {
894 $sthnflstatus = $dbh->prepare("select authorised_value, lib from authorised_values where category=? ");
895 $sthnflstatus->execute($authorised_valuecode);
896 while ( my ($val, $lib) = $sthnflstatus->fetchrow_array ) {
903 =head2 GetManagedTagSubfields
907 $res = GetManagedTagSubfields();
909 Returns a reference to a big hash of hash, with the Marc structure fro the given frameworkcode
910 $forlibrarian :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
911 $frameworkcode : the framework code to read
919 sub GetManagedTagSubfields{
920 my $dbh=C4::Context->dbh;
921 my $rq=$dbh->prepare(qq|
923 DISTINCT CONCAT( marc_subfield_structure.tagfield, tagsubfield ) AS tagsubfield,
924 marc_subfield_structure.liblibrarian as subfielddesc,
925 marc_tag_structure.liblibrarian as tagdesc
926 FROM marc_subfield_structure
927 LEFT JOIN marc_tag_structure
928 ON marc_tag_structure.tagfield = marc_subfield_structure.tagfield
929 AND marc_tag_structure.frameworkcode = marc_subfield_structure.frameworkcode
930 WHERE marc_subfield_structure.tab>=0
931 ORDER BY tagsubfield|);
933 my $data=$rq->fetchall_arrayref({});