[Koha-cvs] koha/C4 Barcodes/PrinterConfig.pm Branch.pm Cal...
paul poulain
paul at koha-fr.org
Fri Mar 9 16:35:32 CET 2007
CVSROOT: /sources/koha
Module name: koha
Changes by: paul poulain <tipaul> 07/03/09 15:35:32
Added files:
C4/Barcodes : PrinterConfig.pm
C4 : Branch.pm Calendar.pm Languages.pm
Maintainance.pm Record.pm
C4/Circulation : Date.pm Returns.pm
C4/tests : Record_test.pl
C4/tests/testrecords: marc21_marc8_combining_chars.dat
marc21_marc8.dat marc21_marc8_errors.dat
marc21_utf8_combining_chars.dat
marc21_utf8.dat
marcxml_utf8_entityencoded.xml
marcxml_utf8.xml
Log message:
rel_3_0 moved to HEAD (introducing new files)
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Barcodes/PrinterConfig.pm?cvsroot=koha&rev=1.4
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Branch.pm?cvsroot=koha&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Calendar.pm?cvsroot=koha&rev=1.3
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Languages.pm?cvsroot=koha&rev=1.2
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Maintainance.pm?cvsroot=koha&rev=1.20
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Record.pm?cvsroot=koha&rev=1.6
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Circulation/Date.pm?cvsroot=koha&rev=1.4
http://cvs.savannah.gnu.org/viewcvs/koha/C4/Circulation/Returns.pm?cvsroot=koha&rev=1.12
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/Record_test.pl?cvsroot=koha&rev=1.4
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/testrecords/marc21_marc8_combining_chars.dat?cvsroot=koha&rev=1.3
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/testrecords/marc21_marc8.dat?cvsroot=koha&rev=1.3
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/testrecords/marc21_marc8_errors.dat?cvsroot=koha&rev=1.3
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/testrecords/marc21_utf8_combining_chars.dat?cvsroot=koha&rev=1.3
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/testrecords/marc21_utf8.dat?cvsroot=koha&rev=1.3
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/testrecords/marcxml_utf8_entityencoded.xml?cvsroot=koha&rev=1.3
http://cvs.savannah.gnu.org/viewcvs/koha/C4/tests/testrecords/marcxml_utf8.xml?cvsroot=koha&rev=1.3
Patches:
Index: Barcodes/PrinterConfig.pm
===================================================================
RCS file: Barcodes/PrinterConfig.pm
diff -N Barcodes/PrinterConfig.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Barcodes/PrinterConfig.pm 9 Mar 2007 15:35:32 -0000 1.4
@@ -0,0 +1,220 @@
+package C4::Barcodes::PrinterConfig;
+
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+require Exporter;
+use vars qw($VERSION @EXPORT);
+
+use PDF::API2;
+use PDF::API2::Page;
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Barcodes::PrinterConfig - Koha module dealing with labels in a PDF.
+
+=head1 SYNOPSIS
+
+ use C4::Barcodes::PrinterConfig;
+
+=head1 DESCRIPTION
+
+This package is used to deal with labels in a pdf file. Giving some parameters,
+this package contains several functions to handle every label considering the
+environment of the pdf file.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at EXPORT = qw(&labelsPage &getLabelPosition setPositionsForX setPositionsForY);
+
+my @positionsForX; # Takes all the X positions of the pdf file.
+my @positionsForY; # Takes all the Y positions of the pdf file.
+my $firstLabel = 1; # Test if the label passed as a parameter is the first label to be printed into the pdf file.
+
+=item setPositionsForX
+
+ C4::Barcodes::PrinterConfig::setPositionsForX($marginLeft, $labelWidth, $columns, $pageType);
+
+Calculate and stores all the X positions across the pdf page.
+
+C<$marginLeft> Indicates how much left margin do you want in your page type.
+
+C<$labelWidth> Indicates the width of the label that you are going to use.
+
+C<$columns> Indicates how many columns do you want in your page type.
+
+C<$pageType> Page type to print (eg: a4, legal, etc).
+
+=cut
+#'
+sub setPositionsForX {
+ my ($marginLeft, $labelWidth, $columns, $pageType) = @_;
+ my $defaultDpi = 72/25.4; # By default we know 25.4 mm -> 1 inch -> 72 dots per inch
+ my $whereToStart = ($marginLeft + ($labelWidth/2));
+ my $firstLabel = $whereToStart*$defaultDpi;
+ my $spaceBetweenLabels = $labelWidth*$defaultDpi;
+ my @positions;
+ for (my $i = 0; $i < $columns ; $i++) {
+ push @positions, ($firstLabel+($spaceBetweenLabels*$i));
+ }
+ @positionsForX = @positions;
+}
+
+=item setPositionsForY
+
+ C4::Barcodes::PrinterConfig::setPositionsForY($marginBottom, $labelHeigth, $rows, $pageType);
+
+Calculate and stores all tha Y positions across the pdf page.
+
+C<$marginBottom> Indicates how much bottom margin do you want in your page type.
+
+C<$labelHeigth> Indicates the height of the label that you are going to use.
+
+C<$rows> Indicates how many rows do you want in your page type.
+
+C<$pageType> Page type to print (eg: a4, legal, etc).
+
+=cut
+#'
+sub setPositionsForY {
+ my ($marginBottom, $labelHeigth, $rows, $pageType) = @_;
+ my $defaultDpi = 72/25.4; # By default we know 25.4 mm -> 1 inch -> 72 dots per inch
+ my $whereToStart = ($marginBottom + ($labelHeigth/2));
+ my $firstLabel = $whereToStart*$defaultDpi;
+ my $spaceBetweenLabels = $labelHeigth*$defaultDpi;
+ my @positions;
+ for (my $i = 0; $i < $rows; $i++) {
+ unshift @positions, ($firstLabel+($spaceBetweenLabels*$i));
+ }
+ @positionsForY = @positions;
+}
+
+=item getLabelPosition
+
+ (my $x, my $y, $pdfObject, $pageObject, $gfxObject, $textObject, $coreObject, $labelPosition) =
+ C4::Barcodes::PrinterConfig::getLabelPosition($labelPosition,
+ $pdfObject,
+ $page,
+ $gfx,
+ $text,
+ $fontObject,
+ $pageType);
+
+Return the (x,y) position of the label that you are going to print considering the environment.
+
+C<$labelPosition> Indicates which label positions do you want to place by x and y coordinates.
+
+C<$pdfObject> The PDF object in use.
+
+C<$page> The page in use.
+
+C<$gfx> The gfx resource to handle with barcodes objects.
+
+C<$text> The text resource to handle with text.
+
+C<$fontObject> The font object
+
+C<$pageType> Page type to print (eg: a4, legal, etc).
+
+=cut
+#'
+sub getLabelPosition {
+ my ($labelNum, $pdf, $page, $gfxObject, $textObject, $fontObject, $pageType) = @_;
+ my $indexX = $labelNum % @positionsForX;
+ my $indexY = int($labelNum / @positionsForX);
+ # Calculates the next label position and return that label number
+ my $nextIndexX = $labelNum % @positionsForX;
+ my $nextIndexY = $labelNum % @positionsForY;
+ if ($firstLabel) {
+ $page = $pdf->page;
+ $page->mediabox($pageType);
+ $gfxObject = $page->gfx;
+ $textObject = $page->text;
+ $textObject->font($fontObject, 7);
+ $firstLabel = 0;
+ } elsif (($nextIndexX == 0) && ($nextIndexY == 0)) {
+ $page = $pdf->page;
+ $page->mediabox($pageType);
+ $gfxObject = $page->gfx;
+ $textObject = $page->text;
+ $textObject->font($fontObject, 7);
+ }
+ $labelNum = $labelNum + 1;
+ if ($labelNum == (@positionsForX*@positionsForY)) {
+ $labelNum = 0;
+ }
+ return ($positionsForX[$indexX], $positionsForY[$indexY], $pdf, $page, $gfxObject, $textObject, $fontObject, $labelNum);
+}
+
+=item labelsPage
+
+ my @labelTable = C4::Barcodes::PrinterConfig::labelsPage($rows, $columns);
+
+This function will help you to build the labels panel, where you can choose
+wich label position do you want to start the printer process.
+
+C<$rows> Indicates how many rows do you want in your page type.
+
+C<$columns> Indicates how many rows do you want in your page type.
+
+=cut
+#'
+sub labelsPage{
+ my ($rows, $columns) = @_;
+ my @pageType;
+ my $tagname = 0;
+ my $labelname = 1;
+ my $check;
+ for (my $i = 1; $i <= $rows; $i++) {
+ my @column;
+ for (my $j = 1; $j <= $columns; $j++) {
+ my %cell;
+ if ($tagname == 0) {
+ $check = 'checked';
+ } else {
+ $check = '';
+ }
+ %cell = (check => $check,
+ tagname => $tagname,
+ labelname => $labelname);
+ $tagname = $tagname + 1;
+ $labelname = $labelname + 1;
+ push @column, \%cell;
+ }
+ my %columns = (columns => \@column);
+ push @pageType, \%columns;
+ }
+ return @pageType;
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Physics Library UNLP <matias_veleda at hotmail.com>
+
+=cut
\ No newline at end of file
Index: Branch.pm
===================================================================
RCS file: Branch.pm
diff -N Branch.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Branch.pm 9 Mar 2007 15:35:32 -0000 1.2
@@ -0,0 +1,443 @@
+package C4::Branch;
+
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+# $Id: Branch.pm,v 1.2 2007/03/09 15:35:32 tipaul Exp $
+
+use strict;
+require Exporter;
+use C4::Context;
+use C4::Koha;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.2 $' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
+
+=head1 NAME
+
+C4::Branch - Koha branch module
+
+=head1 SYNOPSIS
+
+use C4::Branch;
+
+=head1 DESCRIPTION
+
+The functions in this module deal with branches.
+
+=head1 FUNCTIONS
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &GetBranchCategory
+ &GetBranchName
+ &GetBranch
+ &GetBranches
+ &GetBranchDetail
+ &get_branchinfos_of
+ &ModBranch
+ &CheckBranchCategorycode
+ &GetBranchInfo
+ &ModBranchCategoryInfo
+ &DelBranch
+);
+
+=head2 GetBranches
+
+ $branches = &GetBranches();
+ returns informations about ALL branches.
+ Create a branch selector with the following code
+ IndependantBranches Insensitive...
+
+=head3 in PERL SCRIPT
+
+my $branches = GetBranches;
+my @branchloop;
+foreach my $thisbranch (keys %$branches) {
+ my $selected = 1 if $thisbranch eq $branch;
+ my %row =(value => $thisbranch,
+ selected => $selected,
+ branchname => $branches->{$thisbranch}->{'branchname'},
+ );
+ push @branchloop, \%row;
+}
+
+
+=head3 in TEMPLATE
+ <select name="branch">
+ <option value="">Default</option>
+ <!-- TMPL_LOOP name="branchloop" -->
+ <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="branchname" --></option>
+ <!-- /TMPL_LOOP -->
+ </select>
+
+=cut
+
+sub GetBranches {
+
+ my $onlymine=@_;
+ # returns a reference to a hash of references to ALL branches...
+ my %branches;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ my $query="SELECT * from branches";
+ if ($onlymine && C4::Context->userenv && C4::Context->userenv->{branch}){
+ $query .= " WHERE branchcode =".$dbh->quote(C4::Context->userenv->{branch});
+ }
+ $query.=" order by branchname";
+ $sth = $dbh->prepare($query);
+ $sth->execute;
+ while ( my $branch = $sth->fetchrow_hashref ) {
+ my $nsth =
+ $dbh->prepare(
+ "select categorycode from branchrelations where branchcode = ?");
+ $nsth->execute( $branch->{'branchcode'} );
+ while ( my ($cat) = $nsth->fetchrow_array ) {
+
+ # FIXME - This seems wrong. It ought to be
+ # $branch->{categorycodes}{$cat} = 1;
+ # otherwise, there's a namespace collision if there's a
+ # category with the same name as a field in the 'branches'
+ # table (i.e., don't create a category called "issuing").
+ # In addition, the current structure doesn't really allow
+ # you to list the categories that a branch belongs to:
+ # you'd have to list keys %$branch, and remove those keys
+ # that aren't fields in the "branches" table.
+ $branch->{$cat} = 1;
+ }
+ $branches{ $branch->{'branchcode'} } = $branch;
+ }
+ return ( \%branches );
+}
+
+=head2 GetBranchName
+
+=cut
+
+sub GetBranchName {
+ my ($branchcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ $sth = $dbh->prepare("Select branchname from branches where branchcode=?");
+ $sth->execute($branchcode);
+ my $branchname = $sth->fetchrow_array;
+ $sth->finish;
+ return ($branchname);
+}
+
+=head2 ModBranch
+
+&ModBranch($newvalue);
+
+This function modify an existing branches.
+
+C<$newvalue> is a ref to an array wich is containt all the column from branches table.
+
+=cut
+
+sub ModBranch {
+ my ($data) = @_;
+
+ my $dbh = C4::Context->dbh;
+ if ($data->{add}) {
+ my $query = "
+ INSERT INTO branches
+ (branchcode,branchname,branchaddress1,
+ branchaddress2,branchaddress3,branchphone,
+ branchfax,branchemail,branchip,branchprinter)
+ VALUES (?,?,?,?,?,?,?,?,?,?)
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $data->{'branchcode'}, $data->{'branchname'},
+ $data->{'branchaddress1'}, $data->{'branchaddress2'},
+ $data->{'branchaddress3'}, $data->{'branchphone'},
+ $data->{'branchfax'}, $data->{'branchemail'},
+ $data->{'branchip'}, $data->{'branchprinter'},
+ );
+ } else {
+ my $query = "
+ UPDATE branches
+ SET branchname=?,branchaddress1=?,
+ branchaddress2=?,branchaddress3=?,branchphone=?,
+ branchfax=?,branchemail=?,branchip=?,branchprinter=?
+ WHERE branchcode=?
+ ";
+ my $sth = $dbh->prepare($query);
+ $sth->execute(
+ $data->{'branchname'},
+ $data->{'branchaddress1'}, $data->{'branchaddress2'},
+ $data->{'branchaddress3'}, $data->{'branchphone'},
+ $data->{'branchfax'}, $data->{'branchemail'},
+ $data->{'branchip'}, $data->{'branchprinter'},
+ $data->{'branchcode'},
+ );
+ }
+ # sort out the categories....
+ my @checkedcats;
+ my $cats = GetBranchCategory();
+ foreach my $cat (@$cats) {
+ my $code = $cat->{'categorycode'};
+ if ( $data->{$code} ) {
+ push( @checkedcats, $code );
+ }
+ }
+ my $branchcode = uc( $data->{'branchcode'} );
+ my $branch = GetBranchInfo($branchcode);
+ $branch = $branch->[0];
+ my $branchcats = $branch->{'categories'};
+ my @addcats;
+ my @removecats;
+ foreach my $bcat (@$branchcats) {
+
+ unless ( grep { /^$bcat$/ } @checkedcats ) {
+ push( @removecats, $bcat );
+ }
+ }
+ foreach my $ccat (@checkedcats) {
+ unless ( grep { /^$ccat$/ } @$branchcats ) {
+ push( @addcats, $ccat );
+ }
+ }
+ foreach my $cat (@addcats) {
+ my $sth =
+ $dbh->prepare(
+"insert into branchrelations (branchcode, categorycode) values(?, ?)"
+ );
+ $sth->execute( $branchcode, $cat );
+ $sth->finish;
+ }
+ foreach my $cat (@removecats) {
+ my $sth =
+ $dbh->prepare(
+ "delete from branchrelations where branchcode=? and categorycode=?"
+ );
+ $sth->execute( $branchcode, $cat );
+ $sth->finish;
+ }
+}
+
+=head2 GetBranchCategory
+
+$results = GetBranchCategory($categorycode);
+
+C<$results> is an ref to an array.
+
+=cut
+
+sub GetBranchCategory {
+
+ # returns a reference to an array of hashes containing branches,
+ my ($catcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+
+ # print DEBUG "GetBranchCategory: entry: catcode=".cvs($catcode)."\n";
+ if ($catcode) {
+ $sth =
+ $dbh->prepare(
+ "select * from branchcategories where categorycode = ?");
+ $sth->execute($catcode);
+ }
+ else {
+ $sth = $dbh->prepare("Select * from branchcategories");
+ $sth->execute();
+ }
+ my @results;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ push( @results, $data );
+ }
+ $sth->finish;
+
+ # print DEBUG "GetBranchCategory: exit: returning ".cvs(\@results)."\n";
+ return \@results;
+}
+
+=head2 GetBranch
+
+$branch = GetBranch( $query, $branches );
+
+=cut
+
+sub GetBranch ($$) {
+ my ( $query, $branches ) = @_; # get branch for this query from branches
+ my $branch = $query->param('branch');
+ my %cookie = $query->cookie('userenv');
+ ($branch) || ($branch = $cookie{'branchname'});
+ ( $branches->{$branch} ) || ( $branch = ( keys %$branches )[0] );
+ return $branch;
+}
+
+=head2 GetBranchDetail
+
+ $branchname = &GetBranchDetail($branchcode);
+
+Given the branch code, the function returns the corresponding
+branch name for a comprehensive information display
+
+=cut
+
+sub GetBranchDetail {
+ my ($branchcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("SELECT * FROM branches WHERE branchcode = ?");
+ $sth->execute($branchcode);
+ my $branchname = $sth->fetchrow_hashref();
+ $sth->finish();
+ return $branchname;
+}
+
+
+=head2 get_branchinfos_of
+
+ my $branchinfos_of = get_branchinfos_of(@branchcodes);
+
+Associates a list of branchcodes to the information of the branch, taken in
+branches table.
+
+Returns a href where keys are branchcodes and values are href where keys are
+branch information key.
+
+ print 'branchname is ', $branchinfos_of->{$code}->{branchname};
+
+=cut
+
+sub get_branchinfos_of {
+ my @branchcodes = @_;
+
+ my $query = '
+ SELECT branchcode,
+ branchname
+ FROM branches
+ WHERE branchcode IN ('
+ . join( ',', map( { "'" . $_ . "'" } @branchcodes ) ) . ')
+';
+ return C4::Koha::get_infos_of( $query, 'branchcode' );
+}
+
+=head2 GetBranchInfo
+
+$results = GetBranchInfo($branchcode);
+
+returns C<$results>, a reference to an array of hashes containing branches.
+
+=cut
+
+sub GetBranchInfo {
+ my ($branchcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth;
+ if ($branchcode) {
+ $sth =
+ $dbh->prepare(
+ "Select * from branches where branchcode = ? order by branchcode");
+ $sth->execute($branchcode);
+ }
+ else {
+ $sth = $dbh->prepare("Select * from branches order by branchcode");
+ $sth->execute();
+ }
+ my @results;
+ while ( my $data = $sth->fetchrow_hashref ) {
+ my $nsth =
+ $dbh->prepare(
+ "select categorycode from branchrelations where branchcode = ?");
+ $nsth->execute( $data->{'branchcode'} );
+ my @cats = ();
+ while ( my ($cat) = $nsth->fetchrow_array ) {
+ push( @cats, $cat );
+ }
+ $nsth->finish;
+ $data->{'categories'} = \@cats;
+ push( @results, $data );
+ }
+ $sth->finish;
+ return \@results;
+}
+
+=head2 DelBranch
+
+&DelBranch($branchcode);
+
+=cut
+
+sub DelBranch {
+ my ($branchcode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("delete from branches where branchcode = ?");
+ $sth->execute($branchcode);
+ $sth->finish;
+}
+
+=head2 ModBranchCategoryInfo
+
+&ModBranchCategoryInfo($data);
+sets the data from the editbranch form, and writes to the database...
+
+=cut
+
+sub ModBranchCategoryInfo {
+
+ my ($data) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("replace branchcategories (categorycode,categoryname,codedescription) values (?,?,?)");
+ $sth->execute(uc( $data->{'categorycode'} ),$data->{'categoryname'}, $data->{'codedescription'} );
+ $sth->finish;
+}
+
+=head2 DeleteBranchCategory
+
+DeleteBranchCategory($categorycode);
+
+=cut
+
+sub DeleteBranchCategory {
+ my ($categorycode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth = $dbh->prepare("delete from branchcategories where categorycode = ?");
+ $sth->execute($categorycode);
+ $sth->finish;
+}
+
+=head2 CheckBranchCategorycode
+
+$number_rows_affected = CheckBranchCategorycode($categorycode);
+
+=cut
+
+sub CheckBranchCategorycode {
+
+ # check to see if the branchcode is being used in the database somewhere....
+ my ($categorycode) = @_;
+ my $dbh = C4::Context->dbh;
+ my $sth =
+ $dbh->prepare(
+ "select count(*) from branchrelations where categorycode=?");
+ $sth->execute($categorycode);
+ my ($total) = $sth->fetchrow_array;
+ return $total;
+}
+
+
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Calendar.pm
===================================================================
RCS file: Calendar.pm
diff -N Calendar.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Calendar.pm 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1,561 @@
+package C4::Calendar;
+
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+require Exporter;
+use vars qw($VERSION @EXPORT);
+
+#use Date::Manip;
+# use Date::Calc;
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.3 $' =~ /\d+/g; shift(@v).".".join( "_", map { sprintf "%03d", $_ } @v ); };
+
+=head1 NAME
+
+C4::Calendar::Calendar - Koha module dealing with holidays.
+
+=head1 SYNOPSIS
+
+ use C4::Calendar::Calendar;
+
+=head1 DESCRIPTION
+
+This package is used to deal with holidays. Through this package, you can set all kind of holidays for the library.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at EXPORT = qw(&new
+ &change_branchcode
+ &get_week_days_holidays
+ &get_day_month_holidays
+ &get_exception_holidays
+ &get_single_holidays
+ &insert_week_day_holiday
+ &insert_day_month_holiday
+ &insert_single_holiday
+ &insert_exception_holiday
+ &delete_holiday
+ &isHoliday
+ &addDate
+ &daysBetween);
+
+=item new
+
+ $calendar = C4::Calendar::Calendar->new(branchcode => $branchcode);
+
+C<$branchcode> Is the branch code wich you want to use calendar.
+
+=cut
+
+sub new {
+ my $classname = shift @_;
+ my %options = @_;
+
+ my %hash;
+ my $self = bless(\%hash, $classname);
+
+ foreach my $optionName (keys %options) {
+ $self->{lc($optionName)} = $options{$optionName};
+ }
+
+ $self->_init;
+
+ return $self;
+}
+
+sub _init {
+ my $self = shift @_;
+
+ my $dbh = C4::Context->dbh();
+ my $week_days_sql = $dbh->prepare("select weekday, title, description from repeatable_holidays where ('$self->{branchcode}' = branchcode) and (NOT(ISNULL(weekday)))");
+ $week_days_sql->execute;
+ my %week_days_holidays;
+ while (my ($weekday, $title, $description) = $week_days_sql->fetchrow) {
+ $week_days_holidays{$weekday}{title} = $title;
+ $week_days_holidays{$weekday}{description} = $description;
+ }
+ $week_days_sql->finish;
+ $self->{'week_days_holidays'} = \%week_days_holidays;
+
+ my $day_month_sql = $dbh->prepare("select day, month, title, description from repeatable_holidays where ('$self->{branchcode}' = branchcode) and ISNULL(weekday)");
+ $day_month_sql->execute;
+ my %day_month_holidays;
+ while (my ($day, $month, $title, $description) = $day_month_sql->fetchrow) {
+ $day_month_holidays{"$month/$day"}{title} = $title;
+ $day_month_holidays{"$month/$day"}{description} = $description;
+ }
+ $day_month_sql->finish;
+ $self->{'day_month_holidays'} = \%day_month_holidays;
+
+ my $exception_holidays_sql = $dbh->prepare("select day, month, year, title, description from special_holidays where ('$self->{branchcode}' = branchcode) and (isexception = 1)");
+ $exception_holidays_sql->execute;
+ my %exception_holidays;
+ while (my ($day, $month, $year, $title, $description) = $exception_holidays_sql->fetchrow) {
+ $exception_holidays{"$year/$month/$day"}{title} = $title;
+ $exception_holidays{"$year/$month/$day"}{description} = $description;
+ }
+ $exception_holidays_sql->finish;
+ $self->{'exception_holidays'} = \%exception_holidays;
+
+ my $holidays_sql = $dbh->prepare("select day, month, year, title, description from special_holidays where ('$self->{branchcode}' = branchcode) and (isexception = 0)");
+ $holidays_sql->execute;
+ my %single_holidays;
+ while (my ($day, $month, $year, $title, $description) = $holidays_sql->fetchrow) {
+ $single_holidays{"$year/$month/$day"}{title} = $title;
+ $single_holidays{"$year/$month/$day"}{description} = $description;
+ }
+ $holidays_sql->finish;
+ $self->{'single_holidays'} = \%single_holidays;
+}
+
+=item change_branchcode
+
+ $calendar->change_branchcode(branchcode => $branchcode)
+
+Change the calendar branch code. This means to change the holidays structure.
+
+C<$branchcode> Is the branch code wich you want to use calendar.
+
+=cut
+
+sub change_branchcode {
+ my ($self, $branchcode) = @_;
+ my %options = @_;
+
+ foreach my $optionName (keys %options) {
+ $self->{lc($optionName)} = $options{$optionName};
+ }
+ $self->_init;
+
+ return $self;
+}
+
+=item get_week_days_holidays
+
+ $week_days_holidays = $calendar->get_week_days_holidays();
+
+Returns a hash reference to week days holidays.
+
+=cut
+
+sub get_week_days_holidays {
+ my $self = shift @_;
+ my $week_days_holidays = $self->{'week_days_holidays'};
+ return $week_days_holidays;
+}
+
+=item get_day_month_holidays
+
+ $day_month_holidays = $calendar->get_day_month_holidays();
+
+Returns a hash reference to day month holidays.
+
+=cut
+
+sub get_day_month_holidays {
+ my $self = shift @_;
+ my $day_month_holidays = $self->{'day_month_holidays'};
+ return $day_month_holidays;
+}
+
+=item get_exception_holidays
+
+ $exception_holidays = $calendar->exception_holidays();
+
+Returns a hash reference to exception holidays. This kind of days are those
+which stands for a holiday, but you wanted to make an exception for this particular
+date.
+
+=cut
+
+sub get_exception_holidays {
+ my $self = shift @_;
+ my $exception_holidays = $self->{'exception_holidays'};
+ return $exception_holidays;
+}
+
+=item get_single_holidays
+
+ $single_holidays = $calendar->get_single_holidays();
+
+Returns a hash reference to single holidays. This kind of holidays are those which
+happend just one time.
+
+=cut
+
+sub get_single_holidays {
+ my $self = shift @_;
+ my $single_holidays = $self->{'single_holidays'};
+ return $single_holidays;
+}
+
+=item insert_week_day_holiday
+
+ insert_week_day_holiday(weekday => $weekday,
+ title => $title,
+ description => $description);
+
+Inserts a new week day for $self->{branchcode}.
+
+C<$day> Is the week day to make holiday.
+
+C<$title> Is the title to store for the holiday formed by $year/$month/$day.
+
+C<$description> Is the description to store for the holiday formed by $year/$month/$day.
+
+=cut
+
+sub insert_week_day_holiday {
+ my $self = shift @_;
+ my %options = @_;
+
+ my $dbh = C4::Context->dbh();
+ my $insertHoliday = $dbh->prepare("insert into repeatable_holidays (id,branchcode,weekday,day,month,title,description) values ( '',?,?,NULL,NULL,?,? )");
+ $insertHoliday->execute( $self->{branchcode}, $options{weekday},$options{title}, $options{description});
+ $insertHoliday->finish;
+
+ $self->{'week_days_holidays'}->{$options{weekday}}{title} = $options{title};
+ $self->{'week_days_holidays'}->{$options{weekday}}{description} = $options{description};
+ return $self;
+}
+
+=item insert_day_month_holiday
+
+ insert_day_month_holiday(day => $day,
+ month => $month,
+ title => $title,
+ description => $description);
+
+Inserts a new day month holiday for $self->{branchcode}.
+
+C<$day> Is the day month to make the date to insert.
+
+C<$month> Is month to make the date to insert.
+
+C<$title> Is the title to store for the holiday formed by $year/$month/$day.
+
+C<$description> Is the description to store for the holiday formed by $year/$month/$day.
+
+=cut
+
+sub insert_day_month_holiday {
+ my $self = shift @_;
+ my %options = @_;
+
+ my $dbh = C4::Context->dbh();
+ my $insertHoliday = $dbh->prepare("insert into repeatable_holidays (id,branchcode,weekday,day,month,title,description) values ('', ?, NULL, ?, ?, ?,? )");
+ $insertHoliday->execute( $self->{branchcode}, $options{day},$options{month},$options{title}, $options{description});
+ $insertHoliday->finish;
+
+ $self->{'day_month_holidays'}->{"$options{month}/$options{day}"}{title} = $options{title};
+ $self->{'day_month_holidays'}->{"$options{month}/$options{day}"}{description} = $options{description};
+ return $self;
+}
+
+=item insert_single_holiday
+
+ insert_single_holiday(day => $day,
+ month => $month,
+ year => $year,
+ title => $title,
+ description => $description);
+
+Inserts a new single holiday for $self->{branchcode}.
+
+C<$day> Is the day month to make the date to insert.
+
+C<$month> Is month to make the date to insert.
+
+C<$year> Is year to make the date to insert.
+
+C<$title> Is the title to store for the holiday formed by $year/$month/$day.
+
+C<$description> Is the description to store for the holiday formed by $year/$month/$day.
+
+=cut
+
+sub insert_single_holiday {
+ my $self = shift @_;
+ my %options = @_;
+
+ my $dbh = C4::Context->dbh();
+ my $isexception = 0;
+ my $insertHoliday = $dbh->prepare("insert into special_holidays (id,branchcode,day,month,year,isexception,title,description) values ('', ?,?,?,?,?,?,?)");
+ $insertHoliday->execute( $self->{branchcode}, $options{day},$options{month},$options{year}, $isexception, $options{title}, $options{description});
+ $insertHoliday->finish;
+
+ $self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{title} = $options{title};
+ $self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
+ return $self;
+}
+
+=item insert_exception_holiday
+
+ insert_exception_holiday(day => $day,
+ month => $month,
+ year => $year,
+ title => $title,
+ description => $description);
+
+Inserts a new exception holiday for $self->{branchcode}.
+
+C<$day> Is the day month to make the date to insert.
+
+C<$month> Is month to make the date to insert.
+
+C<$year> Is year to make the date to insert.
+
+C<$title> Is the title to store for the holiday formed by $year/$month/$day.
+
+C<$description> Is the description to store for the holiday formed by $year/$month/$day.
+
+=cut
+
+sub insert_exception_holiday {
+ my $self = shift @_;
+ my %options = @_;
+
+ my $dbh = C4::Context->dbh();
+ my $isexception = 1;
+ my $insertException = $dbh->prepare("insert into special_holidays (id,branchcode,day,month,year,isexception,title,description) values ('', ?,?,?,?,?,?,?)");
+ $insertException->execute( $self->{branchcode}, $options{day},$options{month},$options{year}, $isexception, $options{title}, $options{description});
+ $insertException->finish;
+
+ $self->{'exceptions_holidays'}->{"$options{year}/$options{month}/$options{day}"}{title} = $options{title};
+ $self->{'exceptions_holidays'}->{"$options{year}/$options{month}/$options{day}"}{description} = $options{description};
+ return $self;
+}
+
+=item delete_holiday
+
+ delete_holiday(weekday => $weekday
+ day => $day,
+ month => $month,
+ year => $year);
+
+Delete a holiday for $self->{branchcode}.
+
+C<$weekday> Is the week day to delete.
+
+C<$day> Is the day month to make the date to delete.
+
+C<$month> Is month to make the date to delete.
+
+C<$year> Is year to make the date to delete.
+
+=cut
+
+sub delete_holiday {
+ my $self = shift @_;
+ my %options = @_;
+
+ # Verify what kind of holiday that day is. For example, if it is
+ # a repeatable holiday, this should check if there are some exception
+ # for that holiday rule. Otherwise, if it is a regular holiday, it´s
+ # ok just deleting it.
+
+ my $dbh = C4::Context->dbh();
+ my $isSingleHoliday = $dbh->prepare("select id from special_holidays where (branchcode = '$self->{branchcode}') and (day = $options{day}) and (month = $options{month}) and (year = $options{year})");
+ $isSingleHoliday->execute;
+ if ($isSingleHoliday->rows) {
+ my $id = $isSingleHoliday->fetchrow;
+ $isSingleHoliday->finish; # Close the last query
+
+ my $deleteHoliday = $dbh->prepare("delete from special_holidays where (id = $id)");
+ $deleteHoliday->execute;
+ $deleteHoliday->finish; # Close the last query
+ delete($self->{'single_holidays'}->{"$options{year}/$options{month}/$options{day}"});
+ } else {
+ $isSingleHoliday->finish; # Close the last query
+
+ my $isWeekdayHoliday = $dbh->prepare("select id from repeatable_holidays where (branchcode = '$self->{branchcode}') and (weekday = $options{weekday})");
+ $isWeekdayHoliday->execute;
+ if ($isWeekdayHoliday->rows) {
+ my $id = $isWeekdayHoliday->fetchrow;
+ $isWeekdayHoliday->finish; # Close the last query
+
+ my $updateExceptions = $dbh->prepare("update special_holidays set isexception = 0 where (WEEKDAY(CONCAT(special_holidays.year,'-',special_holidays.month,'-',special_holidays.day)) = $options{weekday}) and (branchcode = '$self->{branchcode}')");
+ $updateExceptions->execute;
+ $updateExceptions->finish; # Close the last query
+
+ my $deleteHoliday = $dbh->prepare("delete from repeatable_holidays where (id = $id)");
+ $deleteHoliday->execute;
+ $deleteHoliday->finish;
+ delete($self->{'week_days_holidays'}->{$options{weekday}});
+ } else {
+ $isWeekdayHoliday->finish; # Close the last query
+
+ my $isDayMonthHoliday = $dbh->prepare("select id from repeatable_holidays where (branchcode = '$self->{branchcode}') and (day = '$options{day}') and (month = '$options{month}')");
+ $isDayMonthHoliday->execute;
+ if ($isDayMonthHoliday->rows) {
+ my $id = $isDayMonthHoliday->fetchrow;
+ $isDayMonthHoliday->finish;
+ my $updateExceptions = $dbh->prepare("update special_holidays set isexception = 0 where (special_holidays.branchcode = '$self->{branchcode}') and (special_holidays.day = '$options{day}') and (special_holidays.month = '$options{month}')");
+ $updateExceptions->execute;
+ $updateExceptions->finish; # Close the last query
+
+ my $deleteHoliday = $dbh->prepare("delete from repeatable_holidays where (id = '$id')");
+ $deleteHoliday->execute;
+ $deleteHoliday->finish; # Close the last query
+ $isDayMonthHoliday->finish; # Close the last query
+ delete($self->{'day_month_holidays'}->{"$options{month}/$options{day}"});
+ }
+ }
+ }
+ return $self;
+}
+
+=item isHoliday
+
+ $isHoliday = isHoliday($day, $month $year);
+
+
+C<$day> Is the day to check wether if is a holiday or not.
+
+C<$month> Is the month to check wether if is a holiday or not.
+
+C<$year> Is the year to check wether if is a holiday or not.
+
+=cut
+
+sub isHoliday {
+ my ($self, $day, $month, $year) = @_;
+
+ my $weekday = Date_DayOfWeek($month, $day, $year) % 7;
+
+ my $weekDays = $self->get_week_days_holidays();
+ my $dayMonths = $self->get_day_month_holidays();
+ my $exceptions = $self->get_exception_holidays();
+ my $singles = $self->get_single_holidays();
+
+ if (defined($exceptions->{"$year/$month/$day"})) {
+ return 0;
+ } else {
+ if ((exists($weekDays->{$weekday})) ||
+ (exists($dayMonths->{"$month/$day"})) ||
+ (exists($singles->{"$year/$month/$day"}))) {
+ return 1;
+ } else {
+ return 0;
+ }
+ }
+
+}
+
+=item addDate
+
+ my ($day, $month, $year) = $calendar->addDate($day, $month, $year, $offset)
+
+C<$day> Is the starting day of the interval.
+
+C<$month> Is the starting month of the interval.
+
+C<$year> Is the starting year of the interval.
+
+C<$offset> Is the number of days that this function has to count from $date.
+
+=cut
+
+sub addDate {
+ my ($self, $day, $month, $year, $offset) = @_;
+
+ if ($offset < 0) { # In case $offset is negative
+ $offset = $offset*(-1);
+ }
+
+ my $daysMode = C4::Context->preference('useDaysMode');
+ if ($daysMode eq 'normal') {
+ ($year, $month, $day) = &Date::Calc::Add_Delta_Days($year, $month, $day, ($offset - 1));
+ } else {
+ while ($offset > 0) {
+ if (!($self->isHoliday($day, $month, $year))) {
+ $offset = $offset - 1;
+ }
+ if ($offset > 0) {
+ ($year, $month, $day) = &Date::Calc::Add_Delta_Days($year, $month, $day, 1);
+ }
+ }
+ }
+
+ return($day, $month, $year);
+}
+
+=item daysBetween
+
+ my $daysBetween = $calendar->daysBetween($dayFrom, $monthFrom, $yearFrom,
+ $dayTo, $monthTo, $yearTo)
+
+C<$dayFrom> Is the starting day of the interval.
+
+C<$monthFrom> Is the starting month of the interval.
+
+C<$yearFrom> Is the starting year of the interval.
+
+C<$dayTo> Is the ending day of the interval.
+
+C<$monthTo> Is the ending month of the interval.
+
+C<$yearTo> Is the ending year of the interval.
+
+=cut
+
+sub daysBetween {
+ my ($self, $dayFrom, $monthFrom, $yearFrom, $dayTo, $monthTo, $yearTo) = @_;
+
+ my $daysMode = C4::Context->preference('useDaysMode');
+ my $count = 1;
+ my $continue = 1;
+ if ($daysMode eq 'normal') {
+ while ($continue) {
+ if (($yearFrom != $yearTo) || ($monthFrom != $monthTo) || ($dayFrom != $dayTo)) {
+ ($yearFrom, $monthFrom, $dayFrom) = &Date::Calc::Add_Delta_Days($yearFrom, $monthFrom, $dayFrom, 1);
+ $count++;
+ } else {
+ $continue = 0;
+ }
+ }
+ } else {
+ while ($continue) {
+ if (($yearFrom != $yearTo) || ($monthFrom != $monthTo) || ($dayFrom != $dayTo)) {
+ if (!($self->isHoliday($dayFrom, $monthFrom, $yearFrom))) {
+ $count++;
+ }
+ ($yearFrom, $monthFrom, $dayFrom) = &Date::Calc::Add_Delta_Days($yearFrom, $monthFrom, $dayFrom, 1);
+ } else {
+ $continue = 0;
+ }
+ }
+ }
+ return($count);
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Physics Library UNLP <matias_veleda at hotmail.com>
+
+=cut
Index: Languages.pm
===================================================================
RCS file: Languages.pm
diff -N Languages.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Languages.pm 9 Mar 2007 15:35:32 -0000 1.2
@@ -0,0 +1,451 @@
+package C4::Languages;
+
+# Copyright 2006 (C) LibLime
+# Joshua Ferraro <jmf at liblime.com>
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+# $Id: Languages.pm,v 1.2 2007/03/09 15:35:32 tipaul Exp $
+
+use strict; use warnings; #FIXME: turn off warnings before release
+require Exporter;
+use C4::Context;
+use vars qw($VERSION @ISA @EXPORT);
+
+$VERSION = do { my @v = '$Revision: 1.2 $' =~ /\d+/g; shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v ); };
+
+=head1 NAME
+
+C4::Languages - Perl Module containing language list functions for Koha
+
+=head1 SYNOPSIS
+
+use C4::Languages;
+
+=head1 DESCRIPTION
+
+=head1 FUNCTIONS
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(
+ &getFrameworkLanguages
+ &getTranslatedLanguages
+ &getAllLanguages
+ );
+
+my $DEBUG = 0;
+
+=head2 getFrameworkLanguages
+
+Returns a reference to an array of hashes:
+
+ my $languages = getFrameworkLanguages();
+ for my $language(@$languages) {
+ print "$language->{language_code}\n"; # language code in iso 639-2
+ print "$language->{language_name}\n"; # language name in native script
+ print "$language->{language_locale_name}\n"; # language name in current locale
+ }
+
+=cut
+
+sub getFrameworkLanguages {
+ # get a hash with all language codes, names, and locale names
+ my $all_languages = getAllLanguages();
+ my @languages;
+
+ # find the available directory names
+ my $dir=C4::Context->config('intranetdir')."/misc/sql-datas/";
+ opendir (MYDIR,$dir);
+ my @listdir= grep { !/^\.|CVS/ && -d "$dir/$_"} readdir(MYDIR);
+ closedir MYDIR;
+
+ # pull out all data for the dir names that exist
+ for my $dirname (@listdir) {
+ for my $language_set (@$all_languages) {
+ my $language_name = $language_set->{language_name};
+ my $language_locale_name = $language_set->{language_locale_name};
+
+ if ($dirname eq $language_set->{language_code}) {
+ push @languages, {'language_code'=>$dirname, 'language_name'=>$language_name, 'language_locale_name'=>$language_locale_name}
+ }
+ }
+ }
+ return \@languages;
+}
+
+=head2 getTranslatedLanguages
+
+Returns a reference to an array of hashes:
+
+ my $languages = getTranslatedLanguages();
+ print "Available translated langauges:\n";
+ for my $language(@$trlanguages) {
+ print "$language->{language_code}\n"; # language code in iso 639-2
+ print "$language->{language_name}\n"; # language name in native script
+ print "$language->{language_locale_name}\n"; # language name in current locale
+ }
+
+=cut
+
+sub getTranslatedLanguages {
+ my ($interface, $theme) = @_;
+ my $htdocs;
+ my $all_languages = getAllLanguages();
+ my @languages;
+ my $lang;
+
+ if ( $interface eq 'opac' ) {
+ $htdocs = C4::Context->config('opachtdocs');
+ if ( $theme and -d "$htdocs/$theme" ) {
+ (@languages) = _get_language_dirs($htdocs,$theme);
+ return _get_final_languages($all_languages, at languages);
+ }
+ else {
+ for my $theme ( _get_themes('opac') ) {
+ push @languages, _get_language_dirs($htdocs,$theme);
+ }
+ return _get_final_languages($all_languages, at languages);
+ }
+ }
+ elsif ( $interface eq 'intranet' ) {
+ $htdocs = C4::Context->config('intrahtdocs');
+ if ( $theme and -d "$htdocs/$theme" ) {
+ @languages = _get_language_dirs($htdocs,$theme);
+ return _get_final_languages($all_languages, at languages);
+ }
+ else {
+ foreach my $theme ( _get_themes('opac') ) {
+ push @languages, _get_language_dirs($htdocs,$theme);
+ }
+ return _get_final_languages($all_languages, at languages);
+ }
+ }
+ else {
+ my $htdocs = C4::Context->config('intrahtdocs');
+ foreach my $theme ( _get_themes('intranet') ) {
+ push @languages, _get_language_dirs($htdocs,$theme);
+ }
+ $htdocs = C4::Context->config('opachtdocs');
+ foreach my $theme ( _get_themes('opac') ) {
+ push @languages, _get_language_dirs($htdocs,$theme);
+ }
+ return _get_final_languages($all_languages, at languages);
+ }
+}
+
+=head2 getAllLanguages
+
+Returns a reference to an array of hashes:
+
+ my $alllanguages = getAllLanguages();
+ print "Available translated langauges:\n";
+ for my $language(@$alllanguages) {
+ print "$language->{language_code}\n";
+ print "$language->{language_name}\n";
+ print "$language->{language_locale_name}\n";
+ }
+
+=cut
+
+sub getAllLanguages {
+ my $languages_loop = [
+ {
+ language_code => "",
+ language_name => "No Limit",
+ language_locale_name => "",
+ selected => "selected",
+ },
+ {
+ language_code => "ara",
+ language_name =>
+ "العربية",
+ language_locale_name => "Arabic",
+ ,
+ },
+ {
+ language_code => "bul",
+ language_name =>
+ "Български",
+ language_locale_name => "Bulgarian",
+ ,
+ },
+ {
+ language_code => "chi",
+ language_name => "中文",
+ language_locale_name => "Chinese",
+ ,
+ },
+ {
+ language_code => "scr",
+ language_name => "Hrvatski",
+ language_locale_name => "Croatian",
+ ,
+ },
+ {
+ language_code => "cze",
+ language_name => "čeština",
+ language_locale_name => "Czech",
+ ,
+ },
+ {
+ language_code => "dan",
+ language_name => "Dænsk",
+ language_locale_name => "Danish",
+ ,
+ },
+ {
+ language_code => "dut",
+ language_name => "nedərlɑns",
+ language_locale_name => "Dutch",
+ ,
+ },
+ {
+ language_code => "en",
+ language_name => "English",
+ language_locale_name => "English",
+ ,
+ },
+ {
+ language_code => "fr",
+ language_name => "Français",
+ language_locale_name => "French",
+ ,
+ },
+ {
+ language_code => "ger",
+ language_name => "Deutsch",
+ language_locale_name => "German",
+ ,
+ },
+ {
+ language_code => "gre",
+ language_name =>
+ "ελληνικά",
+ language_locale_name => "Greek, Modern [1453- ]",
+ ,
+ },
+ {
+ language_code => "heb",
+ language_name => "עברית",
+ language_locale_name => "Hebrew",
+ ,
+ },
+ {
+ language_code => "hin",
+ language_name => "हिन्दी",
+ language_locale_name => "Hindi",
+ ,
+ },
+ {
+ language_code => "hun",
+ language_name => "Magyar",
+ language_locale_name => "Hungarian",
+ ,
+ },
+ {
+ language_code => "ind",
+ language_name => "",
+ language_locale_name => "Indonesian",
+ ,
+ },
+ {
+ language_code => "ita",
+ language_name => "Italiano",
+ language_locale_name => "Italian",
+ ,
+ },
+ {
+ language_code => "jpn",
+ language_name => "日本語",
+ language_locale_name => "Japanese",
+ ,
+ },
+ {
+ language_code => "kor",
+ language_name => "한국어",
+ language_locale_name => "Korean",
+ ,
+ },
+ {
+ language_code => "lat",
+ language_name => "Latina",
+ language_locale_name => "Latin",
+ ,
+ },
+ {
+ language_code => "nor",
+ language_name => "Norsk",
+ language_locale_name => "Norwegian",
+ ,
+ },
+ {
+ language_code => "per",
+ language_name => "فارسى",
+ language_locale_name => "Persian",
+ ,
+ },
+ {
+ language_code => "pol",
+ language_name => "Polski",
+ language_locale_name => "Polish",
+ ,
+ },
+ {
+ language_code => "por",
+ language_name => "Português",
+ language_locale_name => "Portuguese",
+ ,
+ },
+ {
+ language_code => "rum",
+ language_name => "Română",
+ language_locale_name => "Romanian",
+ ,
+ },
+ {
+ language_code => "rus",
+ language_name =>
+ "Русский",
+ language_locale_name => "Russian",
+ ,
+ },
+ {
+ language_code => "spa",
+ language_name => "Español",
+ language_locale_name => "Spanish",
+ ,
+ },
+ {
+ language_code => "swe",
+ language_name => "Svenska",
+ language_locale_name => "Swedish",
+ ,
+ },
+ {
+ language_code => "tha",
+ language_name =>
+ "ภาษาไทย",
+ language_locale_name => "Thai",
+ ,
+ },
+ {
+ language_code => "tur",
+ language_name => "Türkçe",
+ language_locale_name => "Turkish",
+ ,
+ },
+ {
+ language_code => "ukr",
+ language_name =>
+"Українська",
+ language_locale_name => "Ukrainian",
+ ,
+ },
+
+ ];
+ return $languages_loop;
+}
+
+=head2 _get_themes
+
+Internal function, returns an array of all available themes.
+
+ (@themes) = &_get_themes('opac');
+ (@themes) = &_get_themes('intranet');
+
+=cut
+
+sub _get_themes {
+ my $interface = shift;
+ my $htdocs;
+ my @themes;
+ if ( $interface eq 'intranet' ) {
+ $htdocs = C4::Context->config('intrahtdocs');
+ }
+ else {
+ $htdocs = C4::Context->config('opachtdocs');
+ }
+ opendir D, "$htdocs";
+ my @dirlist = readdir D;
+ foreach my $directory (@dirlist) {
+ # if there's an en dir, it's a valid theme
+ -d "$htdocs/$directory/en" and push @themes, $directory;
+ }
+ return @themes;
+}
+
+=head2 _get_language_dirs
+
+Internal function, returns an array of directory names, excluding non-language directories
+
+=cut
+
+sub _get_language_dirs {
+ my ($htdocs,$theme) = @_;
+ my @languages;
+ opendir D, "$htdocs/$theme";
+ for my $language ( readdir D ) {
+ next if $language =~/^\./;
+ next if $language eq 'all';
+ next if $language =~/png$/;
+ next if $language =~/css$/;
+ next if $language =~/CVS$/;
+ next if $language =~/itemtypeimg$/;
+ next if $language =~/\.txt$/i; #Don't read the readme.txt !
+ next if $language eq 'images';
+ push @languages, $language;
+ }
+ return (@languages);
+}
+
+=head2 _get_final_languages
+
+Internal function for building the ref to array of hashes
+
+FIXME: this could be rewritten and simplified using map
+
+=cut
+
+sub _get_final_languages {
+ my ($all_languages, at languages) = @_;
+ my @final_languages;
+ my %seen_languages;
+ for my $language (@languages) {
+ unless ($seen_languages{$language}) {
+ for my $language_code (@$all_languages) {
+ if ($language eq $language_code->{'language_code'}) {
+ push @final_languages, $language_code;
+ }
+ }
+ $seen_languages{$language}++;
+ }
+ }
+ return \@final_languages;
+}
+
+1;
+
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Joshua Ferraro
+
+=cut
Index: Maintainance.pm
===================================================================
RCS file: Maintainance.pm
diff -N Maintainance.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Maintainance.pm 9 Mar 2007 15:35:32 -0000 1.20
@@ -0,0 +1,213 @@
+package C4::Maintainance; #assumes C4/Maintainance
+
+#package to deal with marking up output
+
+
+# Copyright 2000-2002 Katipo Communications
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+use strict;
+use C4::Context;
+
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+=head1 NAME
+
+C4::Maintenance - Koha catalog maintenance functions
+
+=head1 SYNOPSIS
+
+ use C4::Maintenance;
+
+=head1 DESCRIPTION
+
+The functions in this module perform various catalog-maintenance
+functions, including deleting and undeleting books, fixing
+miscategorized items, etc.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&listsubjects &shiftgroup &deletedbib &undeletebib
+&updatetype &logaction);
+
+=item listsubjects
+
+ ($count, $results) = &listsubjects($subject, $n, $offset);
+
+Finds the subjects that begin with C<$subject> in the bibliosubject
+table of the Koha database.
+
+C<&listsubjects> returns a two-element array. C<$results> is a
+reference-to-array, in which each element is a reference-to-hash
+giving information about the given subject. C<$count> is the number of
+elements in C<@{$results}>.
+
+Probably the only interesting field in C<$results->[$i]> is
+C<subject>, the subject in question.
+
+C<&listsubject> returns up to C<$n> items, starting at C<$offset>. If
+C<$n> is 0, it will return all matching subjects.
+
+=cut
+#'
+# FIXME - This API is bogus. The way it's currently used, it should
+# just return a list of strings.
+sub listsubjects {
+ my ($sub,$num,$offset)=@_;
+ my $dbh = C4::Context->dbh;
+ my $query="Select * from bibliosubject where subject like ? group by subject";
+ my @bind = ("$sub%");
+ # FIXME - Make $num and $offset optional.
+ # If $num was given, make sure $offset was, too.
+ if ($num != 0){
+ $query.=" limit ?,?";
+ push(@bind,$offset,$num);
+ }
+ my $sth=$dbh->prepare($query);
+# print $query;
+ $sth->execute(@bind);
+ my @results;
+ my $i=0;
+ while (my $data=$sth->fetchrow_hashref){
+ $results[$i]=$data;
+ $i++;
+ }
+ $sth->finish;
+ return($i,\@results);
+}
+
+=item shiftgroup
+
+ &shiftgroup($biblionumber, $biblioitemnumber);
+
+Changes the biblionumber associated with a given biblioitem.
+C<$biblioitemnumber> is the number of the biblioitem to change.
+C<$biblionumber> is the biblionumber to associate it with.
+
+=cut
+#'
+sub shiftgroup{
+ my ($biblionumber,$bi)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("update biblioitems set biblionumber=? where biblioitemnumber=?");
+ $sth->execute($biblionumber,$bi);
+ $sth->finish;
+ $sth=$dbh->prepare("update items set biblionumber=? where biblioitemnumber=?");
+ $sth->execute($biblionumber,$bi);
+ $sth->finish;
+}
+
+=item deletedbib
+
+ ($count, $results) = &deletedbib($title);
+
+Looks up deleted books whose title begins with C<$title>.
+
+C<&deletedbib> returns a two-element list. C<$results> is a
+reference-to-array; each element is a reference-to-hash whose keys are
+the fields of the deletedbiblio table in the Koha database. C<$count>
+is the number of elements in C<$results>.
+
+=cut
+#'
+sub deletedbib{
+ my ($title)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("Select * from deletedbiblio where title like ? order by title");
+ $sth->execute("$title%");
+ my @results;
+ my $i=0;
+ while (my $data=$sth->fetchrow_hashref){
+ $results[$i]=$data;
+ $i++;
+ }
+ $sth->finish;
+ return($i,\@results);
+}
+
+=item undeletebib
+
+ &undeletebib($biblionumber);
+
+Undeletes a book. C<&undeletebib> looks up the book with the given
+biblionumber in the deletedbiblio table of the Koha database, and
+moves its entry to the biblio table.
+
+=cut
+#'
+sub undeletebib{
+ my ($biblionumber)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("select * from deletedbiblio where biblionumber=?");
+ $sth->execute($biblionumber);
+ if (my @data=$sth->fetchrow_array){
+ $sth->finish;
+ # FIXME - Doesn't this keep the same biblionumber? Isn't this
+ # forbidden by the definition of 'biblio'? Or doesn't it matter?
+ my $query="INSERT INTO biblio VALUES (";
+ my $count = @data;
+ $query .= ("?," x $count);
+ $query=~ s/\,$/\)/;
+ # print $query;
+ $sth=$dbh->prepare($query);
+ $sth->execute(@data);
+ $sth->finish;
+ }
+ $sth=$dbh->prepare("DELETE FROM deletedbiblio WHERE biblionumber=?");
+ $sth->execute($biblionumber);
+ $sth->finish;
+}
+
+=item updatetype
+
+ &updatetype($biblioitemnumber, $itemtype);
+
+Changes the type of the item with the given biblioitemnumber to be
+C<$itemtype>.
+
+=cut
+#'
+sub updatetype{
+ my ($bi,$type)=@_;
+ my $dbh = C4::Context->dbh;
+ my $sth=$dbh->prepare("Update biblioitems set itemtype=? where biblioitemnumber=?");
+ $sth->execute($type,$bi);
+ $sth->finish;
+}
+
+END { } # module clean-up code here (global destructor)
+
+1;
+__END__
+
+=back
+
+=head1 AUTHOR
+
+Koha Developement team <info at koha.org>
+
+=cut
Index: Record.pm
===================================================================
RCS file: Record.pm
diff -N Record.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Record.pm 9 Mar 2007 15:35:32 -0000 1.6
@@ -0,0 +1,573 @@
+package C4::Record;
+#
+# Copyright 2006 (C) LibLime
+# Joshua Ferraro <jmf at liblime.com>
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+#
+# $Id: Record.pm,v 1.6 2007/03/09 15:35:32 tipaul Exp $
+#
+use strict;# use warnings; #FIXME: turn off warnings before release
+
+# please specify in which methods a given module is used
+use MARC::Record; # marc2marcxml, marcxml2marc, html2marc, changeEncoding
+use MARC::File::XML; # marc2marcxml, marcxml2marc, html2marcxml, changeEncoding
+use MARC::Crosswalk::DublinCore; # marc2dcxml
+use Unicode::Normalize; # _entity_encode
+use XML::LibXSLT;
+use XML::LibXML;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = do { my @v = '$Revision: 1.6 $' =~ /\d+/g;
+ shift(@v) . "." . join("_", map {sprintf "%03d", $_ } @v); };
+
+ at ISA = qw(Exporter);
+
+# only export API methods
+
+ at EXPORT = qw(
+ &marc2marc
+ &marc2marcxml
+ &marcxml2marc
+ &marc2dcxml
+ &marc2modsxml
+
+ &html2marcxml
+ &html2marc
+ &changeEncoding
+);
+
+=head1 NAME
+
+C4::Record - MARC, MARCXML, DC, MODS, XML, etc. Record Management Functions and API
+
+=head1 SYNOPSIS
+
+New in Koha 3.x. This module handles all record-related management functions.
+
+=head1 API (EXPORTED FUNCTIONS)
+
+=head2 marc2marc - Convert from one flavour of ISO-2709 to another
+
+=over 4
+
+my ($error,$newmarc) = marc2marc($marc,$to_flavour,$from_flavour,$encoding);
+
+Returns an ISO-2709 scalar
+
+=back
+
+=cut
+
+sub marc2marc {
+ my ($marc,$to_flavour,$from_flavour,$encoding) = @_;
+ my $error = "Feature not yet implemented\n";
+ return ($error,$marc);
+}
+
+=head2 marc2marcxml - Convert from ISO-2709 to MARCXML
+
+=over 4
+
+my ($error,$marcxml) = marc2marcxml($marc,$encoding,$flavour);
+
+Returns a MARCXML scalar
+
+=over 2
+
+C<$marc> - an ISO-2709 scalar or MARC::Record object
+
+C<$encoding> - UTF-8 or MARC-8 [UTF-8]
+
+C<$flavour> - MARC21 or UNIMARC
+
+C<$dont_entity_encode> - a flag that instructs marc2marcxml not to entity encode the xml before returning (optional)
+
+=back
+
+=back
+
+=cut
+
+sub marc2marcxml {
+ my ($marc,$encoding,$flavour,$dont_entity_encode) = @_;
+ my $error; # the error string
+ my $marcxml; # the final MARCXML scalar
+
+ # test if it's already a MARC::Record object, if not, make it one
+ my $marc_record_obj;
+ if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
+ $marc_record_obj = $marc;
+ } else { # it's not a MARC::Record object, make it one
+ eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
+
+ # conversion to MARC::Record object failed, populate $error
+ if ($@) { $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR };
+ }
+ # only proceed if no errors so far
+ unless ($error) {
+
+ # check the record for warnings
+ my @warnings = $marc_record_obj->warnings();
+ if (@warnings) {
+ warn "\nWarnings encountered while processing ISO-2709 record with title \"".$marc_record_obj->title()."\":\n";
+ foreach my $warn (@warnings) { warn "\t".$warn };
+ }
+ unless($encoding) {$encoding = "UTF-8"}; # set default encoding
+ unless($flavour) {$flavour = C4::Context->preference("marcflavour")}; # set default MARC flavour
+
+ # attempt to convert the record to MARCXML
+ eval { $marcxml = $marc_record_obj->as_xml_record($flavour) }; #handle exceptions
+
+ # record creation failed, populate $error
+ if ($@) {
+ $error .= "Creation of MARCXML failed:".$MARC::File::ERROR;
+ $error .= "Additional information:\n";
+ my @warnings = $@->warnings();
+ foreach my $warn (@warnings) { $error.=$warn."\n" };
+
+ # record creation was successful
+ } else {
+
+ # check the record for warning flags again (warnings() will be cleared already if there was an error, see above block
+ @warnings = $marc_record_obj->warnings();
+ if (@warnings) {
+ warn "\nWarnings encountered while processing ISO-2709 record with title \"".$marc_record_obj->title()."\":\n";
+ foreach my $warn (@warnings) { warn "\t".$warn };
+ }
+ }
+
+ # only proceed if no errors so far
+ unless ($error) {
+
+ # entity encode the XML unless instructed not to
+ unless ($dont_entity_encode) {
+ my ($marcxml_entity_encoded) = _entity_encode($marcxml);
+ $marcxml = $marcxml_entity_encoded;
+ }
+ }
+ }
+ # return result to calling program
+ return ($error,$marcxml);
+}
+
+=head2 marcxml2marc - Convert from MARCXML to ISO-2709
+
+=over 4
+
+my ($error,$marc) = marcxml2marc($marcxml,$encoding,$flavour);
+
+Returns an ISO-2709 scalar
+
+=over 2
+
+C<$marcxml> - a MARCXML record
+
+C<$encoding> - UTF-8 or MARC-8 [UTF-8]
+
+C<$flavour> - MARC21 or UNIMARC
+
+=back
+
+=back
+
+=cut
+
+sub marcxml2marc {
+ my ($marcxml,$encoding,$flavour) = @_;
+ my $error; # the error string
+ my $marc; # the final ISO-2709 scalar
+ unless($encoding) {$encoding = "UTF-8"}; # set the default encoding
+ unless($flavour) {$flavour = C4::Context->preference("marcflavour")}; # set the default MARC flavour
+
+ # attempt to do the conversion
+ eval { $marc = MARC::Record->new_from_xml($marcxml,$encoding,$flavour) }; # handle exceptions
+
+ # record creation failed, populate $error
+ if ($@) {$error .="\nCreation of MARCXML Record failed: ".$@;
+ $error.=$MARC::File::ERROR if ($MARC::File::ERROR);
+ };
+ # return result to calling program
+ return ($error,$marc);
+}
+
+=head2 marc2dcxml - Convert from ISO-2709 to Dublin Core
+
+=over 4
+
+my ($error,$dcxml) = marc2dcxml($marc,$qualified);
+
+Returns a DublinCore::Record object, will eventually return a Dublin Core scalar
+
+FIXME: should return actual XML, not just an object
+
+=over 2
+
+C<$marc> - an ISO-2709 scalar or MARC::Record object
+
+C<$qualified> - specify whether qualified Dublin Core should be used in the input or output [0]
+
+=back
+
+=back
+
+=cut
+
+sub marc2dcxml {
+ my ($marc,$qualified) = @_;
+ my $error;
+ # test if it's already a MARC::Record object, if not, make it one
+ my $marc_record_obj;
+ if ($marc =~ /^MARC::Record/) { # it's already a MARC::Record object
+ $marc_record_obj = $marc;
+ } else { # it's not a MARC::Record object, make it one
+ eval { $marc_record_obj = MARC::Record->new_from_usmarc($marc) }; # handle exceptions
+
+ # conversion to MARC::Record object failed, populate $error
+ if ($@) {
+ $error .="\nCreation of MARC::Record object failed: ".$MARC::File::ERROR;
+ }
+ }
+ my $crosswalk = MARC::Crosswalk::DublinCore->new;
+ if ($qualified) {
+ $crosswalk = MARC::Crosswalk::DublinCore->new( qualified => 1 );
+ }
+ my $dcxml = $crosswalk->as_dublincore($marc_record_obj);
+ my $dcxmlfinal = "<?xml version=\"1.0\"?>\n";
+ $dcxmlfinal .= "<metadata
+ xmlns=\"http://example.org/myapp/\"
+ xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\"
+ xsi:schemaLocation=\"http://example.org/myapp/ http://example.org/myapp/schema.xsd\"
+ xmlns:dc=\"http://purl.org/dc/elements/1.1/\"
+ xmlns:dcterms=\"http://purl.org/dc/terms/\">";
+
+ foreach my $element ( $dcxml->elements() ) {
+ $dcxmlfinal.="<"."dc:".$element->name().">".$element->content()."</"."dc:".$element->name()."\n";
+ }
+ $dcxmlfinal .= "\n</metadata>";
+ return ($error,$dcxmlfinal);
+}
+=head2 marc2modsxml - Convert from ISO-2709 to MODS
+
+=over 4
+
+my ($error,$modsxml) = marc2modsxml($marc);
+
+Returns a MODS scalar
+
+=back
+
+=cut
+
+sub marc2modsxml {
+ my ($marc) = @_;
+ # grab the XML, run it through our stylesheet, push it out to the browser
+ my $xmlrecord = marc2marcxml($marc);
+ my $xslfile = C4::Context->config('intranetdir')."/misc/xslt/MARC21slim2MODS3-1.xsl";
+ my $parser = XML::LibXML->new();
+ my $xslt = XML::LibXSLT->new();
+ my $source = $parser->parse_string($xmlrecord);
+ my $style_doc = $parser->parse_file($xslfile);
+ my $stylesheet = $xslt->parse_stylesheet($style_doc);
+ my $results = $stylesheet->transform($source);
+ my $newxmlrecord = $stylesheet->output_string($results);
+ return ($newxmlrecord);
+}
+=head2 html2marcxml
+
+=over 4
+
+my ($error,$marcxml) = html2marcxml($tags,$subfields,$values,$indicator,$ind_tag);
+
+Returns a MARCXML scalar
+
+this is used in addbiblio.pl and additem.pl to build the MARCXML record from
+the form submission.
+
+FIXME: this could use some better code documentation
+
+=back
+
+=cut
+
+sub html2marcxml {
+ my ($tags,$subfields,$values,$indicator,$ind_tag) = @_;
+ my $error;
+ # add the header info
+ my $marcxml= MARC::File::XML::header(C4::Context->preference('TemplateEncoding'),C4::Context->preference('marcflavour'));
+
+ # some flags used to figure out where in the record we are
+ my $prevvalue;
+ my $prevtag=-1;
+ my $first=1;
+ my $j = -1;
+
+ # handle characters that would cause the parser to choke FIXME: is there a more elegant solution?
+ for (my $i=0;$i<=@$tags;$i++){
+ @$values[$i] =~ s/&/&/g;
+ @$values[$i] =~ s/</</g;
+ @$values[$i] =~ s/>/>/g;
+ @$values[$i] =~ s/"/"/g;
+ @$values[$i] =~ s/'/'/g;
+
+ if ((@$tags[$i] ne $prevtag)){
+ $j++ unless (@$tags[$i] eq "");
+ #warn "IND:".substr(@$indicator[$j],0,1).substr(@$indicator[$j],1,1)." ".@$tags[$i];
+ if (!$first){
+ $marcxml.="</datafield>\n";
+ if ((@$tags[$i] > 10) && (@$values[$i] ne "")){
+ my $ind1 = substr(@$indicator[$j],0,1);
+ my $ind2 = substr(@$indicator[$j],1,1);
+ $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ $first=0;
+ } else {
+ $first=1;
+ }
+ } else {
+ if (@$values[$i] ne "") {
+ # handle the leader
+ if (@$tags[$i] eq "000") {
+ $marcxml.="<leader>@$values[$i]</leader>\n";
+ $first=1;
+ # rest of the fixed fields
+ } elsif (@$tags[$i] < 010) { #FIXME: <10 was the way it was, there might even be a better way
+ $marcxml.="<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
+ $first=1;
+ } else {
+ my $ind1 = substr(@$indicator[$j],0,1);
+ my $ind2 = substr(@$indicator[$j],1,1);
+ $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ $first=0;
+ }
+ }
+ }
+ } else { # @$tags[$i] eq $prevtag
+ if (@$values[$i] eq "") {
+ } else {
+ if ($first){
+ my $ind1 = substr(@$indicator[$j],0,1);
+ my $ind2 = substr(@$indicator[$j],1,1);
+ $marcxml.="<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
+ $first=0;
+ }
+ $marcxml.="<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
+ }
+ }
+ $prevtag = @$tags[$i];
+ }
+ $marcxml.= MARC::File::XML::footer();
+ #warn $marcxml;
+ return ($error,$marcxml);
+}
+
+=head2 html2marc
+
+=over 4
+
+Probably best to avoid using this ... it has some rather striking problems:
+
+=over 2
+
+* saves blank subfields
+
+* subfield order is hardcoded to always start with 'a' for repeatable tags (because it is hardcoded in the addfield routine).
+
+* only possible to specify one set of indicators for each set of tags (ie, one for all the 650s). (because they were stored in a hash with the tag as the key).
+
+* the underlying routines didn't support subfield reordering or subfield repeatability.
+
+=back
+
+I've left it in here because it could be useful if someone took the time to fix it. -- kados
+
+=back
+
+=cut
+
+sub html2marc {
+ my ($dbh,$rtags,$rsubfields,$rvalues,%indicators) = @_;
+ my $prevtag = -1;
+ my $record = MARC::Record->new();
+# my %subfieldlist=();
+ my $prevvalue; # if tag <10
+ my $field; # if tag >=10
+ for (my $i=0; $i< @$rtags; $i++) {
+ # rebuild MARC::Record
+# warn "0=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ";
+ if (@$rtags[$i] ne $prevtag) {
+ if ($prevtag < 10) {
+ if ($prevvalue) {
+ if (($prevtag ne '000') && ($prevvalue ne "")) {
+ $record->add_fields((sprintf "%03s",$prevtag),$prevvalue);
+ } elsif ($prevvalue ne ""){
+ $record->leader($prevvalue);
+ }
+ }
+ } else {
+ if (($field) && ($field ne "")) {
+ $record->add_fields($field);
+ }
+ }
+ $indicators{@$rtags[$i]}.=' ';
+ # skip blank tags, I hope this works
+ if (@$rtags[$i] eq ''){
+ $prevtag = @$rtags[$i];
+ undef $field;
+ next;
+ }
+ if (@$rtags[$i] <10) {
+ $prevvalue= @$rvalues[$i];
+ undef $field;
+ } else {
+ undef $prevvalue;
+ if (@$rvalues[$i] eq "") {
+ undef $field;
+ } else {
+ $field = MARC::Field->new( (sprintf "%03s",@$rtags[$i]), substr($indicators{@$rtags[$i]},0,1),substr($indicators{@$rtags[$i]},1,1), @$rsubfields[$i] => @$rvalues[$i]);
+ }
+# warn "1=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ".$field->as_formatted;
+ }
+ $prevtag = @$rtags[$i];
+ } else {
+ if (@$rtags[$i] <10) {
+ $prevvalue=@$rvalues[$i];
+ } else {
+ if (length(@$rvalues[$i])>0) {
+ $field->add_subfields(@$rsubfields[$i] => @$rvalues[$i]);
+# warn "2=>".@$rtags[$i].@$rsubfields[$i]." = ".@$rvalues[$i].": ".$field->as_formatted;
+ }
+ }
+ $prevtag= @$rtags[$i];
+ }
+ }
+ #}
+ # the last has not been included inside the loop... do it now !
+ #use Data::Dumper;
+ #warn Dumper($field->{_subfields});
+ $record->add_fields($field) if (($field) && $field ne "");
+ #warn "HTML2MARC=".$record->as_formatted;
+ return $record;
+}
+
+=head2 changeEncoding - Change the encoding of a record
+
+=over 4
+
+my ($error, $newrecord) = changeEncoding($record,$format,$flavour,$to_encoding,$from_encoding);
+
+Changes the encoding of a record
+
+=over 2
+
+C<$record> - the record itself can be in ISO-2709, a MARC::Record object, or MARCXML for now (required)
+
+C<$format> - MARC or MARCXML (required)
+
+C<$flavour> - MARC21 or UNIMARC, if MARC21, it will change the leader (optional) [defaults to Koha system preference]
+
+C<$to_encoding> - the encoding you want the record to end up in (optional) [UTF-8]
+
+C<$from_encoding> - the encoding the record is currently in (optional, it will probably be able to tell unless there's a problem with the record)
+
+=back
+
+FIXME: the from_encoding doesn't work yet
+
+FIXME: better handling for UNIMARC, it should allow management of 100 field
+
+FIXME: shouldn't have to convert to and from xml/marc just to change encoding someone needs to re-write MARC::Record's 'encoding' method to actually alter the encoding rather than just changing the leader
+
+=back
+
+=cut
+
+sub changeEncoding {
+ my ($record,$format,$flavour,$to_encoding,$from_encoding) = @_;
+ my $newrecord;
+ my $error;
+ unless($flavour) {$flavour = C4::Context->preference("marcflavour")};
+ unless($to_encoding) {$to_encoding = "UTF-8"};
+
+ # ISO-2709 Record (MARC21 or UNIMARC)
+ if (lc($format) =~ /^marc$/o) {
+ # if we're converting encoding of an ISO2709 file, we need to roundtrip through XML
+ # because MARC::Record doesn't directly provide us with an encoding method
+ # It's definitely less than idea and should be fixed eventually - kados
+ my $marcxml; # temporary storage of MARCXML scalar
+ ($error,$marcxml) = marc2marcxml($record,$to_encoding,$flavour);
+ unless ($error) {
+ ($error,$newrecord) = marcxml2marc($marcxml,$to_encoding,$flavour);
+ }
+
+ # MARCXML Record
+ } elsif (lc($format) =~ /^marcxml$/o) { # MARCXML Record
+ my $marc;
+ ($error,$marc) = marcxml2marc($record,$to_encoding,$flavour);
+ unless ($error) {
+ ($error,$newrecord) = marc2marcxml($record,$to_encoding,$flavour);
+ }
+ } else {
+ $error.="Unsupported record format:".$format;
+ }
+ return ($error,$newrecord);
+}
+
+=head1 INTERNAL FUNCTIONS
+
+=head2 _entity_encode - Entity-encode an array of strings
+
+=over 4
+
+my ($entity_encoded_string) = _entity_encode($string);
+
+or
+
+my (@entity_encoded_strings) = _entity_encode(@strings);
+
+Entity-encode an array of strings
+
+=back
+
+=cut
+
+sub _entity_encode {
+ my @strings = @_;
+ my @strings_entity_encoded;
+ foreach my $string (@strings) {
+ my $nfc_string = NFC($string);
+ $nfc_string =~ s/([\x{0080}-\x{fffd}])/sprintf('&#x%X;',ord($1))/sgoe;
+ push @strings_entity_encoded, $nfc_string;
+ }
+ return @strings_entity_encoded;
+}
+
+END { } # module clean-up code here (global destructor)
+1;
+__END__
+
+=head1 AUTHOR
+
+Joshua Ferraro <jmf at liblime.com>
+
+=head1 MODIFICATIONS
+
+# $Id: Record.pm,v 1.6 2007/03/09 15:35:32 tipaul Exp $
+
+=cut
Index: Circulation/Date.pm
===================================================================
RCS file: Circulation/Date.pm
diff -N Circulation/Date.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Circulation/Date.pm 9 Mar 2007 15:35:32 -0000 1.4
@@ -0,0 +1,132 @@
+package C4::Circulation::Date;
+
+# Copyright 2005 Katipo Communications
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+# $id:$
+
+use strict;
+use C4::Context;
+
+require Exporter;
+
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
+
+$VERSION = do { my @v = '$Revision: 1.4 $' =~ /\d+/g;
+ shift(@v) . "." . join( "_", map { sprintf "%03d", $_ } @v );
+};
+
+ at ISA = qw(Exporter);
+
+ at EXPORT = qw(
+ &display_date_format
+ &format_date
+ &format_date_in_iso
+);
+
+=head1 DESCRIPTION
+
+C4::Circulation::Date provides routines for format dates to display in human readable forms.
+
+=head1 FUNCTIONS
+
+=over 2
+
+=cut
+
+=head2 get_date_format
+
+ $dateformat = get_date_format();
+
+Takes no input, and returns the format that the library prefers dates displayed in
+
+
+=cut
+
+sub get_date_format {
+
+ # Get the database handle
+ my $dbh = C4::Context->dbh;
+ return C4::Context->preference('dateformat');
+}
+
+=head2 display_date_format
+
+ $displaydateformat = display_date_format();
+
+Takes no input, and returns a string showing the format the library likes dates displayed in
+
+
+=cut
+
+sub display_date_format {
+ my $dateformat = get_date_format();
+
+ if ( $dateformat eq "us" ) {
+ return "mm/dd/yyyy";
+ }
+ elsif ( $dateformat eq "metric" ) {
+ return "dd/mm/yyyy";
+ }
+ elsif ( $dateformat eq "iso" ) {
+ return "yyyy-mm-dd";
+ }
+ else {
+ return
+"Invalid date format: $dateformat. Please change in system preferences";
+ }
+}
+
+=head2 format_date
+
+ $formatteddate = format_date($date);
+
+Takes a date, from mysql and returns it in the format specified by the library
+This is less flexible than C4::Date::format_date, which can handle dates of many formats
+if you need that flexibility use C4::Date, if you are just using it to format the output from mysql as
+in circulation.pl use this one, it is much faster.
+=cut
+
+
+sub format_date {
+ my $olddate = shift;
+ my $newdate;
+
+ if ( !$olddate ) {
+ return "";
+ }
+
+ my $dateformat = get_date_format();
+
+ if ( $dateformat eq "us" ) {
+ my @datearray=split('-',$olddate);
+ $newdate = "$datearray[1]/$datearray[2]/$datearray[0]";
+ }
+ elsif ( $dateformat eq "metric" ) {
+ my @datearray=split('-',$olddate);
+ $newdate = "$datearray[2]/$datearray[1]/$datearray[0]";
+ }
+ elsif ( $dateformat eq "iso" ) {
+ $newdate = $olddate;
+ }
+ else {
+ return
+"Invalid date format: $dateformat. Please change in system preferences";
+ }
+}
+
+1;
Index: Circulation/Returns.pm
===================================================================
RCS file: Circulation/Returns.pm
diff -N Circulation/Returns.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ Circulation/Returns.pm 9 Mar 2007 15:35:32 -0000 1.12
@@ -0,0 +1,335 @@
+package C4::Circulation::Returns;
+
+# $Id: Returns.pm,v 1.12 2007/03/09 15:35:32 tipaul Exp $
+
+#package to deal with Returns
+#written 3/11/99 by olwen at katipo.co.nz
+
+
+# Copyright 2000-2002 Katipo Communications
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+
+# FIXME - None of the functions (certainly none of the exported
+# functions) are used anywhere anymore. Presumably this module is
+# obsolete.
+
+use strict;
+require Exporter;
+use DBI;
+use C4::Context;
+use C4::Accounts2;
+use C4::InterfaceCDK;
+use C4::Circulation::Main;
+ # FIXME - C4::Circulation::Main and C4::Circulation::Returns
+ # use each other, so functions get redefined.
+use C4::Scan;
+use C4::Stats;
+use C4::Members;
+use C4::Print;
+use C4::Biblio;
+
+use vars qw($VERSION @ISA @EXPORT);
+
+# set the version for version checking
+$VERSION = 0.01;
+
+ at ISA = qw(Exporter);
+ at EXPORT = qw(&returnrecord &calc_odues &Returns);
+
+# FIXME - This is only used in C4::Circmain and C4::Circulation, both
+# of which appear to be obsolete. Presumably this function is obsolete
+# as well.
+# Otherwise, it needs a POD.
+sub Returns {
+ my ($env)=@_;
+ my $dbh = C4::Context->dbh;
+ my @items;
+ @items[0]=" "x50;
+ my $reason;
+ my $item;
+ my $reason;
+ my $borrower;
+ my $itemno;
+ my $itemrec;
+ my $borrowernumber;
+ my $amt_owing;
+ my $odues;
+ my $issues;
+ my $resp;
+# until (($reason eq "Circ") || ($reason eq "Quit")) {
+ until ($reason ne "") {
+ ($reason,$item) =
+ returnwindow($env,"Enter Returns",
+ $item,\@items,$borrower,$amt_owing,$odues,$dbh,$resp); #C4::Circulation
+ #debug_msg($env,"item = $item");
+ #if (($reason ne "Circ") && ($reason ne "Quit")) {
+ if ($reason eq "") {
+ $resp = "";
+ ($resp,$borrowernumber,$borrower,$itemno,$itemrec,$amt_owing) =
+ checkissue($env,$dbh,$item);
+ if ($borrowernumber ne "") {
+ ($issues,$odues,$amt_owing) = borrdata2($env,$borrowernumber);
+ } else {
+ $issues = "";
+ $odues = "";
+ $amt_owing = "";
+ }
+ if ($resp ne "") {
+ #if ($resp eq "Returned") {
+ if ($itemno ne "" ) {
+ my $item = GetBiblioFromItemNumber($itemno);
+ # FIXME - This relies on C4::Circulation::Main to have a
+ # "use C4::Circulation::Issues;" line, which is bogus.
+ my $fmtitem = C4::Circulation::Issues::formatitem($env,$item,"",$amt_owing);
+ unshift @items,$fmtitem;
+ if ($items[20] > "") {
+ pop @items;
+ }
+ }
+ #} elsif ($resp ne "") {
+ # error_msg($env,"$resp");
+ #}
+ #if ($resp ne "Returned") {
+ # error_msg($env,"$resp");
+ # $borrowernumber = "";
+ #}
+ }
+ }
+ }
+# clearscreen;
+ return($reason);
+ }
+
+# FIXME - Only used in &Returns and in telnet/doreturns.pl, both of
+# which appear obsolete. Presumably this function is obsolete as well.
+# Otherwise, it needs a POD.
+sub checkissue {
+ my ($env,$dbh, $item) = @_;
+ my $reason='Circ';
+ my $borrowernumber;
+ my $borrower;
+ my $itemno;
+ my $itemrec;
+ my $amt_owing;
+ $item = uc $item;
+ my $sth=$dbh->prepare("select * from items,biblio
+ where barcode = ?
+ and (biblio.biblionumber=items.biblionumber)");
+ $sth->execute($item);
+ if ($itemrec=$sth->fetchrow_hashref) {
+ $sth->finish;
+ $itemno = $itemrec->{'itemnumber'};
+ my $sth=$dbh->prepare("select * from issues
+ where (itemnumber=?)
+ and (returndate is null)");
+ $sth->execute($itemrec->{'itemnumber'});
+ if (my $issuerec=$sth->fetchrow_hashref) {
+ $sth->finish;
+ my $sth= $dbh->prepare("select * from borrowers where
+ (borrowernumber = ?)");
+ $sth->execute($issuerec->{'borrowernumber'});
+ $env->{'borrowernumber'}=$issuerec->{'borrowernumber'};
+ $borrower = $sth->fetchrow_hashref;
+ $borrowernumber = $issuerec->{'borrowernumber'};
+ $itemno = $issuerec->{'itemnumber'};
+ $amt_owing = returnrecord($env,$dbh,$borrowernumber,$itemno);
+ $reason = "Returned";
+ } else {
+ $sth->finish;
+ updatelastseen($env,$dbh,$itemrec->{'itemnumber'});
+ $reason = "Item not issued";
+ }
+ my ($resfound,$resrec) = find_reserves($env,$dbh,$itemrec->{'itemnumber'});
+ if ($resfound eq "y") {
+ my $btsh = $dbh->prepare("select * from borrowers
+ where borrowernumber = ?");
+ $btsh->execute($resrec->{'borrowernumber'});
+ my $resborrower = $btsh->fetchrow_hashref;
+ #printreserve($env,$resrec,$resborrower,$itemrec);
+ my $mess = "Reserved for collection at branch $resrec->{'branchcode'}";
+ C4::InterfaceCDK::error_msg($env,$mess);
+ $btsh->finish;
+ }
+ } else {
+ $sth->finish;
+ $reason = "Item not found";
+ }
+ return ($reason,$borrowernumber,$borrower,$itemno,$itemrec,$amt_owing);
+ # end checkissue
+ }
+
+# FIXME - Only used in &C4::Circulation::Main::previousissue,
+# &checkissue, C4/Circulation.pm, and tkperl/tkcirc, all of which
+# appear to be obsolete. Presumably this function is obsolete as well.
+# Otherwise, it needs a POD.
+sub returnrecord {
+ # mark items as returned
+ my ($env,$dbh,$borrowernumber,$itemno)=@_;
+ #my $amt_owing = calc_odues($env,$dbh,$borrowernumber,$itemno);
+ my @datearr = localtime(time);
+ my $dateret = (1900+$datearr[5])."-".$datearr[4]."-".$datearr[3];
+ my $sth = $dbh->prepare("update issues set returndate = now(), branchcode = ? where
+ (borrowernumber = ?) and (itemnumber = ?)
+ and (returndate is null)");
+ $sth->execute($env->{'branchcode'},$borrowernumber,$itemno);
+ $sth->finish;
+ updatelastseen($env,$dbh,$itemno);
+ # check for overdue fine
+ my $oduecharge;
+ my $sth = $dbh->prepare("select * from accountlines
+ where (borrowernumber = ?)
+ and (itemnumber = ?)
+ and (accounttype = 'FU' or accounttype='O')");
+ $sth->execute($borrowernumber,$itemno);
+ if (my $data = $sth->fetchrow_hashref) {
+ # alter fine to show that the book has been returned.
+ my $usth = $dbh->prepare("update accountlines
+ set accounttype = 'F'
+ where (borrowernumber = ?)
+ and (itemnumber = ?)
+ and (accountno = ?) ");
+ $usth->execute($borrowernumber,$itemno,$data->{'accountno'});
+ $usth->finish();
+ $oduecharge = $data->{'amountoutstanding'};
+ }
+ $sth->finish;
+ # check for charge made for lost book
+ my $sth = $dbh->prepare("select * from accountlines
+ where (borrowernumber = ?)
+ and (itemnumber = ?)
+ and (accounttype = 'L')");
+ $sth->execute($borrowernumber,$itemno);
+ if (my $data = $sth->fetchrow_hashref) {
+ # writeoff this amount
+ my $offset;
+ my $amount = $data->{'amount'};
+ my $acctno = $data->{'accountno'};
+ my $amountleft;
+ if ($data->{'amountoutstanding'} == $amount) {
+ $offset = $data->{'amount'};
+ $amountleft = 0;
+ } else {
+ $offset = $amount - $data->{'amountoutstanding'};
+ $amountleft = $data->{'amountoutstanding'} - $amount;
+ }
+ my $usth = $dbh->prepare("update accountlines
+ set accounttype = 'LR',amountoutstanding='0'
+ where (borrowernumber = ?)
+ and (itemnumber = ?)
+ and (accountno = ?) ");
+ $usth->execute($borrowernumber,$itemno,$acctno);
+ $usth->finish;
+ my $nextaccntno = C4::Accounts::getnextacctno($env,$borrowernumber,$dbh);
+ $usth = $dbh->prepare("insert into accountlines
+ (borrowernumber,accountno,date,amount,description,accounttype,amountoutstanding)
+ values (?,?,now(),?,'Book Returned','CR',?)");
+ $usth->execute($borrowernumber,$nextaccntno,0-$amount,$amountleft);
+ $usth->finish;
+ $uquery = "insert into accountoffsets
+ (borrowernumber, accountno, offsetaccount, offsetamount)
+ values (?,?,?,?)";
+ $usth = $dbh->prepare("");
+ $usth->execute($borrowernumber,$data->{'accountno'},$nextaccntno,$offset);
+ $usth->finish;
+ }
+ $sth->finish;
+ UpdateStats($env,'branch','return','0','',$itemno);
+ return($oduecharge);
+}
+
+# FIXME - Only used in tkperl/tkcirc. Presumably this function is
+# obsolete.
+# Otherwise, it needs a POD.
+sub calc_odues {
+ # calculate overdue fees
+ my ($env,$dbh,$borrowernumber,$itemno)=@_;
+ my $amt_owing;
+ return($amt_owing);
+}
+
+# This function is only used in &checkissue and &returnrecord, both of
+# which appear to be obsolete. So presumably this function is obsolete
+# too.
+# Otherwise, it needs a POD.
+sub updatelastseen {
+ my ($env,$dbh,$itemnumber)= @_;
+ my $br = $env->{'branchcode'};
+ my $sth = $dbh->prepare("update items
+ set datelastseen = now(), holdingbranch = ?
+ where (itemnumber = ?)");
+ $sth->execute($br,$itemnumber);
+ $sth->finish;
+
+}
+
+
+# FIXME - There's also a &C4::Circulation::Circ2::find_reserves, but
+# that one looks rather different.
+# FIXME - This is only used in &checkissue, which appears to be
+# obsolete. So presumably this function is obsolete too.
+sub find_reserves {
+ my ($env,$dbh,$itemno) = @_;
+ warn "!!!!! SHOULD NOT BE HERE : Returns::find_reserves is deprecated !!!";
+ my $itemdata = GetBiblioFromItemNumber($itemno);
+ my $sth = $dbh->prepare("select * from reserves where found is null
+ and biblionumber = ? and cancellationdate is NULL
+ order by priority,reservedate ");
+ $sth->execute($itemdata->{'biblionumber'};
+ my $resfound = "n";
+ my $resrec;
+ while (($resrec=$sth->fetchrow_hashref) && ($resfound eq "n")) {
+ if ($resrec->{'found'} eq "W") {
+ if ($resrec->{'itemnumber'} eq $itemno) {
+ $resfound = "y";
+ }
+ } elsif ($resrec->{'constrainttype'} eq "a") {
+ $resfound = "y";
+ } else {
+ my $consth = $dbh->prepare("select * from reserveconstraints where borrowernumber = ? and reservedate = ? and biblionumber = ? and biblioitemnumber = ?");
+ $consth->execute($resrec->{'borrowernumber'},$resrec->{'reservedate'},$resrec->{'biblionumber'},$itemdata->{'biblioitemnumber'});
+ if (my $conrec=$consth->fetchrow_hashref) {
+ if ($resrec->{'constrainttype'} eq "o") {
+ $resfound = "y";
+ }
+ } else {
+ if ($resrec->{'constrainttype'} eq "e") {
+ $resfound = "y";
+ }
+ }
+ $consth->finish;
+ }
+ if ($resfound eq "y") {
+ my $updsth = $dbh->prepare("update reserves
+ set found = 'W',itemnumber = ?
+ where borrowernumber = ?
+ and reservedate = ?
+ and biblionumber = ?");
+ $updsth->execute($itemno,$resrec->{'borrowernumber'},$resrec->{'reservedate'},$resrec->{'biblionumber'});
+ $updsth->finish;
+ my $itbr = $resrec->{'branchcode'};
+ if ($resrec->{'branchcode'} ne $env->{'branchcode'}) {
+ my $updsth = $dbh->prepare("update items
+ set holdingbranch = 'TR'
+ where itemnumber = ?");
+ $updsth->execute($itemno);
+ $updsth->finish;
+ }
+ }
+ }
+ $sth->finish;
+ return ($resfound,$resrec);
+}
Index: tests/Record_test.pl
===================================================================
RCS file: tests/Record_test.pl
diff -N tests/Record_test.pl
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/Record_test.pl 9 Mar 2007 15:35:32 -0000 1.4
@@ -0,0 +1,142 @@
+#!/usr/bin/perl
+#
+# Copyright 2006 (C) LibLime
+# Joshua Ferraro <jmf at liblime.com>
+#
+# This file is part of Koha.
+#
+# Koha is free software; you can redistribute it and/or modify it under the
+# terms of the GNU General Public License as published by the Free Software
+# Foundation; either version 2 of the License, or (at your option) any later
+# version.
+#
+# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
+# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
+# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License along with
+# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
+# Suite 330, Boston, MA 02111-1307 USA
+#
+# $Id: Record_test.pl,v 1.4 2007/03/09 15:35:32 tipaul Exp $
+#
+use strict; use warnings; #FIXME: turn off warnings before release
+
+# specify the number of tests
+use Test::More tests => 23;
+#use C4::Context;
+use C4::Record;
+
+=head1 NAME
+
+Record_test.pl - test suite for Record.pm
+
+=head1 SYNOPSIS
+
+$ export KOHA_CONF=/path/to/koha.conf
+$ ./Record_test.pl
+
+=cut
+
+## FIXME: Preliminarily grab the modules dir so we can run this in context
+
+ok (1, 'module compiled');
+
+# open some files for testing
+open MARC21MARC8,"testrecords/marc21_marc8.dat" or die $!;
+my $marc21_marc8; # = scalar (MARC21MARC8);
+foreach my $line (<MARC21MARC8>) {
+ $marc21_marc8 .= $line;
+}
+$marc21_marc8 =~ s/\n$//;
+close MARC21MARC8;
+
+open (MARC21UTF8,"<:utf8","testrecords/marc21_utf8.dat") or die $!;
+my $marc21_utf8;
+foreach my $line (<MARC21UTF8>) {
+ $marc21_utf8 .= $line;
+}
+$marc21_utf8 =~ s/\n$//;
+close MARC21UTF8;
+
+open MARC21MARC8COMBCHARS,"testrecords/marc21_marc8_combining_chars.dat" or die $!;
+my $marc21_marc8_combining_chars;
+foreach my $line(<MARC21MARC8COMBCHARS>) {
+ $marc21_marc8_combining_chars.=$line;
+}
+$marc21_marc8_combining_chars =~ s/\n$//; #FIXME: why is a newline ending up here?
+close MARC21MARC8COMBCHARS;
+
+open (MARC21UTF8COMBCHARS,"<:utf8","testrecords/marc21_utf8_combining_chars.dat") or die $!;
+my $marc21_utf8_combining_chars;
+foreach my $line(<MARC21UTF8COMBCHARS>) {
+ $marc21_utf8_combining_chars.=$line;
+}
+close MARC21UTF8COMBCHARS;
+
+open (MARCXMLUTF8,"<:utf8","testrecords/marcxml_utf8.xml") or die $!;
+my $marcxml_utf8;
+foreach my $line (<MARCXMLUTF8>) {
+ $marcxml_utf8 .= $line;
+}
+close MARCXMLUTF8;
+
+$marcxml_utf8 =~ s/\n//g;
+
+## The Tests:
+my $error; my $marc; my $marcxml; my $dcxml; # some scalars to store values
+## MARC to MARCXML
+print "\n1. Checking conversion of simple ISO-2709 (MARC21) records to MARCXML\n";
+ok (($error,$marcxml) = marc2marcxml($marc21_marc8,'UTF-8','MARC21'), 'marc2marcxml - from MARC-8 to UTF-8 (MARC21)');
+ok (!$error, 'no errors in conversion');
+ $marcxml =~ s/\n//g;
+ $marcxml =~ s/v\/ s/v\/s/g; # FIXME: bug in new_from_xml_record!!
+is ($marcxml,$marcxml_utf8, 'record matches antitype');
+
+ok (($error,$marcxml) = marc2marcxml($marc21_utf8,'UTF-8','MARC21'), 'marc2marcxml - from UTF-8 to UTF-8 (MARC21)');
+ok (!$error, 'no errors in conversion');
+ $marcxml =~ s/\n//g;
+ $marcxml =~ s/v\/ s/v\/s/g;
+is ($marcxml,$marcxml_utf8, 'record matches antitype');
+
+print "\n2. checking binary MARC21 records with combining characters to MARCXML\n";
+ok (($error,$marcxml) = marc2marcxml($marc21_marc8_combining_chars,'MARC-8','MARC21'), 'marc2marcxml - from MARC-8 to MARC-8 with combining characters(MARC21)');
+ok (!$error, 'no errors in conversion');
+
+ok (($error,$marcxml) = marc2marcxml($marc21_marc8_combining_chars,'UTF-8','MARC21'), 'marc2marcxml - from MARC-8 to UTF-8 with combining characters (MARC21)');
+ok (!$error, 'no errors in conversion');
+
+ok (($error,$marcxml) = marc2marcxml($marc21_utf8_combining_chars,'UTF-8','MARC21'), 'marc2marcxml - from UTF-8 to UTF-8 with combining characters (MARC21)');
+ok (!$error, 'no errors in conversion');
+
+ok (($error,$dcxml) = marc2dcxml($marc21_utf8), 'marc2dcxml - from ISO-2709 to Dublin Core');
+ok (!$error, 'no errors in conversion');
+
+print "\n3. checking ability to alter encoding\n";
+ok (($error,$marc) = changeEncoding($marc21_marc8,'MARC','MARC21','UTF-8'), 'changeEncoding - MARC21 from MARC-8 to UTF-8');
+ok (!$error, 'no errors in conversion');
+
+ok (($error,$marc) = changeEncoding($marc21_utf8,'MARC','MARC21','MARC-8'), 'changeEncoding - MARC21 from UTF-8 to MARC-8');
+ok (!$error, 'no errors in conversion');
+
+ok (($error,$marc) = changeEncoding($marc21_marc8,'MARC','MARC21','MARC-8'), 'changeEncoding - MARC21 from MARC-8 to MARC-8');
+ok (!$error, 'no errors in conversion');
+
+ok (($error,$marc) = changeEncoding($marc21_utf8,'MARC','MARC21','UTF-8'), 'changeEncoding - MARC21 from UTF-8 to UTF-8');
+ok (!$error, 'no errors in conversion');
+
+__END__
+
+=head1 TODO
+
+Still lots more to test including UNIMARC support
+
+=head1 AUTHOR
+
+Joshua Ferraro <jmf at liblime.com>
+
+=head1 MODIFICATIONS
+
+# $Id: Record_test.pl,v 1.4 2007/03/09 15:35:32 tipaul Exp $
+
+=cut
Index: tests/testrecords/marc21_marc8_combining_chars.dat
===================================================================
RCS file: tests/testrecords/marc21_marc8_combining_chars.dat
diff -N tests/testrecords/marc21_marc8_combining_chars.dat
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/testrecords/marc21_marc8_combining_chars.dat 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1 @@
+01442cam 2200373 a 4500001001300000003000600013005001700019008004100036010001700077040002500094016001900119020004200138029002100180050002800201082002300229084001500252092001700267049000800284245015300292260007900445300002800524440015300552500003000705500002200735650005600757650007000813650005700883650002500940650002100965650002500986700003001011942001501041994001201056 ocm11030895 OCoLC 20060516100102.0 840720s1984 ne b 001 0 eng a 83048926 aDLC cDLC dMUQ dNLGGC aB8443186 2bccb a0800606035 (Fortress Press) : c$35.95 1 aNLGGC b840375166 00 aBM485 b.L57 1984 vol. 2 00 a296.1 s a296.1 219 a11.37 2bcl 0 a296.1 bST66 aWN3 00 aJewish writings of the Second Temple period : bApocrypha, Pseudepigrapha, Qumran, sectarian writings, Philo, Josephus / cedited by Michael E. Stone. aAssen, Netherlands : bVan Gorcum ; aPhiladelphia : bFortress Press, c1984. axxiii, 697 p. ; c25 cm. 0 aCompendia rerum Iudaicarum ad Novum Testamentum. nSection 2, pLiterature of the Jewish people in the period of the Second Temple and the Talmud ; v2 aBibliography: p. 603-653. aIncludes indexes. 0 aJewish religious literature xHistory and criticism. 0 aJudaism xHistory yPost-exilic period, 586 B.C.-210 A.D. xSources. 6 aLittâerature religieuse juive xHistoire et critique. 17 aOude Testament. 2gtt 17 aApocriefen. 2gtt 17 aDode-Zeerollen. 2gtt 1 aStone, Michael E., d1938- k296.1 ST66 aC0 bWN3
Index: tests/testrecords/marc21_marc8.dat
===================================================================
RCS file: tests/testrecords/marc21_marc8.dat
diff -N tests/testrecords/marc21_marc8.dat
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/testrecords/marc21_marc8.dat 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1 @@
+00463 2200169 4500001000600000003000500006005001700011008004100028020001500069090001500084100003400099245005100133250002500184650002200209942002500231952003700256 84893 ACLS 19990324000000.0 930421s19xx xxu 00010 eng d a0854562702 c1738 d1738 1 aChristie, Agatha, d1890-1976. 10 aWhy didn't they ask Evans? / cAgatha Christie. aLarge print edition. 0 aLarge type books. aONe cLP kLP Christie bNPL p31000000010273 r12.00 u2148
Index: tests/testrecords/marc21_marc8_errors.dat
===================================================================
RCS file: tests/testrecords/marc21_marc8_errors.dat
diff -N tests/testrecords/marc21_marc8_errors.dat
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/testrecords/marc21_marc8_errors.dat 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1 @@
+00462 2200169 4500001000600000003000500006005001700011008004100028020001500069090001500084100003400099245005100133250002500184650002200209942002500231952003700256 84893 ACLS 19990324000000.0 930421s19xx xxu 00010 eng d a0854562702 c1738 d1738 1 aChristie, Agatha, d1890-1976. 10 aWhy didn't they ask Evans? / cAgatha Christie. aLarge print edition. 0 aLarge type books. aONe cLP kLP Christie bNPL p31000000010273 r12.00 u2148
Index: tests/testrecords/marc21_utf8_combining_chars.dat
===================================================================
RCS file: tests/testrecords/marc21_utf8_combining_chars.dat
diff -N tests/testrecords/marc21_utf8_combining_chars.dat
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/testrecords/marc21_utf8_combining_chars.dat 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1 @@
+01442cam a2200373 a 4500001001300000003000600013005001700019008004100036010001700077040002500094016001900119020004200138029002100180050002800201082002300229084001500252092001700267049000800284245015300292260007900445300002800524440015300552500003000705500002200735650005600757650007000813650005700883650002500940650002100965650002500986700003001011942001501041994001201056 ocm11030895 OCoLC 20060516100102.0 840720s1984 ne b 001 0 eng a 83048926 aDLC cDLC dMUQ dNLGGC aB8443186 2bccb a0800606035 (Fortress Press) : c$35.95 1 aNLGGC b840375166 00 aBM485 b.L57 1984 vol. 2 00 a296.1 s a296.1 219 a11.37 2bcl 0 a296.1 bST66 aWN3 00 aJewish writings of the Second Temple period : bApocrypha, Pseudepigrapha, Qumran, sectarian writings, Philo, Josephus / cedited by Michael E. Stone. aAssen, Netherlands : bVan Gorcum ; aPhiladelphia : bFortress Press, c1984. axxiii, 697 p. ; c25 cm. 0 aCompendia rerum Iudaicarum ad Novum Testamentum. nSection 2, pLiterature of the Jewish people in the period of the Second Temple and the Talmud ; v2 aBibliography: p. 603-653. aIncludes indexes. 0 aJewish religious literature xHistory and criticism. 0 aJudaism xHistory yPost-exilic period, 586 B.C.-210 A.D. xSources. 6 aLittérature religieuse juive xHistoire et critique. 17 aOude Testament. 2gtt 17 aApocriefen. 2gtt 17 aDode-Zeerollen. 2gtt 1 aStone, Michael E., d1938- k296.1 ST66 aC0 bWN3
\ No newline at end of file
Index: tests/testrecords/marc21_utf8.dat
===================================================================
RCS file: tests/testrecords/marc21_utf8.dat
diff -N tests/testrecords/marc21_utf8.dat
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/testrecords/marc21_utf8.dat 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1 @@
+00463 a2200169 4500001000600000003000500006005001700011008004100028020001500069090001500084100003400099245005100133250002500184650002200209942002500231952003700256 84893 ACLS 19990324000000.0 930421s19xx xxu 00010 eng d a0854562702 c1738 d1738 1 aChristie, Agatha, d1890-1976. 10 aWhy didn't they ask Evans? / cAgatha Christie. aLarge print edition. 0 aLarge type books. aONe cLP kLP Christie bNPL p31000000010273 r12.00 u2148
\ No newline at end of file
Index: tests/testrecords/marcxml_utf8_entityencoded.xml
===================================================================
RCS file: tests/testrecords/marcxml_utf8_entityencoded.xml
diff -N tests/testrecords/marcxml_utf8_entityencoded.xml
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/testrecords/marcxml_utf8_entityencoded.xml 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1,46 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<collection
+ xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+ xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
+ xmlns="http://www.loc.gov/MARC21/slim">
+
+<record>
+ <leader>00463 a2200169 4500</leader>
+ <controlfield tag="001">84893</controlfield>
+ <controlfield tag="003">ACLS</controlfield>
+ <controlfield tag="005">19990324000000.0</controlfield>
+ <controlfield tag="008">930421s19xx xxu 00010 eng d</controlfield>
+ <datafield tag="020" ind1=" " ind2=" ">
+ <subfield code="a">0854562702</subfield>
+ </datafield>
+ <datafield tag="090" ind1=" " ind2=" ">
+ <subfield code="c">1738</subfield>
+ <subfield code="d">1738</subfield>
+ </datafield>
+ <datafield tag="100" ind1="1" ind2=" ">
+ <subfield code="a">Christie, Agatha,</subfield>
+ <subfield code="d">1890-1976.</subfield>
+ </datafield>
+ <datafield tag="245" ind1="1" ind2="0">
+ <subfield code="a">Why didn't they ask Evans? /</subfield>
+ <subfield code="c">Agatha Christie.</subfield>
+ </datafield>
+ <datafield tag="250" ind1=" " ind2=" ">
+ <subfield code="a">Large print edition.</subfield>
+ </datafield>
+ <datafield tag="650" ind1=" " ind2="0">
+ <subfield code="a">Large type books.</subfield>
+ </datafield>
+ <datafield tag="942" ind1=" " ind2=" ">
+ <subfield code="a">ONe</subfield>
+ <subfield code="c">LP</subfield>
+ <subfield code="k">LP Christie</subfield>
+ </datafield>
+ <datafield tag="952" ind1=" " ind2=" ">
+ <subfield code="b">NPL</subfield>
+ <subfield code="p">31000000010273</subfield>
+ <subfield code="r">12.00</subfield>
+ <subfield code="u">2148</subfield>
+ </datafield>
+</record>
+</collection>
Index: tests/testrecords/marcxml_utf8.xml
===================================================================
RCS file: tests/testrecords/marcxml_utf8.xml
diff -N tests/testrecords/marcxml_utf8.xml
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ tests/testrecords/marcxml_utf8.xml 9 Mar 2007 15:35:32 -0000 1.3
@@ -0,0 +1,44 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<record
+ xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance"
+ xsi:schemaLocation="http://www.loc.gov/MARC21/slim http://www.loc.gov/standards/marcxml/schema/MARC21slim.xsd"
+ xmlns="http://www.loc.gov/MARC21/slim">
+
+ <leader>00463 a2200169 4500</leader>
+ <controlfield tag="001">84893</controlfield>
+ <controlfield tag="003">ACLS</controlfield>
+ <controlfield tag="005">19990324000000.0</controlfield>
+ <controlfield tag="008">930421s19xx xxu 00010 eng d</controlfield>
+ <datafield tag="020" ind1=" " ind2=" ">
+ <subfield code="a">0854562702</subfield>
+ </datafield>
+ <datafield tag="090" ind1=" " ind2=" ">
+ <subfield code="c">1738</subfield>
+ <subfield code="d">1738</subfield>
+ </datafield>
+ <datafield tag="100" ind1="1" ind2=" ">
+ <subfield code="a">Christie, Agatha,</subfield>
+ <subfield code="d">1890-1976.</subfield>
+ </datafield>
+ <datafield tag="245" ind1="1" ind2="0">
+ <subfield code="a">Why didn't they ask Evans? /</subfield>
+ <subfield code="c">Agatha Christie.</subfield>
+ </datafield>
+ <datafield tag="250" ind1=" " ind2=" ">
+ <subfield code="a">Large print edition.</subfield>
+ </datafield>
+ <datafield tag="650" ind1=" " ind2="0">
+ <subfield code="a">Large type books.</subfield>
+ </datafield>
+ <datafield tag="942" ind1=" " ind2=" ">
+ <subfield code="a">ONe</subfield>
+ <subfield code="c">LP</subfield>
+ <subfield code="k">LP Christie</subfield>
+ </datafield>
+ <datafield tag="952" ind1=" " ind2=" ">
+ <subfield code="b">NPL</subfield>
+ <subfield code="p">31000000010273</subfield>
+ <subfield code="r">12.00</subfield>
+ <subfield code="u">2148</subfield>
+ </datafield>
+</record>
More information about the Koha-cvs
mailing list