File Coverage

File:	C4/Patroncards/Lib.pm
Coverage:	17.6%

line	stmt	bran	sub	time	code
1					package C4::Patroncards::Lib;
2
3					# Copyright 2009 Foundations Bible College.
4					#
5					# This file is part of Koha.
6					#
7					# Koha is free software; you can redistribute it and/or modify it under the
8					# terms of the GNU General Public License as published by the Free Software
9					# Foundation; either version 2 of the License, or (at your option) any later
10					# version.
11					#
12					# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13					# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14					# A PARTICULAR PURPOSE. See the GNU General Public License for more details.
15					#
16					# You should have received a copy of the GNU General Public License along
17					# with Koha; if not, write to the Free Software Foundation, Inc.,
18					# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20	5 5 5		5	22863 39 209	use strict;
21	5 5 5		5	65 50 239	use warnings;
22
23	5 5 5		5	276 1703 67	use autouse 'Data::Dumper' => qw(Dumper);
24
25	5 5 5		5	762 21 71	use C4::Context;
26	5 5 5		5	46 29 639	use C4::Debug;
27
28					BEGIN {
29	5 5 5 5		5 5	420 3253 68 65	use version; our $VERSION = qv('1.0.0_1');
30	5 5 5		5	443 13 586	use base qw(Exporter);
31	5			6207	our @EXPORT = qw(unpack_UTF8
32					text_alignment
33					leading
34					box
35					get_borrower_attributes
36					put_image
37					get_image
38					rm_image
39					);
40					}
41
42					sub unpack_UTF8 {
43	0		0		my ($str) = @_;
44	0				my @UTF8 = (unpack("U0U*", $str));
45	0 0				my @HEX = map { sprintf '%2.2x', $_ } @UTF8;
46	0				return \@HEX;
47					}
48
49					sub text_alignment {
50	0		0		my ($origin_llx, $text_box_width, $text_llx, $string_width, $line, $alignment) = @_;
51	0				my $Tw = 0;
52	0				my $Tx = 0;
53	0	0 0 0 0			if ($alignment eq 'J') {
54	0				my $UTF82HEX = unpack_UTF8($line);
55	0				my $space_count = 0;
56	0 0	0			grep {$space_count++ if $_ eq '20'} @$UTF82HEX;
57	0				$Tw = (($text_box_width - $text_llx) - $string_width) / $space_count;
58	0				return $origin_llx, $Tw;
59					}
60					elsif ($alignment eq 'C') {
61	0				my $center_margin = ($text_box_width / 2) + ($origin_llx - $text_llx);
62	0				$Tx = $center_margin - ($string_width / 2);
63	0				return $Tx, $Tw;
64					}
65					elsif ($alignment eq 'R') {
66	0				$Tx = ($text_box_width - $string_width) + (($origin_llx - $text_llx) / 2);
67	0				return $Tx, $Tw;
68					}
69					elsif ($alignment eq 'L') {
70	0				return $origin_llx, $Tw;
71					}
72					else { # if we are not handed an alignment default to left align text...
73	0				return $origin_llx, $Tw;
74					}
75					}
76
77					sub leading {
78	0		0		return $_[0] + ($_[0] * 0.20); # recommended starting point for leading is 20% of the font point size (See http://www.bastoky.com/KeyRelations.htm)
79					}
80
81					sub box {
82	0		0		my ($llx, $lly, $width, $height, $pdf) = @_;
83	0				my $obj_stream = "q\n"; # save the graphic state
84	0				$obj_stream .= "0.5 w\n"; # border line width
85	0				$obj_stream .= "1.0 0.0 0.0 RG\n"; # border color red
86	0				$obj_stream .= "1.0 1.0 1.0 rg\n"; # fill color white
87	0				$obj_stream .= "$llx $lly $width $height re\n"; # a rectangle
88	0				$obj_stream .= "B\n"; # fill (and a little more)
89	0				$obj_stream .= "Q\n"; # restore the graphic state
90	0				$pdf->Add($obj_stream);
91					}
92
93					sub get_borrower_attributes {
94	0		0		my ($borrower_number, @fields) = @_;
95	0				my $get_branch = 0;
96	0 0	0			$get_branch = 1 if grep{$_ eq 'branchcode'} @fields;
97	0				my $attrib_count = scalar(@fields);
98	0				my $query = "SELECT ";
99	0				while (scalar(@fields)) {
100	0				$query .= shift(@fields);
101	0	0			$query .= ', ' if scalar(@fields);
102					}
103	0				$query .= " FROM borrowers WHERE borrowernumber = ?";
104	0				my $sth = C4::Context->dbh->prepare($query);
105					# $sth->{'TraceLevel'} = 3;
106	0				$sth->execute($borrower_number);
107	0	0			if ($sth->err) {
108	0				warn sprintf('Database returned the following error: %s', $sth->errstr);
109	0				return 1;
110					}
111	0				my $borrower_attributes = $sth->fetchrow_hashref();
112	0	0			if ($get_branch) {
113	0				$query = "SELECT branchname FROM branches WHERE branchcode = ?";
114	0				$sth = C4::Context->dbh->prepare($query);
115	0				$sth->execute($borrower_attributes->{'branchcode'});
116	0	0			if ($sth->err) {
117	0				warn sprintf('Database returned the following error: %s', $sth->errstr);
118	0				return 1;
119					}
120	0				$borrower_attributes->{'branchcode'} = $sth->fetchrow_hashref()->{'branchname'};
121					}
122	0				return $borrower_attributes;
123					}
124
125					sub put_image {
126	0		0		my ($image_name, $image_file) = @_;
127	0	0			if (my $image_limit = C4::Context->preference('ImageLimit')) { # enforce quota if set
128	0				my $query = "SELECT count(*) FROM creator_images;";
129	0				my $sth = C4::Context->dbh->prepare($query);
130	0				$sth->execute();
131	0	0			if ($sth->err) {
132	0				warn sprintf('Database returned the following error: %s', $sth->errstr);
133	0				return 1;
134					}
135	0	0			return 202 if $sth->fetchrow_array >= $image_limit;
136					}
137	0				my$query = "INSERT INTO creator_images (imagefile, image_name) VALUES (?,?) ON DUPLICATE KEY UPDATE imagefile = ?;";
138	0				my $sth = C4::Context->dbh->prepare($query);
139	0				$sth->execute($image_file, $image_name, $image_file);
140	0	0			if ($sth->err) {
141	0				warn sprintf('Database returned the following error: %s', $sth->errstr);
142	0				return 1;
143					}
144	0				return;
145					}
146
147					sub get_image {
148	0		0		my ($image_name, $fields) = @_;
149	0	0			$fields = '*' unless $fields;
150	0				my $query = "SELECT $fields FROM creator_images";
151	0	0			$query .= " WHERE image_name = ?" if $image_name;
152	0				my $sth = C4::Context->dbh->prepare($query);
153	0	0			if ($image_name) {
154	0				$sth->execute($image_name);
155					}
156					else {
157	0				$sth->execute();
158					}
159	0	0			if ($sth->err) {
160	0				warn sprintf('Database returned the following error: %s', $sth->errstr);
161	0				return 1;
162					}
163	0				return $sth->fetchall_arrayref({});
164					}
165
166					sub rm_image {
167	0		0		my $image_ids = shift;
168	0				my $errstr = ();
169	0				foreach my $image_id (@$image_ids) {
170	0				my $query = "DELETE FROM creator_images WHERE image_id = ?";
171	0				my $sth = C4::Context->dbh->prepare($query);
172	0				$sth->execute($image_id);
173	0	0			if ($sth->err) {
174	0				warn sprintf('Database returned the following error: %s', $sth->errstr);
175	0				push (@$errstr, $image_id);
176					}
177					}
178	0	0			if ($errstr) {
179	0				return $errstr;
180					}
181					else {
182	0				return;
183					}
184					}
185
186					1;