| File: | C4/Koha.pm |
| Coverage: | 7.8% |
| line | stmt | bran | cond | sub | time | code |
|---|---|---|---|---|---|---|
| 1 | package C4::Koha; | |||||
| 2 | ||||||
| 3 | # Copyright 2000-2002 Katipo Communications | |||||
| 4 | # Parts Copyright 2010 Nelsonville Public Library | |||||
| 5 | # Parts copyright 2010 BibLibre | |||||
| 6 | # | |||||
| 7 | # This file is part of Koha. | |||||
| 8 | # | |||||
| 9 | # Koha is free software; you can redistribute it and/or modify it under the | |||||
| 10 | # terms of the GNU General Public License as published by the Free Software | |||||
| 11 | # Foundation; either version 2 of the License, or (at your option) any later | |||||
| 12 | # version. | |||||
| 13 | # | |||||
| 14 | # Koha is distributed in the hope that it will be useful, but WITHOUT ANY | |||||
| 15 | # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR | |||||
| 16 | # A PARTICULAR PURPOSE. See the GNU General Public License for more details. | |||||
| 17 | # | |||||
| 18 | # You should have received a copy of the GNU General Public License along | |||||
| 19 | # with Koha; if not, write to the Free Software Foundation, Inc., | |||||
| 20 | # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. | |||||
| 21 | ||||||
| 22 | ||||||
| 23 | 20 20 20 | 261 186 775 | use strict; | |||
| 24 | #use warnings; FIXME - Bug 2505 | |||||
| 25 | 20 20 20 | 643 185 390 | use C4::Context; | |||
| 26 | 20 20 20 | 18864 55647 1591 | use Memoize; | |||
| 27 | ||||||
| 28 | 20 20 20 | 244 152 2927 | use vars qw($VERSION @ISA @EXPORT $DEBUG); | |||
| 29 | ||||||
| 30 | BEGIN { | |||||
| 31 | 20 | 148 | $VERSION = 3.01; | |||
| 32 | 20 | 195 | require Exporter; | |||
| 33 | 20 | 410 | @ISA = qw(Exporter); | |||
| 34 | 20 | 434 | @EXPORT = qw( | |||
| 35 | &slashifyDate | |||||
| 36 | &subfield_is_koha_internal_p | |||||
| 37 | &GetPrinters &GetPrinter | |||||
| 38 | &GetItemTypes &getitemtypeinfo | |||||
| 39 | &GetCcodes | |||||
| 40 | &GetSupportName &GetSupportList | |||||
| 41 | &get_itemtypeinfos_of | |||||
| 42 | &getframeworks &getframeworkinfo | |||||
| 43 | &getauthtypes &getauthtype | |||||
| 44 | &getallthemes | |||||
| 45 | &getFacets | |||||
| 46 | &displayServers | |||||
| 47 | &getnbpages | |||||
| 48 | &get_infos_of | |||||
| 49 | &get_notforloan_label_of | |||||
| 50 | &getitemtypeimagedir | |||||
| 51 | &getitemtypeimagesrc | |||||
| 52 | &getitemtypeimagelocation | |||||
| 53 | &GetAuthorisedValues | |||||
| 54 | &GetAuthorisedValueCategories | |||||
| 55 | &GetKohaAuthorisedValues | |||||
| 56 | &GetKohaAuthorisedValuesFromField | |||||
| 57 | &GetKohaAuthorisedValueLib | |||||
| 58 | &GetAuthorisedValueByCode | |||||
| 59 | &GetKohaImageurlFromAuthorisedValues | |||||
| 60 | &GetAuthValCode | |||||
| 61 | &GetNormalizedUPC | |||||
| 62 | &GetNormalizedISBN | |||||
| 63 | &GetNormalizedEAN | |||||
| 64 | &GetNormalizedOCLCNumber | |||||
| 65 | &xml_escape | |||||
| 66 | ||||||
| 67 | $DEBUG | |||||
| 68 | ); | |||||
| 69 | 20 | 115203 | $DEBUG = 0; | |||
| 70 | } | |||||
| 71 | ||||||
| 72 | # expensive functions | |||||
| 73 | memoize('GetAuthorisedValues'); | |||||
| 74 | ||||||
| 75 - 89 | =head1 NAME C4::Koha - Perl Module containing convenience functions for Koha scripts =head1 SYNOPSIS use C4::Koha; =head1 DESCRIPTION Koha.pm provides many functions for Koha scripts. =head1 FUNCTIONS =cut | |||||
| 90 | ||||||
| 91 - 98 | =head2 slashifyDate $slash_date = &slashifyDate($dash_date); Takes a string of the form "DD-MM-YYYY" (or anything separated by dashes), converts it to the form "YYYY/MM/DD", and returns the result. =cut | |||||
| 99 | ||||||
| 100 | sub slashifyDate { | |||||
| 101 | ||||||
| 102 | # accepts a date of the form xx-xx-xx[xx] and returns it in the | |||||
| 103 | # form xx/xx/xx[xx] | |||||
| 104 | 1 | 18 | my @dateOut = split( '-', shift ); | |||
| 105 | 1 | 21 | return ("$dateOut[2]/$dateOut[1]/$dateOut[0]"); | |||
| 106 | } | |||||
| 107 | ||||||
| 108 | # FIXME.. this should be moved to a MARC-specific module | |||||
| 109 | sub subfield_is_koha_internal_p ($) { | |||||
| 110 | 0 | 0 | my ($subfield) = @_; | |||
| 111 | ||||||
| 112 | # We could match on 'lib' and 'tab' (and 'mandatory', & more to come!) | |||||
| 113 | # But real MARC subfields are always single-character | |||||
| 114 | # so it really is safer just to check the length | |||||
| 115 | ||||||
| 116 | 0 | 0 | return length $subfield != 1; | |||
| 117 | } | |||||
| 118 | ||||||
| 119 - 125 | =head2 GetSupportName $itemtypename = &GetSupportName($codestring); Returns a string with the name of the itemtype. =cut | |||||
| 126 | ||||||
| 127 | sub GetSupportName{ | |||||
| 128 | 0 | 0 | my ($codestring)=@_; | |||
| 129 | 0 | 0 | return if (! $codestring); | |||
| 130 | 0 | 0 | my $resultstring; | |||
| 131 | 0 | 0 | my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes"); | |||
| 132 | 0 | 0 | if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') { | |||
| 133 | 0 | 0 | my $query = qq| | |||
| 134 | SELECT description | |||||
| 135 | FROM itemtypes | |||||
| 136 | WHERE itemtype=? | |||||
| 137 | order by description | |||||
| 138 | |; | |||||
| 139 | 0 | 0 | my $sth = C4::Context->dbh->prepare($query); | |||
| 140 | 0 | 0 | $sth->execute($codestring); | |||
| 141 | 0 | 0 | ($resultstring)=$sth->fetchrow; | |||
| 142 | 0 | 0 | return $resultstring; | |||
| 143 | } else { | |||||
| 144 | 0 | 0 | my $sth = | |||
| 145 | C4::Context->dbh->prepare( | |||||
| 146 | "SELECT lib FROM authorised_values WHERE category = ? AND authorised_value = ?" | |||||
| 147 | ); | |||||
| 148 | 0 | 0 | $sth->execute( $advanced_search_types, $codestring ); | |||
| 149 | 0 | 0 | my $data = $sth->fetchrow_hashref; | |||
| 150 | 0 | 0 | return $$data{'lib'}; | |||
| 151 | } | |||||
| 152 | ||||||
| 153 | } | |||||
| 154 - 180 | =head2 GetSupportList
$itemtypes = &GetSupportList();
Returns an array ref containing informations about Support (since itemtype is rather a circulation code when item-level-itypes is used).
build a HTML select with the following code :
=head3 in PERL SCRIPT
my $itemtypes = GetSupportList();
$template->param(itemtypeloop => $itemtypes);
=head3 in TEMPLATE
<form action='<!-- TMPL_VAR name="script_name" -->' method=post>
<select name="itemtype">
<option value="">Default</option>
<!-- TMPL_LOOP name="itemtypeloop" -->
<option value="<!-- TMPL_VAR name="itemtype" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->> <!--TMPL_IF Name="imageurl"--><img alt="<!-- TMPL_VAR name="description" -->" src="<!--TMPL_VAR Name="imageurl"-->><!--TMPL_ELSE-->"<!-- TMPL_VAR name="description" --><!--/TMPL_IF--></option>
<!-- /TMPL_LOOP -->
</select>
<input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
<input type="submit" value="OK" class="button">
</form>
=cut | |||||
| 181 | ||||||
| 182 | sub GetSupportList{ | |||||
| 183 | 0 | 0 | my $advanced_search_types = C4::Context->preference("AdvancedSearchTypes"); | |||
| 184 | 0 | 0 | if (!$advanced_search_types or $advanced_search_types eq 'itemtypes') { | |||
| 185 | 0 | 0 | my $query = qq| | |||
| 186 | SELECT * | |||||
| 187 | FROM itemtypes | |||||
| 188 | order by description | |||||
| 189 | |; | |||||
| 190 | 0 | 0 | my $sth = C4::Context->dbh->prepare($query); | |||
| 191 | 0 | 0 | $sth->execute; | |||
| 192 | 0 | 0 | return $sth->fetchall_arrayref({}); | |||
| 193 | } else { | |||||
| 194 | 0 | 0 | my $advsearchtypes = GetAuthorisedValues($advanced_search_types); | |||
| 195 | 0 0 | 0 0 | my @results= map {{itemtype=>$$_{authorised_value},description=>$$_{lib},imageurl=>$$_{imageurl}}} @$advsearchtypes; | |||
| 196 | 0 | 0 | return \@results; | |||
| 197 | } | |||||
| 198 | } | |||||
| 199 - 234 | =head2 GetItemTypes
$itemtypes = &GetItemTypes();
Returns information about existing itemtypes.
build a HTML select with the following code :
=head3 in PERL SCRIPT
my $itemtypes = GetItemTypes;
my @itemtypesloop;
foreach my $thisitemtype (sort keys %$itemtypes) {
my $selected = 1 if $thisitemtype eq $itemtype;
my %row =(value => $thisitemtype,
selected => $selected,
description => $itemtypes->{$thisitemtype}->{'description'},
);
push @itemtypesloop, \%row;
}
$template->param(itemtypeloop => \@itemtypesloop);
=head3 in TEMPLATE
<form action='<!-- TMPL_VAR name="script_name" -->' method=post>
<select name="itemtype">
<option value="">Default</option>
<!-- TMPL_LOOP name="itemtypeloop" -->
<option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="description" --></option>
<!-- /TMPL_LOOP -->
</select>
<input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
<input type="submit" value="OK" class="button">
</form>
=cut | |||||
| 235 | ||||||
| 236 | sub GetItemTypes { | |||||
| 237 | ||||||
| 238 | # returns a reference to a hash of references to itemtypes... | |||||
| 239 | 0 | 0 | my %itemtypes; | |||
| 240 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 241 | 0 | 0 | my $query = qq| | |||
| 242 | SELECT * | |||||
| 243 | FROM itemtypes | |||||
| 244 | |; | |||||
| 245 | 0 | 0 | my $sth = $dbh->prepare($query); | |||
| 246 | 0 | 0 | $sth->execute; | |||
| 247 | 0 | 0 | while ( my $IT = $sth->fetchrow_hashref ) { | |||
| 248 | 0 | 0 | $itemtypes{ $IT->{'itemtype'} } = $IT; | |||
| 249 | } | |||||
| 250 | 0 | 0 | return ( \%itemtypes ); | |||
| 251 | } | |||||
| 252 | ||||||
| 253 | sub get_itemtypeinfos_of { | |||||
| 254 | 0 | 0 | my @itemtypes = @_; | |||
| 255 | ||||||
| 256 | 0 0 | 0 0 | my $placeholders = join( ', ', map { '?' } @itemtypes ); | |||
| 257 | 0 | 0 | my $query = <<"END_SQL"; | |||
| 258 | SELECT itemtype, | |||||
| 259 | description, | |||||
| 260 | imageurl, | |||||
| 261 | notforloan | |||||
| 262 | FROM itemtypes | |||||
| 263 | WHERE itemtype IN ( $placeholders ) | |||||
| 264 | END_SQL | |||||
| 265 | ||||||
| 266 | 0 | 0 | return get_infos_of( $query, 'itemtype', undef, \@itemtypes ); | |||
| 267 | } | |||||
| 268 | ||||||
| 269 | # this is temporary until we separate collection codes and item types | |||||
| 270 | sub GetCcodes { | |||||
| 271 | 0 | 0 | my $count = 0; | |||
| 272 | 0 | 0 | my @results; | |||
| 273 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 274 | 0 | 0 | my $sth = | |||
| 275 | $dbh->prepare( | |||||
| 276 | "SELECT * FROM authorised_values ORDER BY authorised_value"); | |||||
| 277 | 0 | 0 | $sth->execute; | |||
| 278 | 0 | 0 | while ( my $data = $sth->fetchrow_hashref ) { | |||
| 279 | 0 | 0 | if ( $data->{category} eq "CCODE" ) { | |||
| 280 | 0 | 0 | $count++; | |||
| 281 | 0 | 0 | $results[$count] = $data; | |||
| 282 | ||||||
| 283 | #warn "data: $data"; | |||||
| 284 | } | |||||
| 285 | } | |||||
| 286 | 0 | 0 | $sth->finish; | |||
| 287 | 0 | 0 | return ( $count, @results ); | |||
| 288 | } | |||||
| 289 | ||||||
| 290 - 325 | =head2 getauthtypes
$authtypes = &getauthtypes();
Returns information about existing authtypes.
build a HTML select with the following code :
=head3 in PERL SCRIPT
my $authtypes = getauthtypes;
my @authtypesloop;
foreach my $thisauthtype (keys %$authtypes) {
my $selected = 1 if $thisauthtype eq $authtype;
my %row =(value => $thisauthtype,
selected => $selected,
authtypetext => $authtypes->{$thisauthtype}->{'authtypetext'},
);
push @authtypesloop, \%row;
}
$template->param(itemtypeloop => \@itemtypesloop);
=head3 in TEMPLATE
<form action='<!-- TMPL_VAR name="script_name" -->' method=post>
<select name="authtype">
<!-- TMPL_LOOP name="authtypeloop" -->
<option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="authtypetext" --></option>
<!-- /TMPL_LOOP -->
</select>
<input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
<input type="submit" value="OK" class="button">
</form>
=cut | |||||
| 326 | ||||||
| 327 | sub getauthtypes { | |||||
| 328 | ||||||
| 329 | # returns a reference to a hash of references to authtypes... | |||||
| 330 | 0 | 0 | my %authtypes; | |||
| 331 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 332 | 0 | 0 | my $sth = $dbh->prepare("select * from auth_types order by authtypetext"); | |||
| 333 | 0 | 0 | $sth->execute; | |||
| 334 | 0 | 0 | while ( my $IT = $sth->fetchrow_hashref ) { | |||
| 335 | 0 | 0 | $authtypes{ $IT->{'authtypecode'} } = $IT; | |||
| 336 | } | |||||
| 337 | 0 | 0 | return ( \%authtypes ); | |||
| 338 | } | |||||
| 339 | ||||||
| 340 | sub getauthtype { | |||||
| 341 | 0 | 0 | my ($authtypecode) = @_; | |||
| 342 | ||||||
| 343 | # returns a reference to a hash of references to authtypes... | |||||
| 344 | 0 | 0 | my %authtypes; | |||
| 345 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 346 | 0 | 0 | my $sth = $dbh->prepare("select * from auth_types where authtypecode=?"); | |||
| 347 | 0 | 0 | $sth->execute($authtypecode); | |||
| 348 | 0 | 0 | my $res = $sth->fetchrow_hashref; | |||
| 349 | 0 | 0 | return $res; | |||
| 350 | } | |||||
| 351 | ||||||
| 352 - 387 | =head2 getframework
$frameworks = &getframework();
Returns information about existing frameworks
build a HTML select with the following code :
=head3 in PERL SCRIPT
my $frameworks = frameworks();
my @frameworkloop;
foreach my $thisframework (keys %$frameworks) {
my $selected = 1 if $thisframework eq $frameworkcode;
my %row =(value => $thisframework,
selected => $selected,
description => $frameworks->{$thisframework}->{'frameworktext'},
);
push @frameworksloop, \%row;
}
$template->param(frameworkloop => \@frameworksloop);
=head3 in TEMPLATE
<form action='<!-- TMPL_VAR name="script_name" -->' method=post>
<select name="frameworkcode">
<option value="">Default</option>
<!-- TMPL_LOOP name="frameworkloop" -->
<option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="frameworktext" --></option>
<!-- /TMPL_LOOP -->
</select>
<input type=text name=searchfield value="<!-- TMPL_VAR name="searchfield" -->">
<input type="submit" value="OK" class="button">
</form>
=cut | |||||
| 388 | ||||||
| 389 | sub getframeworks { | |||||
| 390 | ||||||
| 391 | # returns a reference to a hash of references to branches... | |||||
| 392 | 0 | 0 | my %itemtypes; | |||
| 393 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 394 | 0 | 0 | my $sth = $dbh->prepare("select * from biblio_framework"); | |||
| 395 | 0 | 0 | $sth->execute; | |||
| 396 | 0 | 0 | while ( my $IT = $sth->fetchrow_hashref ) { | |||
| 397 | 0 | 0 | $itemtypes{ $IT->{'frameworkcode'} } = $IT; | |||
| 398 | } | |||||
| 399 | 0 | 0 | return ( \%itemtypes ); | |||
| 400 | } | |||||
| 401 | ||||||
| 402 - 408 | =head2 getframeworkinfo $frameworkinfo = &getframeworkinfo($frameworkcode); Returns information about an frameworkcode. =cut | |||||
| 409 | ||||||
| 410 | sub getframeworkinfo { | |||||
| 411 | 0 | 0 | my ($frameworkcode) = @_; | |||
| 412 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 413 | 0 | 0 | my $sth = | |||
| 414 | $dbh->prepare("select * from biblio_framework where frameworkcode=?"); | |||||
| 415 | 0 | 0 | $sth->execute($frameworkcode); | |||
| 416 | 0 | 0 | my $res = $sth->fetchrow_hashref; | |||
| 417 | 0 | 0 | return $res; | |||
| 418 | } | |||||
| 419 | ||||||
| 420 - 426 | =head2 getitemtypeinfo $itemtype = &getitemtype($itemtype); Returns information about an itemtype. =cut | |||||
| 427 | ||||||
| 428 | sub getitemtypeinfo { | |||||
| 429 | 0 | 0 | my ($itemtype) = @_; | |||
| 430 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 431 | 0 | 0 | my $sth = $dbh->prepare("select * from itemtypes where itemtype=?"); | |||
| 432 | 0 | 0 | $sth->execute($itemtype); | |||
| 433 | 0 | 0 | my $res = $sth->fetchrow_hashref; | |||
| 434 | ||||||
| 435 | 0 | 0 | $res->{imageurl} = getitemtypeimagelocation( 'intranet', $res->{imageurl} ); | |||
| 436 | ||||||
| 437 | 0 | 0 | return $res; | |||
| 438 | } | |||||
| 439 | ||||||
| 440 - 448 | =head2 getitemtypeimagedir my $directory = getitemtypeimagedir( 'opac' ); pass in 'opac' or 'intranet'. Defaults to 'opac'. returns the full path to the appropriate directory containing images. =cut | |||||
| 449 | ||||||
| 450 | sub getitemtypeimagedir { | |||||
| 451 | 0 | 0 | my $src = shift || 'opac'; | |||
| 452 | 0 | 0 | if ($src eq 'intranet') { | |||
| 453 | 0 | 0 | return C4::Context->config('intrahtdocs') . '/' .C4::Context->preference('template') . '/img/itemtypeimg'; | |||
| 454 | } else { | |||||
| 455 | 0 | 0 | return C4::Context->config('opachtdocs') . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg'; | |||
| 456 | } | |||||
| 457 | } | |||||
| 458 | ||||||
| 459 | sub getitemtypeimagesrc { | |||||
| 460 | 0 | 0 | my $src = shift || 'opac'; | |||
| 461 | 0 | 0 | if ($src eq 'intranet') { | |||
| 462 | 0 | 0 | return '/intranet-tmpl' . '/' . C4::Context->preference('template') . '/img/itemtypeimg'; | |||
| 463 | } else { | |||||
| 464 | 0 | 0 | return '/opac-tmpl' . '/' . C4::Context->preference('opacthemes') . '/itemtypeimg'; | |||
| 465 | } | |||||
| 466 | } | |||||
| 467 | ||||||
| 468 | sub getitemtypeimagelocation($$) { | |||||
| 469 | 0 | 0 | my ( $src, $image ) = @_; | |||
| 470 | ||||||
| 471 | 0 | 0 | return '' if ( !$image ); | |||
| 472 | 0 | 0 | require URI::Split; | |||
| 473 | ||||||
| 474 | 0 | 0 | my $scheme = ( URI::Split::uri_split( $image ) )[0]; | |||
| 475 | ||||||
| 476 | 0 | 0 | return $image if ( $scheme ); | |||
| 477 | ||||||
| 478 | 0 | 0 | return getitemtypeimagesrc( $src ) . '/' . $image; | |||
| 479 | } | |||||
| 480 | ||||||
| 481 - 494 | =head3 _getImagesFromDirectory Find all of the image files in a directory in the filesystem parameters: a directory name returns: a list of images in that directory. Notes: this does not traverse into subdirectories. See _getSubdirectoryNames for help with that. Images are assumed to be files with .gif or .png file extensions. The image names returned do not have the directory name on them. =cut | |||||
| 495 | ||||||
| 496 | sub _getImagesFromDirectory { | |||||
| 497 | 0 | 0 | my $directoryname = shift; | |||
| 498 | 0 | 0 | return unless defined $directoryname; | |||
| 499 | 0 | 0 | return unless -d $directoryname; | |||
| 500 | ||||||
| 501 | 0 | 0 | if ( opendir ( my $dh, $directoryname ) ) { | |||
| 502 | 0 0 | 0 0 | my @images = grep { /\.(gif|png)$/i } readdir( $dh ); | |||
| 503 | 0 | 0 | closedir $dh; | |||
| 504 | 0 | 0 | @images = sort(@images); | |||
| 505 | 0 | 0 | return @images; | |||
| 506 | } else { | |||||
| 507 | 0 | 0 | warn "unable to opendir $directoryname: $!"; | |||
| 508 | 0 | 0 | return; | |||
| 509 | } | |||||
| 510 | } | |||||
| 511 | ||||||
| 512 - 524 | =head3 _getSubdirectoryNames Find all of the directories in a directory in the filesystem parameters: a directory name returns: a list of subdirectories in that directory. Notes: this does not traverse into subdirectories. Only the first level of subdirectories are returned. The directory names returned don't have the parent directory name on them. =cut | |||||
| 525 | ||||||
| 526 | sub _getSubdirectoryNames { | |||||
| 527 | 0 | 0 | my $directoryname = shift; | |||
| 528 | 0 | 0 | return unless defined $directoryname; | |||
| 529 | 0 | 0 | return unless -d $directoryname; | |||
| 530 | ||||||
| 531 | 0 | 0 | if ( opendir ( my $dh, $directoryname ) ) { | |||
| 532 | 0 0 | 0 0 | my @directories = grep { -d File::Spec->catfile( $directoryname, $_ ) && ! ( /^\./ ) } readdir( $dh ); | |||
| 533 | 0 | 0 | closedir $dh; | |||
| 534 | 0 | 0 | return @directories; | |||
| 535 | } else { | |||||
| 536 | 0 | 0 | warn "unable to opendir $directoryname: $!"; | |||
| 537 | 0 | 0 | return; | |||
| 538 | } | |||||
| 539 | } | |||||
| 540 | ||||||
| 541 - 558 | =head3 getImageSets
returns: a listref of hashrefs. Each hash represents another collection of images.
{ imagesetname => 'npl', # the name of the image set (npl is the original one)
images => listref of image hashrefs
}
each image is represented by a hashref like this:
{ KohaImage => 'npl/image.gif',
StaffImageUrl => '/intranet-tmpl/prog/img/itemtypeimg/npl/image.gif',
OpacImageURL => '/opac-tmpl/prog/itemtypeimg/npl/image.gif'
checked => 0 or 1: was this the image passed to this method?
Note: I'd like to remove this somehow.
}
=cut | |||||
| 559 | ||||||
| 560 | sub getImageSets { | |||||
| 561 | 0 | 0 | my %params = @_; | |||
| 562 | 0 | 0 | my $checked = $params{'checked'} || ''; | |||
| 563 | ||||||
| 564 | 0 | 0 | my $paths = { staff => { filesystem => getitemtypeimagedir('intranet'), | |||
| 565 | url => getitemtypeimagesrc('intranet'), | |||||
| 566 | }, | |||||
| 567 | opac => { filesystem => getitemtypeimagedir('opac'), | |||||
| 568 | url => getitemtypeimagesrc('opac'), | |||||
| 569 | } | |||||
| 570 | }; | |||||
| 571 | ||||||
| 572 | 0 | 0 | my @imagesets = (); # list of hasrefs of image set data to pass to template | |||
| 573 | 0 | 0 | my @subdirectories = _getSubdirectoryNames( $paths->{'staff'}{'filesystem'} ); | |||
| 574 | 0 | 0 | foreach my $imagesubdir ( @subdirectories ) { | |||
| 575 | 0 | 0 | warn $imagesubdir if $DEBUG; | |||
| 576 | 0 | 0 | my @imagelist = (); # hashrefs of image info | |||
| 577 | 0 | 0 | my @imagenames = _getImagesFromDirectory( File::Spec->catfile( $paths->{'staff'}{'filesystem'}, $imagesubdir ) ); | |||
| 578 | 0 | 0 | my $imagesetactive = 0; | |||
| 579 | 0 | 0 | foreach my $thisimage ( @imagenames ) { | |||
| 580 | 0 | 0 | push( @imagelist, | |||
| 581 | { KohaImage => "$imagesubdir/$thisimage", | |||||
| 582 | StaffImageUrl => join( '/', $paths->{'staff'}{'url'}, $imagesubdir, $thisimage ), | |||||
| 583 | OpacImageUrl => join( '/', $paths->{'opac'}{'url'}, $imagesubdir, $thisimage ), | |||||
| 584 | checked => "$imagesubdir/$thisimage" eq $checked ? 1 : 0, | |||||
| 585 | } | |||||
| 586 | ); | |||||
| 587 | 0 | 0 | $imagesetactive = 1 if "$imagesubdir/$thisimage" eq $checked; | |||
| 588 | } | |||||
| 589 | 0 | 0 | push @imagesets, { imagesetname => $imagesubdir, | |||
| 590 | imagesetactive => $imagesetactive, | |||||
| 591 | images => \@imagelist }; | |||||
| 592 | ||||||
| 593 | } | |||||
| 594 | 0 | 0 | return \@imagesets; | |||
| 595 | } | |||||
| 596 | ||||||
| 597 - 608 | =head2 GetPrinters $printers = &GetPrinters(); @queues = keys %$printers; Returns information about existing printer queues. C<$printers> is a reference-to-hash whose keys are the print queues defined in the printers table of the Koha database. The values are references-to-hash, whose keys are the fields in the printers table. =cut | |||||
| 609 | ||||||
| 610 | sub GetPrinters { | |||||
| 611 | 0 | 0 | my %printers; | |||
| 612 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 613 | 0 | 0 | my $sth = $dbh->prepare("select * from printers"); | |||
| 614 | 0 | 0 | $sth->execute; | |||
| 615 | 0 | 0 | while ( my $printer = $sth->fetchrow_hashref ) { | |||
| 616 | 0 | 0 | $printers{ $printer->{'printqueue'} } = $printer; | |||
| 617 | } | |||||
| 618 | 0 | 0 | return ( \%printers ); | |||
| 619 | } | |||||
| 620 | ||||||
| 621 - 625 | =head2 GetPrinter $printer = GetPrinter( $query, $printers ); =cut | |||||
| 626 | ||||||
| 627 | sub GetPrinter ($$) { | |||||
| 628 | 0 | 0 | my ( $query, $printers ) = @_; # get printer for this query from printers | |||
| 629 | 0 | 0 | my $printer = $query->param('printer'); | |||
| 630 | 0 | 0 | my %cookie = $query->cookie('userenv'); | |||
| 631 | 0 | 0 | ($printer) || ( $printer = $cookie{'printer'} ) || ( $printer = '' ); | |||
| 632 | 0 | 0 | ( $printers->{$printer} ) || ( $printer = ( keys %$printers )[0] ); | |||
| 633 | 0 | 0 | return $printer; | |||
| 634 | } | |||||
| 635 | ||||||
| 636 - 641 | =head2 getnbpages Returns the number of pages to display in a pagination bar, given the number of items and the number of items per page. =cut | |||||
| 642 | ||||||
| 643 | sub getnbpages { | |||||
| 644 | 0 | 0 | my ( $nb_items, $nb_items_per_page ) = @_; | |||
| 645 | ||||||
| 646 | 0 | 0 | return int( ( $nb_items - 1 ) / $nb_items_per_page ) + 1; | |||
| 647 | } | |||||
| 648 | ||||||
| 649 - 656 | =head2 getallthemes
(@themes) = &getallthemes('opac');
(@themes) = &getallthemes('intranet');
Returns an array of all available themes.
=cut | |||||
| 657 | ||||||
| 658 | sub getallthemes { | |||||
| 659 | 0 | 0 | my $type = shift; | |||
| 660 | 0 | 0 | my $htdocs; | |||
| 661 | 0 | 0 | my @themes; | |||
| 662 | 0 | 0 | if ( $type eq 'intranet' ) { | |||
| 663 | 0 | 0 | $htdocs = C4::Context->config('intrahtdocs'); | |||
| 664 | } | |||||
| 665 | else { | |||||
| 666 | 0 | 0 | $htdocs = C4::Context->config('opachtdocs'); | |||
| 667 | } | |||||
| 668 | 0 | 0 | opendir D, "$htdocs"; | |||
| 669 | 0 | 0 | my @dirlist = readdir D; | |||
| 670 | 0 | 0 | foreach my $directory (@dirlist) { | |||
| 671 | 0 | 0 | -d "$htdocs/$directory/en" and push @themes, $directory; | |||
| 672 | } | |||||
| 673 | 0 | 0 | return @themes; | |||
| 674 | } | |||||
| 675 | ||||||
| 676 | sub getFacets { | |||||
| 677 | 0 | 0 | my $facets; | |||
| 678 | 0 | 0 | if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) { | |||
| 679 | 0 | 0 | $facets = [ | |||
| 680 | { | |||||
| 681 | idx => 'su-to', | |||||
| 682 | label => 'Topics', | |||||
| 683 | tags => [ qw/ 600a 601a 602a 603a 604a 605a 606ax 610a/ ], | |||||
| 684 | sep => ' - ', | |||||
| 685 | }, | |||||
| 686 | { | |||||
| 687 | idx => 'su-geo', | |||||
| 688 | label => 'Places', | |||||
| 689 | tags => [ qw/ 651a / ], | |||||
| 690 | sep => ' - ', | |||||
| 691 | }, | |||||
| 692 | { | |||||
| 693 | idx => 'su-ut', | |||||
| 694 | label => 'Titles', | |||||
| 695 | tags => [ qw/ 500a 501a 502a 503a 504a / ], | |||||
| 696 | sep => ', ', | |||||
| 697 | }, | |||||
| 698 | { | |||||
| 699 | idx => 'au', | |||||
| 700 | label => 'Authors', | |||||
| 701 | tags => [ qw/ 700ab 701ab 702ab / ], | |||||
| 702 | sep => ', ', | |||||
| 703 | }, | |||||
| 704 | { | |||||
| 705 | idx => 'se', | |||||
| 706 | label => 'Series', | |||||
| 707 | tags => [ qw/ 225a / ], | |||||
| 708 | sep => ', ', | |||||
| 709 | }, | |||||
| 710 | ]; | |||||
| 711 | 0 | 0 | my $library_facet = { | |||
| 712 | idx => 'branch', | |||||
| 713 | label => 'Libraries', | |||||
| 714 | tags => [ qw/ 995b / ], | |||||
| 715 | expanded => '1', | |||||
| 716 | }; | |||||
| 717 | 0 | 0 | push @$facets, $library_facet unless C4::Context->preference("singleBranchMode"); | |||
| 718 | } | |||||
| 719 | else { | |||||
| 720 | 0 | 0 | $facets = [ | |||
| 721 | { | |||||
| 722 | idx => 'su-to', | |||||
| 723 | label => 'Topics', | |||||
| 724 | tags => [ qw/ 650a / ], | |||||
| 725 | sep => '--', | |||||
| 726 | }, | |||||
| 727 | # { | |||||
| 728 | # idx => 'su-na', | |||||
| 729 | # label => 'People and Organizations', | |||||
| 730 | # tags => [ qw/ 600a 610a 611a / ], | |||||
| 731 | # sep => 'a', | |||||
| 732 | # }, | |||||
| 733 | { | |||||
| 734 | idx => 'su-geo', | |||||
| 735 | label => 'Places', | |||||
| 736 | tags => [ qw/ 651a / ], | |||||
| 737 | sep => '--', | |||||
| 738 | }, | |||||
| 739 | { | |||||
| 740 | idx => 'su-ut', | |||||
| 741 | label => 'Titles', | |||||
| 742 | tags => [ qw/ 630a / ], | |||||
| 743 | sep => '--', | |||||
| 744 | }, | |||||
| 745 | { | |||||
| 746 | idx => 'au', | |||||
| 747 | label => 'Authors', | |||||
| 748 | tags => [ qw/ 100a 110a 700a / ], | |||||
| 749 | sep => ', ', | |||||
| 750 | }, | |||||
| 751 | { | |||||
| 752 | idx => 'se', | |||||
| 753 | label => 'Series', | |||||
| 754 | tags => [ qw/ 440a 490a / ], | |||||
| 755 | sep => ', ', | |||||
| 756 | }, | |||||
| 757 | ]; | |||||
| 758 | 0 | 0 | my $library_facet; | |||
| 759 | 0 | 0 | $library_facet = { | |||
| 760 | idx => 'branch', | |||||
| 761 | label => 'Libraries', | |||||
| 762 | tags => [ qw/ 952b / ], | |||||
| 763 | sep => ', ', | |||||
| 764 | expanded => '1', | |||||
| 765 | }; | |||||
| 766 | 0 | 0 | push @$facets, $library_facet unless C4::Context->preference("singleBranchMode"); | |||
| 767 | } | |||||
| 768 | 0 | 0 | return $facets; | |||
| 769 | } | |||||
| 770 | ||||||
| 771 - 795 | =head2 get_infos_of
Return a href where a key is associated to a href. You give a query,
the name of the key among the fields returned by the query. If you
also give as third argument the name of the value, the function
returns a href of scalar. The optional 4th argument is an arrayref of
items passed to the C<execute()> call. It is designed to bind
parameters to any placeholders in your SQL.
my $query = '
SELECT itemnumber,
notforloan,
barcode
FROM items
';
# generic href of any information on the item, href of href.
my $iteminfos_of = get_infos_of($query, 'itemnumber');
print $iteminfos_of->{$itemnumber}{barcode};
# specific information, href of scalar
my $barcode_of_item = get_infos_of($query, 'itemnumber', 'barcode');
print $barcode_of_item->{$itemnumber};
=cut | |||||
| 796 | ||||||
| 797 | sub get_infos_of { | |||||
| 798 | 0 | 0 | my ( $query, $key_name, $value_name, $bind_params ) = @_; | |||
| 799 | ||||||
| 800 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 801 | ||||||
| 802 | 0 | 0 | my $sth = $dbh->prepare($query); | |||
| 803 | 0 | 0 | $sth->execute( @$bind_params ); | |||
| 804 | ||||||
| 805 | 0 | 0 | my %infos_of; | |||
| 806 | 0 | 0 | while ( my $row = $sth->fetchrow_hashref ) { | |||
| 807 | 0 | 0 | if ( defined $value_name ) { | |||
| 808 | 0 | 0 | $infos_of{ $row->{$key_name} } = $row->{$value_name}; | |||
| 809 | } | |||||
| 810 | else { | |||||
| 811 | 0 | 0 | $infos_of{ $row->{$key_name} } = $row; | |||
| 812 | } | |||||
| 813 | } | |||||
| 814 | 0 | 0 | $sth->finish; | |||
| 815 | ||||||
| 816 | 0 | 0 | return \%infos_of; | |||
| 817 | } | |||||
| 818 | ||||||
| 819 - 837 | =head2 get_notforloan_label_of
my $notforloan_label_of = get_notforloan_label_of();
Each authorised value of notforloan (information available in items and
itemtypes) is link to a single label.
Returns a href where keys are authorised values and values are corresponding
labels.
foreach my $authorised_value (keys %{$notforloan_label_of}) {
printf(
"authorised_value: %s => %s\n",
$authorised_value,
$notforloan_label_of->{$authorised_value}
);
}
=cut | |||||
| 838 | ||||||
| 839 | # FIXME - why not use GetAuthorisedValues ?? | |||||
| 840 | # | |||||
| 841 | sub get_notforloan_label_of { | |||||
| 842 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 843 | ||||||
| 844 | 0 | 0 | my $query = ' | |||
| 845 | SELECT authorised_value | |||||
| 846 | FROM marc_subfield_structure | |||||
| 847 | WHERE kohafield = \'items.notforloan\' | |||||
| 848 | LIMIT 0, 1 | |||||
| 849 | '; | |||||
| 850 | 0 | 0 | my $sth = $dbh->prepare($query); | |||
| 851 | 0 | 0 | $sth->execute(); | |||
| 852 | 0 | 0 | my ($statuscode) = $sth->fetchrow_array(); | |||
| 853 | ||||||
| 854 | 0 | 0 | $query = ' | |||
| 855 | SELECT lib, | |||||
| 856 | authorised_value | |||||
| 857 | FROM authorised_values | |||||
| 858 | WHERE category = ? | |||||
| 859 | '; | |||||
| 860 | 0 | 0 | $sth = $dbh->prepare($query); | |||
| 861 | 0 | 0 | $sth->execute($statuscode); | |||
| 862 | 0 | 0 | my %notforloan_label_of; | |||
| 863 | 0 | 0 | while ( my $row = $sth->fetchrow_hashref ) { | |||
| 864 | 0 | 0 | $notforloan_label_of{ $row->{authorised_value} } = $row->{lib}; | |||
| 865 | } | |||||
| 866 | 0 | 0 | $sth->finish; | |||
| 867 | ||||||
| 868 | 0 | 0 | return \%notforloan_label_of; | |||
| 869 | } | |||||
| 870 | ||||||
| 871 - 893 | =head2 displayServers
my $servers = displayServers();
my $servers = displayServers( $position );
my $servers = displayServers( $position, $type );
displayServers returns a listref of hashrefs, each containing
information about available z3950 servers. Each hashref has a format
like:
{
'checked' => 'checked',
'encoding' => 'MARC-8'
'icon' => undef,
'id' => 'LIBRARY OF CONGRESS',
'label' => '',
'name' => 'server',
'opensearch' => '',
'value' => 'z3950.loc.gov:7090/',
'zed' => 1,
},
=cut | |||||
| 894 | ||||||
| 895 | sub displayServers { | |||||
| 896 | 0 | 0 | my ( $position, $type ) = @_; | |||
| 897 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 898 | ||||||
| 899 | 0 | 0 | my $strsth = 'SELECT * FROM z3950servers'; | |||
| 900 | 0 | 0 | my @where_clauses; | |||
| 901 | 0 | 0 | my @bind_params; | |||
| 902 | ||||||
| 903 | 0 | 0 | if ($position) { | |||
| 904 | 0 | 0 | push @bind_params, $position; | |||
| 905 | 0 | 0 | push @where_clauses, ' position = ? '; | |||
| 906 | } | |||||
| 907 | ||||||
| 908 | 0 | 0 | if ($type) { | |||
| 909 | 0 | 0 | push @bind_params, $type; | |||
| 910 | 0 | 0 | push @where_clauses, ' type = ? '; | |||
| 911 | } | |||||
| 912 | ||||||
| 913 | # reassemble where clause from where clause pieces | |||||
| 914 | 0 | 0 | if (@where_clauses) { | |||
| 915 | 0 | 0 | $strsth .= ' WHERE ' . join( ' AND ', @where_clauses ); | |||
| 916 | } | |||||
| 917 | ||||||
| 918 | 0 | 0 | my $rq = $dbh->prepare($strsth); | |||
| 919 | 0 | 0 | $rq->execute(@bind_params); | |||
| 920 | 0 | 0 | my @primaryserverloop; | |||
| 921 | ||||||
| 922 | 0 | 0 | while ( my $data = $rq->fetchrow_hashref ) { | |||
| 923 | 0 | 0 | push @primaryserverloop, | |||
| 924 | { label => $data->{description}, | |||||
| 925 | id => $data->{name}, | |||||
| 926 | name => "server", | |||||
| 927 | value => $data->{host} . ":" . $data->{port} . "/" . $data->{database}, | |||||
| 928 | encoding => ( $data->{encoding} ? $data->{encoding} : "iso-5426" ), | |||||
| 929 | checked => "checked", | |||||
| 930 | icon => $data->{icon}, | |||||
| 931 | zed => $data->{type} eq 'zed', | |||||
| 932 | opensearch => $data->{type} eq 'opensearch' | |||||
| 933 | }; | |||||
| 934 | } | |||||
| 935 | 0 | 0 | return \@primaryserverloop; | |||
| 936 | } | |||||
| 937 | ||||||
| 938 | ||||||
| 939 - 945 | =head2 GetKohaImageurlFromAuthorisedValues $authhorised_value = GetKohaImageurlFromAuthorisedValues( $category, $authvalcode ); Return the first url of the authorised value image represented by $lib. =cut | |||||
| 946 | ||||||
| 947 | sub GetKohaImageurlFromAuthorisedValues { | |||||
| 948 | 0 | 0 | my ( $category, $lib ) = @_; | |||
| 949 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 950 | 0 | 0 | my $sth = $dbh->prepare("SELECT imageurl FROM authorised_values WHERE category=? AND lib =?"); | |||
| 951 | 0 | 0 | $sth->execute( $category, $lib ); | |||
| 952 | 0 | 0 | while ( my $data = $sth->fetchrow_hashref ) { | |||
| 953 | 0 | 0 | return $data->{'imageurl'}; | |||
| 954 | } | |||||
| 955 | } | |||||
| 956 | ||||||
| 957 - 961 | =head2 GetAuthValCode $authvalcode = GetAuthValCode($kohafield,$frameworkcode); =cut | |||||
| 962 | ||||||
| 963 | sub GetAuthValCode { | |||||
| 964 | 0 | 0 | my ($kohafield,$fwcode) = @_; | |||
| 965 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 966 | 0 | 0 | $fwcode='' unless $fwcode; | |||
| 967 | 0 | 0 | my $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where kohafield=? and frameworkcode=?'); | |||
| 968 | 0 | 0 | $sth->execute($kohafield,$fwcode); | |||
| 969 | 0 | 0 | my ($authvalcode) = $sth->fetchrow_array; | |||
| 970 | 0 | 0 | return $authvalcode; | |||
| 971 | } | |||||
| 972 | ||||||
| 973 - 979 | =head2 GetAuthValCodeFromField $authvalcode = GetAuthValCodeFromField($field,$subfield,$frameworkcode); C<$subfield> can be undefined =cut | |||||
| 980 | ||||||
| 981 | sub GetAuthValCodeFromField { | |||||
| 982 | 0 | 0 | my ($field,$subfield,$fwcode) = @_; | |||
| 983 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 984 | 0 | 0 | $fwcode='' unless $fwcode; | |||
| 985 | 0 | 0 | my $sth; | |||
| 986 | 0 | 0 | if (defined $subfield) { | |||
| 987 | 0 | 0 | $sth = $dbh->prepare('select authorised_value from marc_subfield_structure where tagfield=? and tagsubfield=? and frameworkcode=?'); | |||
| 988 | 0 | 0 | $sth->execute($field,$subfield,$fwcode); | |||
| 989 | } else { | |||||
| 990 | 0 | 0 | $sth = $dbh->prepare('select authorised_value from marc_tag_structure where tagfield=? and frameworkcode=?'); | |||
| 991 | 0 | 0 | $sth->execute($field,$fwcode); | |||
| 992 | } | |||||
| 993 | 0 | 0 | my ($authvalcode) = $sth->fetchrow_array; | |||
| 994 | 0 | 0 | return $authvalcode; | |||
| 995 | } | |||||
| 996 | ||||||
| 997 - 1007 | =head2 GetAuthorisedValues $authvalues = GetAuthorisedValues([$category], [$selected]); This function returns all authorised values from the'authorised_value' table in a reference to array of hashrefs. C<$category> returns authorised values for just one category (optional). C<$opac> If set to a true value, displays OPAC descriptions rather than normal ones when they exist. =cut | |||||
| 1008 | ||||||
| 1009 | sub GetAuthorisedValues { | |||||
| 1010 | my ($category,$selected,$opac) = @_; | |||||
| 1011 | my @results; | |||||
| 1012 | my $dbh = C4::Context->dbh; | |||||
| 1013 | my $query = "SELECT * FROM authorised_values"; | |||||
| 1014 | $query .= " WHERE category = '" . $category . "'" if $category; | |||||
| 1015 | $query .= " ORDER BY category, lib, lib_opac"; | |||||
| 1016 | my $sth = $dbh->prepare($query); | |||||
| 1017 | $sth->execute; | |||||
| 1018 | while (my $data=$sth->fetchrow_hashref) { | |||||
| 1019 | if ($selected && $selected eq $data->{'authorised_value'} ) { | |||||
| 1020 | $data->{'selected'} = 1; | |||||
| 1021 | } | |||||
| 1022 | if ($opac && $data->{'lib_opac'}) { | |||||
| 1023 | $data->{'lib'} = $data->{'lib_opac'}; | |||||
| 1024 | } | |||||
| 1025 | push @results, $data; | |||||
| 1026 | } | |||||
| 1027 | #my $data = $sth->fetchall_arrayref({}); | |||||
| 1028 | return \@results; #$data; | |||||
| 1029 | } | |||||
| 1030 | ||||||
| 1031 - 1038 | =head2 GetAuthorisedValueCategories $auth_categories = GetAuthorisedValueCategories(); Return an arrayref of all of the available authorised value categories. =cut | |||||
| 1039 | ||||||
| 1040 | sub GetAuthorisedValueCategories { | |||||
| 1041 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 1042 | 0 | 0 | my $sth = $dbh->prepare("SELECT DISTINCT category FROM authorised_values ORDER BY category"); | |||
| 1043 | 0 | 0 | $sth->execute; | |||
| 1044 | 0 | 0 | my @results; | |||
| 1045 | 0 | 0 | while (defined (my $category = $sth->fetchrow_array) ) { | |||
| 1046 | 0 | 0 | push @results, $category; | |||
| 1047 | } | |||||
| 1048 | 0 | 0 | return \@results; | |||
| 1049 | } | |||||
| 1050 | ||||||
| 1051 - 1058 | =head2 GetAuthorisedValueByCode $authhorised_value = GetAuthorisedValueByCode( $category, $authvalcode ); Return the lib attribute from authorised_values from the row identified by the passed category and code =cut | |||||
| 1059 | ||||||
| 1060 | sub GetAuthorisedValueByCode { | |||||
| 1061 | 0 | 0 | my ( $category, $authvalcode ) = @_; | |||
| 1062 | ||||||
| 1063 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 1064 | 0 | 0 | my $sth = $dbh->prepare("SELECT lib FROM authorised_values WHERE category=? AND authorised_value =?"); | |||
| 1065 | 0 | 0 | $sth->execute( $category, $authvalcode ); | |||
| 1066 | 0 | 0 | while ( my $data = $sth->fetchrow_hashref ) { | |||
| 1067 | 0 | 0 | return $data->{'lib'}; | |||
| 1068 | } | |||||
| 1069 | } | |||||
| 1070 | ||||||
| 1071 - 1081 | =head2 GetKohaAuthorisedValues Takes $kohafield, $fwcode as parameters. If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist. Returns hashref of Code => description Returns undef if no authorised value category is defined for the kohafield. =cut | |||||
| 1082 | ||||||
| 1083 | sub GetKohaAuthorisedValues { | |||||
| 1084 | 0 | 0 | my ($kohafield,$fwcode,$opac) = @_; | |||
| 1085 | 0 | 0 | $fwcode='' unless $fwcode; | |||
| 1086 | 0 | 0 | my %values; | |||
| 1087 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 1088 | 0 | 0 | my $avcode = GetAuthValCode($kohafield,$fwcode); | |||
| 1089 | 0 | 0 | if ($avcode) { | |||
| 1090 | 0 | 0 | my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? "); | |||
| 1091 | 0 | 0 | $sth->execute($avcode); | |||
| 1092 | 0 | 0 | while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) { | |||
| 1093 | 0 | 0 | $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib; | |||
| 1094 | } | |||||
| 1095 | 0 | 0 | return \%values; | |||
| 1096 | } else { | |||||
| 1097 | 0 | 0 | return undef; | |||
| 1098 | } | |||||
| 1099 | } | |||||
| 1100 | ||||||
| 1101 - 1112 | =head2 GetKohaAuthorisedValuesFromField Takes $field, $subfield, $fwcode as parameters. If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist. $subfield can be undefined Returns hashref of Code => description Returns undef if no authorised value category is defined for the given field and subfield =cut | |||||
| 1113 | ||||||
| 1114 | sub GetKohaAuthorisedValuesFromField { | |||||
| 1115 | 0 | 0 | my ($field, $subfield, $fwcode,$opac) = @_; | |||
| 1116 | 0 | 0 | $fwcode='' unless $fwcode; | |||
| 1117 | 0 | 0 | my %values; | |||
| 1118 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 1119 | 0 | 0 | my $avcode = GetAuthValCodeFromField($field, $subfield, $fwcode); | |||
| 1120 | 0 | 0 | if ($avcode) { | |||
| 1121 | 0 | 0 | my $sth = $dbh->prepare("select authorised_value, lib, lib_opac from authorised_values where category=? "); | |||
| 1122 | 0 | 0 | $sth->execute($avcode); | |||
| 1123 | 0 | 0 | while ( my ($val, $lib, $lib_opac) = $sth->fetchrow_array ) { | |||
| 1124 | 0 | 0 | $values{$val} = ($opac && $lib_opac) ? $lib_opac : $lib; | |||
| 1125 | } | |||||
| 1126 | 0 | 0 | return \%values; | |||
| 1127 | } else { | |||||
| 1128 | 0 | 0 | return undef; | |||
| 1129 | } | |||||
| 1130 | } | |||||
| 1131 | ||||||
| 1132 - 1138 | =head2 xml_escape my $escaped_string = C4::Koha::xml_escape($string); Convert &, <, >, ', and " in a string to XML entities =cut | |||||
| 1139 | ||||||
| 1140 | sub xml_escape { | |||||
| 1141 | 2 | 4 | my $str = shift; | |||
| 1142 | 2 | 13 | return '' unless defined $str; | |||
| 1143 | 1 | 5 | $str =~ s/&/&/g; | |||
| 1144 | 1 | 4 | $str =~ s/</</g; | |||
| 1145 | 1 | 4 | $str =~ s/>/>/g; | |||
| 1146 | 1 | 3 | $str =~ s/'/'/g; | |||
| 1147 | 1 | 3 | $str =~ s/"/"/g; | |||
| 1148 | 1 | 8 | return $str; | |||
| 1149 | } | |||||
| 1150 | ||||||
| 1151 - 1159 | =head2 GetKohaAuthorisedValueLib Takes $category, $authorised_value as parameters. If $opac parameter is set to a true value, displays OPAC descriptions rather than normal ones when they exist. Returns authorised value description =cut | |||||
| 1160 | ||||||
| 1161 | sub GetKohaAuthorisedValueLib { | |||||
| 1162 | 0 | 0 | my ($category,$authorised_value,$opac) = @_; | |||
| 1163 | 0 | 0 | my $value; | |||
| 1164 | 0 | 0 | my $dbh = C4::Context->dbh; | |||
| 1165 | 0 | 0 | my $sth = $dbh->prepare("select lib, lib_opac from authorised_values where category=? and authorised_value=?"); | |||
| 1166 | 0 | 0 | $sth->execute($category,$authorised_value); | |||
| 1167 | 0 | 0 | my $data = $sth->fetchrow_hashref; | |||
| 1168 | 0 | 0 | $value = ($opac && $$data{'lib_opac'}) ? $$data{'lib_opac'} : $$data{'lib'}; | |||
| 1169 | 0 | 0 | return $value; | |||
| 1170 | } | |||||
| 1171 | ||||||
| 1172 - 1181 | =head2 display_marc_indicators my $display_form = C4::Koha::display_marc_indicators($field); C<$field> is a MARC::Field object Generate a display form of the indicators of a variable MARC field, replacing any blanks with '#'. =cut | |||||
| 1182 | ||||||
| 1183 | sub display_marc_indicators { | |||||
| 1184 | 0 | 0 | my $field = shift; | |||
| 1185 | 0 | 0 | my $indicators = ''; | |||
| 1186 | 0 | 0 | if ($field->tag() >= 10) { | |||
| 1187 | 0 | 0 | $indicators = $field->indicator(1) . $field->indicator(2); | |||
| 1188 | 0 | 0 | $indicators =~ s/ /#/g; | |||
| 1189 | } | |||||
| 1190 | 0 | 0 | return $indicators; | |||
| 1191 | } | |||||
| 1192 | ||||||
| 1193 | sub GetNormalizedUPC { | |||||
| 1194 | 0 | 0 | my ($record,$marcflavour) = @_; | |||
| 1195 | 0 | 0 | my (@fields,$upc); | |||
| 1196 | ||||||
| 1197 | 0 | 0 | if ($marcflavour eq 'UNIMARC') { | |||
| 1198 | 0 | 0 | @fields = $record->field('072'); | |||
| 1199 | 0 | 0 | foreach my $field (@fields) { | |||
| 1200 | 0 | 0 | my $upc = _normalize_match_point($field->subfield('a')); | |||
| 1201 | 0 | 0 | if ($upc ne '') { | |||
| 1202 | 0 | 0 | return $upc; | |||
| 1203 | } | |||||
| 1204 | } | |||||
| 1205 | ||||||
| 1206 | } | |||||
| 1207 | else { # assume marc21 if not unimarc | |||||
| 1208 | 0 | 0 | @fields = $record->field('024'); | |||
| 1209 | 0 | 0 | foreach my $field (@fields) { | |||
| 1210 | 0 | 0 | my $indicator = $field->indicator(1); | |||
| 1211 | 0 | 0 | my $upc = _normalize_match_point($field->subfield('a')); | |||
| 1212 | 0 | 0 | if ($indicator == 1 and $upc ne '') { | |||
| 1213 | 0 | 0 | return $upc; | |||
| 1214 | } | |||||
| 1215 | } | |||||
| 1216 | } | |||||
| 1217 | } | |||||
| 1218 | ||||||
| 1219 | # Normalizes and returns the first valid ISBN found in the record | |||||
| 1220 | # ISBN13 are converted into ISBN10. This is required to get Amazon cover book. | |||||
| 1221 | sub GetNormalizedISBN { | |||||
| 1222 | 0 | 0 | my ($isbn,$record,$marcflavour) = @_; | |||
| 1223 | 0 | 0 | my @fields; | |||
| 1224 | 0 | 0 | if ($isbn) { | |||
| 1225 | # Koha attempts to store multiple ISBNs in biblioitems.isbn, separated by " | " | |||||
| 1226 | # anything after " | " should be removed, along with the delimiter | |||||
| 1227 | 0 | 0 | $isbn =~ s/(.*)( \| )(.*)/$1/; | |||
| 1228 | 0 | 0 | return _isbn_cleanup($isbn); | |||
| 1229 | } | |||||
| 1230 | 0 | 0 | return undef unless $record; | |||
| 1231 | ||||||
| 1232 | 0 | 0 | if ($marcflavour eq 'UNIMARC') { | |||
| 1233 | 0 | 0 | @fields = $record->field('010'); | |||
| 1234 | 0 | 0 | foreach my $field (@fields) { | |||
| 1235 | 0 | 0 | my $isbn = $field->subfield('a'); | |||
| 1236 | 0 | 0 | if ($isbn) { | |||
| 1237 | 0 | 0 | return _isbn_cleanup($isbn); | |||
| 1238 | } else { | |||||
| 1239 | 0 | 0 | return undef; | |||
| 1240 | } | |||||
| 1241 | } | |||||
| 1242 | } | |||||
| 1243 | else { # assume marc21 if not unimarc | |||||
| 1244 | 0 | 0 | @fields = $record->field('020'); | |||
| 1245 | 0 | 0 | foreach my $field (@fields) { | |||
| 1246 | 0 | 0 | $isbn = $field->subfield('a'); | |||
| 1247 | 0 | 0 | if ($isbn) { | |||
| 1248 | 0 | 0 | return _isbn_cleanup($isbn); | |||
| 1249 | } else { | |||||
| 1250 | 0 | 0 | return undef; | |||
| 1251 | } | |||||
| 1252 | } | |||||
| 1253 | } | |||||
| 1254 | } | |||||
| 1255 | ||||||
| 1256 | sub GetNormalizedEAN { | |||||
| 1257 | 0 | 0 | my ($record,$marcflavour) = @_; | |||
| 1258 | 0 | 0 | my (@fields,$ean); | |||
| 1259 | ||||||
| 1260 | 0 | 0 | if ($marcflavour eq 'UNIMARC') { | |||
| 1261 | 0 | 0 | @fields = $record->field('073'); | |||
| 1262 | 0 | 0 | foreach my $field (@fields) { | |||
| 1263 | 0 | 0 | $ean = _normalize_match_point($field->subfield('a')); | |||
| 1264 | 0 | 0 | if ($ean ne '') { | |||
| 1265 | 0 | 0 | return $ean; | |||
| 1266 | } | |||||
| 1267 | } | |||||
| 1268 | } | |||||
| 1269 | else { # assume marc21 if not unimarc | |||||
| 1270 | 0 | 0 | @fields = $record->field('024'); | |||
| 1271 | 0 | 0 | foreach my $field (@fields) { | |||
| 1272 | 0 | 0 | my $indicator = $field->indicator(1); | |||
| 1273 | 0 | 0 | $ean = _normalize_match_point($field->subfield('a')); | |||
| 1274 | 0 | 0 | if ($indicator == 3 and $ean ne '') { | |||
| 1275 | 0 | 0 | return $ean; | |||
| 1276 | } | |||||
| 1277 | } | |||||
| 1278 | } | |||||
| 1279 | } | |||||
| 1280 | sub GetNormalizedOCLCNumber { | |||||
| 1281 | 0 | 0 | my ($record,$marcflavour) = @_; | |||
| 1282 | 0 | 0 | my (@fields,$oclc); | |||
| 1283 | ||||||
| 1284 | 0 | 0 | if ($marcflavour eq 'UNIMARC') { | |||
| 1285 | # TODO: add UNIMARC fields | |||||
| 1286 | } | |||||
| 1287 | else { # assume marc21 if not unimarc | |||||
| 1288 | 0 | 0 | @fields = $record->field('035'); | |||
| 1289 | 0 | 0 | foreach my $field (@fields) { | |||
| 1290 | 0 | 0 | $oclc = $field->subfield('a'); | |||
| 1291 | 0 | 0 | if ($oclc =~ /OCoLC/) { | |||
| 1292 | 0 | 0 | $oclc =~ s/\(OCoLC\)//; | |||
| 1293 | 0 | 0 | return $oclc; | |||
| 1294 | } else { | |||||
| 1295 | 0 | 0 | return undef; | |||
| 1296 | } | |||||
| 1297 | } | |||||
| 1298 | } | |||||
| 1299 | } | |||||
| 1300 | ||||||
| 1301 | sub _normalize_match_point { | |||||
| 1302 | 0 | 0 | my $match_point = shift; | |||
| 1303 | 0 | 0 | (my $normalized_match_point) = $match_point =~ /([\d-]*[X]*)/; | |||
| 1304 | 0 | 0 | $normalized_match_point =~ s/-//g; | |||
| 1305 | ||||||
| 1306 | 0 | 0 | return $normalized_match_point; | |||
| 1307 | } | |||||
| 1308 | ||||||
| 1309 | sub _isbn_cleanup { | |||||
| 1310 | 3 | 248 | require Business::ISBN; | |||
| 1311 | 3 | 17189 | my $isbn = Business::ISBN->new( $_[0] ); | |||
| 1312 | 3 | 2846 | if ( $isbn ) { | |||
| 1313 | 3 | 51 | $isbn = $isbn->as_isbn10 if $isbn->type eq 'ISBN13'; | |||
| 1314 | 3 | 399 | if (defined $isbn) { | |||
| 1315 | 3 | 57 | return $isbn->as_string([]); | |||
| 1316 | } | |||||
| 1317 | } | |||||
| 1318 | 0 | return; | ||||
| 1319 | } | |||||
| 1320 | ||||||
| 1321 | 1; | |||||
| 1322 | ||||||