C4/Labels.pm

   1 package C4::Labels;
   2
   3 # Copyright 2006 Katipo Communications.
   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 with
  17 # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
  18 # Suite 330, Boston, MA  02111-1307 USA
  19
  20 use strict;
  21 use vars qw($VERSION @ISA @EXPORT);
  22
  23 use PDF::Reuse;
  24 use Text::Wrap;
  25 use Algorithm::CheckDigits;
  26 # use Data::Dumper;
  27 # use Smart::Comments;
  28
  29 BEGIN {
  30         $VERSION = 0.03;
  31         require Exporter;
  32         @ISA    = qw(Exporter);
  33         @EXPORT = qw(
  34                 &get_label_options &get_label_items
  35                 &build_circ_barcode &draw_boundaries
  36                 &drawbox &GetActiveLabelTemplate
  37                 &GetAllLabelTemplates &DeleteTemplate
  38                 &GetSingleLabelTemplate &SaveTemplate
  39                 &CreateTemplate &SetActiveTemplate
  40                 &SaveConf &DrawSpineText &GetTextWrapCols
  41                 &GetUnitsValue &DrawBarcode
  42                 &get_printingtypes
  43                 &get_layouts
  44                 &get_barcode_types
  45                 &get_batches &delete_batch
  46                 &add_batch &printText
  47                 &GetItemFields
  48                 &get_text_fields
  49                 get_layout &save_layout &add_layout
  50                 &set_active_layout &by_order
  51                 &build_text_dropbox
  52                 &delete_layout &get_active_layout
  53                 &get_highest_batch
  54                 &deduplicate_batch
  55                 &GetAllPrinterProfiles &GetSinglePrinterProfile
  56                 &SaveProfile &CreateProfile &DeleteProfile
  57                 &GetAssociatedProfile &SetAssociatedProfile
  58         );
  59 }
  60
  61 my $DEBUG = 0;
  62
  63 =head1 NAME
  64
  65 C4::Labels - Functions for printing spine labels and barcodes in Koha
  66
  67 =head1 FUNCTIONS
  68
  69 =over 2
  70
  71 =item get_label_options;
  72
  73         $options = get_label_options()
  74
  75 Return a pointer on a hash list containing info from labels_conf table in Koha DB.
  76
  77 =cut
  78
  79 #'
  80 sub get_label_options {
  81     my $dbh    = C4::Context->dbh;
  82     my $query2 = " SELECT * FROM labels_conf where active = 1";
  83     my $sth    = $dbh->prepare($query2);
  84     $sth->execute();
  85     my $conf_data = $sth->fetchrow_hashref;
  86     $sth->finish;
  87     return $conf_data;
  88 }
  89
  90 sub get_layouts {
  91
  92 ## FIXME: this if/else could be compacted...
  93     my $dbh = C4::Context->dbh;
  94     my @data;
  95     my $query = " Select * from labels_conf";
  96     my $sth   = $dbh->prepare($query);
  97     $sth->execute();
  98     my @resultsloop;
  99     while ( my $data = $sth->fetchrow_hashref ) {
 100
 101         $data->{'fieldlist'} = get_text_fields( $data->{'id'} );
 102         push( @resultsloop, $data );
 103     }
 104     $sth->finish;
 105
 106     # @resultsloop
 107
 108     return @resultsloop;
 109 }
 110
 111 sub get_layout {
 112     my ($layout_id) = @_;
 113     my $dbh = C4::Context->dbh;
 114
 115     # get the actual items to be printed.
 116     my $query = " Select * from labels_conf where id = ?";
 117     my $sth   = $dbh->prepare($query);
 118     $sth->execute($layout_id);
 119     my $data = $sth->fetchrow_hashref;
 120     $sth->finish;
 121     return $data;
 122 }
 123
 124 sub get_active_layout {
 125     my ($layout_id) = @_;
 126     my $dbh = C4::Context->dbh;
 127
 128     # get the actual items to be printed.
 129     my $query = " Select * from labels_conf where active = 1";
 130     my $sth   = $dbh->prepare($query);
 131     $sth->execute();
 132     my $data = $sth->fetchrow_hashref;
 133     $sth->finish;
 134     return $data;
 135 }
 136
 137 sub delete_layout {
 138     my ($layout_id) = @_;
 139     my $dbh = C4::Context->dbh;
 140
 141     # get the actual items to be printed.
 142     my $query = "delete from  labels_conf where id = ?";
 143     my $sth   = $dbh->prepare($query);
 144     $sth->execute($layout_id);
 145     $sth->finish;
 146 }
 147
 148 sub get_printingtypes {
 149     my ($layout_id) = @_;
 150     my @printtypes;
 151
 152     push( @printtypes, { code => 'BAR',    desc => "barcode" } );
 153     push( @printtypes, { code => 'BIB',    desc => "biblio" } );
 154     push( @printtypes, { code => 'BARBIB', desc => "barcode / biblio" } );
 155     push( @printtypes, { code => 'BIBBAR', desc => "biblio / barcode" } );
 156     push( @printtypes, { code => 'ALT',    desc => "alternating labels" } );
 157
 158     my $conf             = get_layout($layout_id);
 159     my $active_printtype = $conf->{'printingtype'};
 160
 161     # lop thru layout, insert selected to hash
 162
 163     foreach my $printtype (@printtypes) {
 164         if ( $printtype->{'code'} eq $active_printtype ) {
 165             $printtype->{'active'} = 'MOO';
 166         }
 167     }
 168     return @printtypes;
 169 }
 170
 171 sub build_text_dropbox {
 172     my ($order) = @_;
 173
 174     #  my @fields      = get_text_fields();
 175     #    my $field_count = scalar @fields;
 176     my $field_count = 10;    # <-----------       FIXME hard coded
 177
 178     my @lines;
 179     !$order
 180       ? push( @lines, { num => '', selected => '1' } )
 181       : push( @lines, { num => '' } );
 182     for ( my $i = 1 ; $i <= $field_count ; $i++ ) {
 183         my $line = { num => "$i" };
 184         $line->{'selected'} = 1 if $i eq $order;
 185         push( @lines, $line );
 186     }
 187
 188     # add a blank row too
 189
 190     return @lines;
 191 }
 192
 193 sub get_text_fields {
 194     my ($layout_id, $sorttype) = @_;
 195
 196     my ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 197
 198     my $sortorder = get_layout($layout_id);
 199
 200     # $sortorder
 201
 202     $a = {
 203         code  => 'itemtype',
 204         desc  => "Item Type",
 205         order => $sortorder->{'itemtype'}
 206     };
 207     $b = {
 208         code  => 'dewey',
 209         desc  => "Dewey",
 210         order => $sortorder->{'dewey'}
 211     };
 212     $c = { code => 'issn', desc => "ISSN",
 213         order => $sortorder->{'issn'} };
 214     $d = { code => 'isbn', desc => "ISBN",
 215             order => $sortorder->{'isbn'} };
 216     $e = {
 217         code  => 'class',
 218         desc  => "Classification",
 219         order => $sortorder->{'class'}
 220     };
 221     $f = {
 222         code  => 'subclass',
 223         desc  => "Sub-Class",
 224         order => $sortorder->{'subclass'}
 225     };
 226     $g = {
 227         code  => 'barcode',
 228         desc  => "Barcode",
 229         order => $sortorder->{'barcode'}
 230     };
 231     $h =
 232       { code => 'author', desc => "Author", order => $sortorder->{'author'} };
 233     $i = { code => 'title', desc => "Title", order => $sortorder->{'title'} };
 234     $j = { code => 'itemcallnumber', desc => "Call Number", order => $sortorder->{'itemcallnumber'} };
 235         $k = { code => 'subtitle', desc => "Subtitle", order => $sortorder->{'subtitle'} };
 236
 237         my @text_fields = ( $a, $b, $c, $d, $e, $f, $g, $h, $i ,$j, $k );
 238
 239     my @new_fields;
 240     foreach my $field (@text_fields) {
 241         push( @new_fields, $field ) if $field->{'order'} > 0;
 242     }
 243
 244     my @sorted_fields = sort by_order @new_fields;
 245     my $active_fields;
 246     foreach my $field (@sorted_fields) {
 247      $sorttype eq 'codes' ?   $active_fields .= "$field->{'code'} " :
 248           $active_fields .= "$field->{'desc'} ";
 249     }
 250     return $active_fields;
 251
 252 }
 253
 254 sub by_order {
 255     $$a{order} <=> $$b{order};
 256 }
 257
 258 sub add_batch {
 259     my $new_batch;
 260     my $dbh = C4::Context->dbh;
 261     my $q =
 262       "select distinct batch_id from labels order by batch_id desc limit 1";
 263     my $sth = $dbh->prepare($q);
 264     $sth->execute();
 265     my $data = $sth->fetchrow_hashref;
 266     $sth->finish;
 267
 268     if ( !$data->{'batch_id'} ) {
 269         $new_batch = 1;
 270     }
 271     else {
 272         $new_batch = ( $data->{'batch_id'} + 1 );
 273     }
 274
 275     return $new_batch;
 276 }
 277
 278
 279 sub get_highest_batch {
 280     my $new_batch;
 281     my $dbh = C4::Context->dbh;
 282     my $q =
 283       "select distinct batch_id from labels order by batch_id desc limit 1";
 284     my $sth = $dbh->prepare($q);
 285     $sth->execute();
 286     my $data = $sth->fetchrow_hashref;
 287     $sth->finish;
 288
 289     if ( !$data->{'batch_id'} ) {
 290         $new_batch = 1;
 291     }
 292     else {
 293         $new_batch =  $data->{'batch_id'};
 294     }
 295
 296     return $new_batch;
 297 }
 298
 299
 300 sub get_batches {
 301     my $dbh = C4::Context->dbh;
 302     my $q   = "select batch_id, count(*) as num from labels group by batch_id";
 303     my $sth = $dbh->prepare($q);
 304     $sth->execute();
 305     my @resultsloop;
 306     while ( my $data = $sth->fetchrow_hashref ) {
 307         push( @resultsloop, $data );
 308     }
 309     $sth->finish;
 310
 311 # Not sure why we are doing this rather than simply telling the user that no batches are currently defined.
 312 # So I'm commenting this out and modifying label-manager.tmpl to properly inform the user as stated. -fbcit
 313     # adding a dummy batch=1 value , if none exists in the db
 314 #    if ( !scalar(@resultsloop) ) {
 315 #        push( @resultsloop, { batch_id => '1' , num => '0' } );
 316 #    }
 317     return @resultsloop;
 318 }
 319
 320 sub delete_batch {
 321     my ($batch_id) = @_;
 322     my $dbh        = C4::Context->dbh;
 323     my $q          = "DELETE FROM labels where batch_id  = ?";
 324     my $sth        = $dbh->prepare($q);
 325     $sth->execute($batch_id);
 326     $sth->finish;
 327 }
 328
 329 sub get_barcode_types {
 330     my ($layout_id) = @_;
 331     my $layout      = get_layout($layout_id);
 332     my $barcode     = $layout->{'barcodetype'};
 333     my @array;
 334
 335     push( @array, { code => 'CODE39',      desc => 'Code 39' } );
 336     push( @array, { code => 'CODE39MOD',   desc => 'Code39 + Modulo43' } );
 337     push( @array, { code => 'CODE39MOD10', desc => 'Code39 + Modulo10' } );
 338     push( @array, { code => 'ITF',         desc => 'Interleaved 2 of 5' } );
 339
 340     foreach my $line (@array) {
 341         if ( $line->{'code'} eq $barcode ) {
 342             $line->{'active'} = 1;
 343         }
 344
 345     }
 346     return @array;
 347 }
 348
 349 sub GetUnitsValue {
 350     my ($units) = @_;
 351     my $unitvalue;
 352
 353     $unitvalue = '1'          if ( $units eq 'POINT' );
 354     $unitvalue = '2.83464567' if ( $units eq 'MM' );
 355     $unitvalue = '28.3464567' if ( $units eq 'CM' );
 356     $unitvalue = 72           if ( $units eq 'INCH' );
 357     return $unitvalue;
 358 }
 359
 360 sub GetTextWrapCols {
 361     my ( $font, $fontsize, $label_width, $left_text_margin ) = @_;
 362     my $string = '0';
 363     my $strwidth;
 364     my $count = 0;
 365 #    my $textlimit = $label_width - ($left_text_margin);
 366     my $textlimit = $label_width - ( 2* $left_text_margin);
 367
 368     while ( $strwidth < $textlimit ) {
 369         $strwidth = prStrWidth( $string, $font, $fontsize );
 370         $string = $string . '0';
 371         #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
 372         $count++;
 373     }
 374     return $count;
 375 }
 376
 377 sub GetActiveLabelTemplate {
 378     my $dbh   = C4::Context->dbh;
 379     my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
 380     my $sth   = $dbh->prepare($query);
 381     $sth->execute();
 382     my $active_tmpl = $sth->fetchrow_hashref;
 383     $sth->finish;
 384     return $active_tmpl;
 385 }
 386
 387 sub GetSingleLabelTemplate {
 388     my ($tmpl_id) = @_;
 389     my $dbh       = C4::Context->dbh;
 390     my $query     = " SELECT * FROM labels_templates where tmpl_id = ?";
 391     my $sth       = $dbh->prepare($query);
 392     $sth->execute($tmpl_id);
 393     my $template = $sth->fetchrow_hashref;
 394     $sth->finish;
 395     return $template;
 396 }
 397
 398 sub SetActiveTemplate {
 399
 400     my ($tmpl_id) = @_;
 401
 402     my $dbh   = C4::Context->dbh;
 403     my $query = " UPDATE labels_templates SET active = NULL";
 404     my $sth   = $dbh->prepare($query);
 405     $sth->execute();
 406
 407     $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
 408     $sth   = $dbh->prepare($query);
 409     $sth->execute($tmpl_id);
 410     $sth->finish;
 411 }
 412
 413 sub set_active_layout {
 414
 415     my ($layout_id) = @_;
 416     my $dbh         = C4::Context->dbh;
 417     my $query       = " UPDATE labels_conf SET active = NULL";
 418     my $sth         = $dbh->prepare($query);
 419     $sth->execute();
 420
 421     $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
 422     $sth   = $dbh->prepare($query);
 423     $sth->execute($layout_id);
 424     $sth->finish;
 425 }
 426
 427 sub DeleteTemplate {
 428     my ($tmpl_id) = @_;
 429     my $dbh       = C4::Context->dbh;
 430     my $query     = " DELETE  FROM labels_templates where tmpl_id = ?";
 431     my $sth       = $dbh->prepare($query);
 432     $sth->execute($tmpl_id);
 433     $sth->finish;
 434 }
 435
 436 sub SaveTemplate {
 437     my (
 438         $tmpl_id,     $tmpl_code,   $tmpl_desc,    $page_width,
 439         $page_height, $label_width, $label_height, $topmargin,
 440         $leftmargin,  $cols,        $rows,         $colgap,
 441         $rowgap,      $font,        $fontsize,     $units
 442     ) = @_;
 443     warn "Passed \$font:$font";
 444     my $dbh = C4::Context->dbh;
 445     my $query =
 446       " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
 447                page_height=?, label_width=?, label_height=?, topmargin=?,
 448                leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
 449                            units=?
 450                   WHERE tmpl_id = ?";
 451
 452     my $sth = $dbh->prepare($query);
 453     $sth->execute(
 454         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 455         $label_width, $label_height, $topmargin,  $leftmargin,
 456         $cols,        $rows,         $colgap,     $rowgap,
 457         $font,        $fontsize,     $units,      $tmpl_id
 458     );
 459     my $dberror = $sth->errstr;
 460     $sth->finish;
 461     return $dberror;
 462 }
 463
 464 sub CreateTemplate {
 465     my $tmpl_id;
 466     my (
 467         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 468         $label_width, $label_height, $topmargin,  $leftmargin,
 469         $cols,        $rows,         $colgap,     $rowgap,
 470         $font,        $fontsize,     $units
 471     ) = @_;
 472
 473     my $dbh = C4::Context->dbh;
 474
 475     my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
 476                          page_height, label_width, label_height, topmargin,
 477                          leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
 478                          VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
 479
 480     my $sth = $dbh->prepare($query);
 481     $sth->execute(
 482         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 483         $label_width, $label_height, $topmargin,  $leftmargin,
 484         $cols,        $rows,         $colgap,     $rowgap,
 485         $font,        $fontsize,    $units
 486     );
 487     my $dberror = $sth->errstr;
 488     $sth->finish;
 489     return $dberror;
 490 }
 491
 492 sub GetAllLabelTemplates {
 493     my $dbh = C4::Context->dbh;
 494
 495     # get the actual items to be printed.
 496     my @data;
 497     my $query = " Select * from labels_templates ";
 498     my $sth   = $dbh->prepare($query);
 499     $sth->execute();
 500     my @resultsloop;
 501     while ( my $data = $sth->fetchrow_hashref ) {
 502         push( @resultsloop, $data );
 503     }
 504     $sth->finish;
 505
 506     #warn Dumper @resultsloop;
 507     return @resultsloop;
 508 }
 509
 510 #sub SaveConf {
 511 sub add_layout {
 512
 513     my (
 514         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 515         $itemtype,     $bcn,            $dcn,        $classif,
 516         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 517         $printingtype, $guidebox,       $startlabel, $layoutname
 518     ) = @_;
 519
 520     my $dbh    = C4::Context->dbh;
 521     my $query2 = "update labels_conf set active = NULL";
 522     my $sth2   = $dbh->prepare($query2);
 523     $sth2->execute();
 524     $query2 = "INSERT INTO labels_conf
 525             ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
 526               dewey, class, subclass, itemcallnumber, author, printingtype,
 527                 guidebox, startlabel, layoutname, active )
 528                values ( ?, ?, ?, ?, ?, ?, ?,  ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
 529     $sth2 = $dbh->prepare($query2);
 530     $sth2->execute(
 531         $barcodetype, $title, $subtitle, $isbn, $issn,
 532
 533         $itemtype, $bcn,            $dcn,    $classif,
 534         $subclass, $itemcallnumber, $author, $printingtype,
 535         $guidebox, $startlabel,     $layoutname
 536     );
 537     $sth2->finish;
 538
 539     SetActiveTemplate($tmpl_id);
 540     return;
 541 }
 542
 543 sub save_layout {
 544
 545     my (
 546         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 547         $itemtype,     $bcn,            $dcn,        $classif,
 548         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 549         $printingtype, $guidebox,       $startlabel, $layoutname,
 550         $layout_id
 551     ) = @_;
 552 ### $layoutname
 553 ### $layout_id
 554
 555     my $dbh    = C4::Context->dbh;
 556     my $query2 = "update labels_conf set
 557              barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
 558             itemtype=?, barcode=?,    dewey=?, class=?,
 559              subclass=?, itemcallnumber=?, author=?,  printingtype=?,
 560                guidebox=?, startlabel=?, layoutname=? where id = ?";
 561     my $sth2 = $dbh->prepare($query2);
 562     $sth2->execute(
 563         $barcodetype, $title,          $subtitle,       $isbn,       $issn,
 564         $itemtype,    $bcn,            $dcn,        $classif,
 565         $subclass,    $itemcallnumber, $author,     $printingtype,
 566         $guidebox,    $startlabel,     $layoutname, $layout_id
 567     );
 568     $sth2->finish;
 569
 570     return;
 571 }
 572
 573 =item GetAllPrinterProfiles;
 574
 575     @profiles = GetAllPrinterProfiles()
 576
 577 Returns an array of references-to-hash, whos keys are .....
 578
 579 =cut
 580
 581 sub GetAllPrinterProfiles {
 582
 583     my $dbh = C4::Context->dbh;
 584     my @data;
 585     my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
 586     my $sth = $dbh->prepare($query);
 587     $sth->execute();
 588     my @resultsloop;
 589     while ( my $data = $sth->fetchrow_hashref ) {
 590         push( @resultsloop, $data );
 591     }
 592     $sth->finish;
 593
 594     return @resultsloop;
 595 }
 596
 597 =item GetSinglePrinterProfile;
 598
 599     $profile = GetSinglePrinterProfile()
 600
 601 Returns a hashref whos keys are...
 602
 603 =cut
 604
 605 sub GetSinglePrinterProfile {
 606     my ($prof_id) = @_;
 607     my $dbh       = C4::Context->dbh;
 608     my $query     = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
 609     my $sth       = $dbh->prepare($query);
 610     $sth->execute($prof_id);
 611     my $template = $sth->fetchrow_hashref;
 612     $sth->finish;
 613     return $template;
 614 }
 615
 616 =item SaveProfile;
 617
 618     SaveProfile('parameters')
 619
 620 When passed a set of parameters, this function updates the given profile with the new parameters.
 621
 622 =cut
 623
 624 sub SaveProfile {
 625     my (
 626         $prof_id,       $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units
 627     ) = @_;
 628     my $dbh = C4::Context->dbh;
 629     my $query =
 630       " UPDATE printers_profile
 631         SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
 632         WHERE prof_id = ? ";
 633     my $sth = $dbh->prepare($query);
 634     $sth->execute(
 635         $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units,         $prof_id
 636     );
 637     $sth->finish;
 638 }
 639
 640 =item CreateProfile;
 641
 642     CreateProfile('parameters')
 643
 644 When passed a set of parameters, this function creates a new profile containing those parameters
 645 and returns any errors.
 646
 647 =cut
 648
 649 sub CreateProfile {
 650     my (
 651         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 652         $offset_vert,   $creep_horz,    $creep_vert,    $units
 653     ) = @_;
 654     my $dbh = C4::Context->dbh;
 655     my $query =
 656         " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
 657                                         offset_horz, offset_vert, creep_horz, creep_vert, unit)
 658           VALUES(?,?,?,?,?,?,?,?,?) ";
 659     my $sth = $dbh->prepare($query);
 660     $sth->execute(
 661         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 662         $offset_vert,   $creep_horz,    $creep_vert,    $units
 663     );
 664     my $error =  $sth->errstr;
 665     $sth->finish;
 666     return $error;
 667 }
 668
 669 =item DeleteProfile;
 670
 671     DeleteProfile(prof_id)
 672
 673 When passed a profile id, this function deletes that profile from the database and returns any errors.
 674
 675 =cut
 676
 677 sub DeleteProfile {
 678     my ($prof_id) = @_;
 679     my $dbh       = C4::Context->dbh;
 680     my $query     = " DELETE FROM printers_profile WHERE prof_id = ?";
 681     my $sth       = $dbh->prepare($query);
 682     $sth->execute($prof_id);
 683     my $error = $sth->errstr;
 684     $sth->finish;
 685     return $error;
 686 }
 687
 688 =item GetAssociatedProfile;
 689
 690     $assoc_prof = GetAssociatedProfile(tmpl_id)
 691
 692 When passed a template id, this function returns the parameters from the currently associated printer profile
 693 in a hashref where key=fieldname and value=fieldvalue.
 694
 695 =cut
 696
 697 sub GetAssociatedProfile {
 698     my ($tmpl_id) = @_;
 699     my $dbh   = C4::Context->dbh;
 700     # First we find out the prof_id for the associated profile...
 701     my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
 702     my $sth   = $dbh->prepare($query);
 703     $sth->execute($tmpl_id);
 704     my $assoc_prof = $sth->fetchrow_hashref;
 705     $sth->finish;
 706     # Then we retrieve that profile and return it to the caller...
 707     $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
 708     return $assoc_prof;
 709 }
 710
 711 =item SetAssociatedProfile;
 712
 713     SetAssociatedProfile($prof_id, $tmpl_id)
 714
 715 When passed both a profile id and template id, this function establishes an association between the two. No more
 716 than one profile may be associated with any given template at the same time.
 717
 718 =cut
 719
 720 sub SetAssociatedProfile {
 721
 722     my ($prof_id, $tmpl_id) = @_;
 723
 724     my $dbh = C4::Context->dbh;
 725     my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
 726     my $sth = $dbh->prepare($query);
 727     $sth->execute($prof_id, $tmpl_id, $prof_id);
 728     $sth->finish;
 729 }
 730
 731 =item get_label_items;
 732
 733         $options = get_label_items()
 734
 735 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
 736
 737 =cut
 738
 739 #'
 740 sub get_label_items {
 741     my ($batch_id) = @_;
 742     my $dbh = C4::Context->dbh;
 743
 744     my @resultsloop = ();
 745     my $count;
 746     my @data;
 747     my $sth;
 748
 749     if ($batch_id) {
 750         my $query3 = "Select * from labels where batch_id = ? order by labelid ";
 751         $sth = $dbh->prepare($query3);
 752         $sth->execute($batch_id);
 753
 754     }
 755     else {
 756
 757         my $query3 = "Select * from labels";
 758         $sth = $dbh->prepare($query3);
 759         $sth->execute();
 760     }
 761     my $cnt = $sth->rows;
 762     my $i1  = 1;
 763     while ( my $data = $sth->fetchrow_hashref ) {
 764
 765         # lets get some summary info from each item
 766         my $query1 = "
 767          select i.*, bi.*, b.*  from items i,biblioitems bi,biblio b
 768                 where itemnumber=? and  i.biblioitemnumber=bi.biblioitemnumber and
 769                 bi.biblionumber=b.biblionumber";
 770
 771                 my $sth1 = $dbh->prepare($query1);
 772         $sth1->execute( $data->{'itemnumber'} );
 773
 774         my $data1 = $sth1->fetchrow_hashref();
 775         $data1->{'labelno'}  = $i1;
 776         $data1->{'labelid'}  = $data->{'labelid'};
 777         $data1->{'batch_id'} = $batch_id;
 778         $data1->{'summary'} =
 779           "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
 780
 781         push( @resultsloop, $data1 );
 782         $sth1->finish;
 783
 784         $i1++;
 785     }
 786     $sth->finish;
 787     return @resultsloop;
 788
 789 }
 790
 791 sub GetItemFields {
 792     my @fields = qw (
 793       barcode title subtitle
 794       dewey isbn issn author class
 795       itemtype subclass itemcallnumber
 796
 797     );
 798     return @fields;
 799 }
 800
 801 sub deduplicate_batch {
 802         my $batch_id = shift or return undef;
 803         my $query = "
 804         SELECT DISTINCT
 805                         batch_id,itemnumber,
 806                         count(labelid) as count
 807         FROM     labels
 808         WHERE    batch_id = ?
 809         GROUP BY itemnumber,batch_id
 810         HAVING   count > 1
 811         ORDER BY batch_id,
 812                          count DESC  ";
 813         my $sth = C4::Context->dbh->prepare($query);
 814         $sth->execute($batch_id);
 815         $sth->rows or return undef;
 816
 817         my $del_query = qq(
 818         DELETE
 819         FROM     labels
 820         WHERE    batch_id = ?
 821         AND      itemnumber = ?
 822         ORDER BY timestamp ASC
 823         );
 824         my $killed = 0;
 825         while (my $data = $sth->fetchrow_hashref()) {
 826                 my $itemnumber = $data->{itemnumber} or next;
 827                 my $limit      = $data->{count} - 1  or next;
 828                 my $sth2 = C4::Context->dbh->prepare("$del_query  LIMIT $limit");
 829                 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
 830                 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
 831                 $sth2->execute($batch_id, $itemnumber) and
 832                         $killed += ($data->{count} - 1);
 833         }
 834         return $killed;
 835 }
 836
 837 sub DrawSpineText {
 838
 839     my ( $x_pos, $y_pos, $label_height, $label_width, $fontname, $fontsize, $left_text_margin,
 840         $text_wrap_cols, $item, $conf_data, $printingtype )
 841       = @_;
 842 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
 843         $$item->{'class'} = $$item->{'classification'};
 844
 845     $Text::Wrap::columns   = $text_wrap_cols;
 846     $Text::Wrap::separator = "\n";
 847
 848     my $str;
 849
 850     my $top_text_margin = ( $fontsize + 3 );    #FIXME: This should be a template parameter and passed in...
 851     my $line_spacer = ( $fontsize * 0.20 );    # number of pixels between text rows (This is actually leading: baseline to baseline minus font size. Recommended starting point is 20% of font size.).
 852
 853     # add your printable fields manually in here
 854
 855     my $layout_id = $$conf_data->{'id'};
 856
 857 #    my @fields = GetItemFields();
 858
 859     my $str_fields = get_text_fields($layout_id, 'codes' );
 860     my @fields = split(/ /, $str_fields);
 861     #warn Dumper(@fields);
 862
 863     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
 864     my $font = prFont($fontname);
 865
 866     # warn Dumper $conf_data;
 867     #warn Dumper $item;
 868
 869     foreach my $field (@fields) {
 870
 871         # testing hack
 872 #     $$item->{"$field"} = $field . ": " . $$item->{"$field"};
 873
 874         # if the display option for this field is selected in the DB,
 875         # and the item record has some values for this field, display it.
 876         if ( $$conf_data->{"$field"} && $$item->{"$field"} ) {
 877
 878             #            warn "CONF_TYPE = $field";
 879
 880             # get the string
 881             $str = $$item->{"$field"};
 882             # strip out naughty existing nl/cr's
 883             $str =~ s/\n//g;
 884             $str =~ s/\r//g;
 885             # strip out division slashes
 886             $str =~ s/\///g;
 887             # chop the string up into _upto_ 12 chunks
 888             # and seperate the chunks with newlines
 889
 890             $str = wrap( "", "", "$str" );
 891             $str = wrap( "", "", "$str" );
 892
 893             # split the chunks between newline's, into an array
 894             my @strings = split /\n/, $str;
 895
 896             # then loop for each string line
 897             foreach my $str (@strings) {
 898                 my $hPos;
 899                 if ( $printingtype eq 'BIB' ) { #FIXME: This is a hack and needs to be implimented as a text justification option in the template...
 900                     # some code to try and center each line on the label based on font size and string point width...
 901                     my $stringwidth = prStrWidth($str, $fontname, $fontsize);
 902                     my $whitespace = ( $label_width - ( $stringwidth + (2 * $left_text_margin) ) );
 903                     $hPos = ( ( $whitespace  / 2 ) + $x_pos + $left_text_margin );
 904                     #warn "\$label_width=$label_width \$stringwidth=$stringwidth \$whitespace=$whitespace \$left_text_margin=$left_text_margin for $str\n";
 905                 } else {
 906                     $hPos = ( $x_pos + $left_text_margin );
 907                 }
 908                 PrintText( $hPos, $vPos, $font, $fontsize, $str );
 909                 $vPos = $vPos - $line_spacer;
 910
 911             }
 912         }    # if field is
 913     }    #foreach feild
 914 }
 915
 916 sub PrintText {
 917     my ( $hPos, $vPos, $font, $fontsize, $text ) = @_;
 918     my $str = "BT /$font $fontsize Tf $hPos $vPos Td ($text) Tj ET";
 919     prAdd($str);
 920 }
 921
 922 # Is this used anywhere?
 923
 924 #sub SetFontSize {
 925 #
 926 #    my ($fontsize) = @_;
 927 #### fontsize
 928 #    my $str = "BT/F13 30 Tf288 720 Td( AAAAAAAAAA ) TjET";
 929 #    prAdd($str);
 930 #}
 931
 932 sub DrawBarcode {
 933
 934     # x and y are from the top-left :)
 935     my ( $x_pos, $y_pos, $height, $width, $barcode, $barcodetype ) = @_;
 936     my $num_of_bars = length($barcode);
 937     my $bar_width   = $width * .8;        # %80 of length of label width
 938     my $tot_bar_length;
 939     my $bar_length;
 940     my $guard_length = 10;
 941     my $xsize_ratio;
 942
 943     if ( $barcodetype eq 'CODE39' ) {
 944         $bar_length = '17.5';
 945         $tot_bar_length =
 946           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 947         $xsize_ratio = ( $bar_width / $tot_bar_length );
 948         eval {
 949             PDF::Reuse::Barcode::Code39(
 950                 x => ( $x_pos + ( $width / 10 ) ),
 951                 y => ( $y_pos + ( $height / 10 ) ),
 952                 value         => "*$barcode*",
 953                 ySize         => ( .02 * $height ),
 954                 xSize         => $xsize_ratio,
 955                 hide_asterisk => 1,
 956             );
 957         };
 958         if ($@) {
 959             warn "$barcodetype, $barcode FAILED:$@";
 960         }
 961     }
 962
 963     elsif ( $barcodetype eq 'CODE39MOD' ) {
 964
 965         # get modulo43 checksum
 966         my $c39 = CheckDigits('code_39');
 967         $barcode = $c39->complete($barcode);
 968
 969         $bar_length = '19';
 970         $tot_bar_length =
 971           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 972         $xsize_ratio = ( $bar_width / $tot_bar_length );
 973         eval {
 974             PDF::Reuse::Barcode::Code39(
 975                 x => ( $x_pos + ( $width / 10 ) ),
 976                 y => ( $y_pos + ( $height / 10 ) ),
 977                 value         => "*$barcode*",
 978                 ySize         => ( .02 * $height ),
 979                 xSize         => $xsize_ratio,
 980                 hide_asterisk => 1,
 981             );
 982         };
 983
 984         if ($@) {
 985             warn "$barcodetype, $barcode FAILED:$@";
 986         }
 987     }
 988     elsif ( $barcodetype eq 'CODE39MOD10' ) {
 989
 990         # get modulo43 checksum
 991         my $c39_10 = CheckDigits('visa');
 992         $barcode = $c39_10->complete($barcode);
 993
 994         $bar_length = '19';
 995         $tot_bar_length =
 996           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
 997         $xsize_ratio = ( $bar_width / $tot_bar_length );
 998         eval {
 999             PDF::Reuse::Barcode::Code39(
1000                 x => ( $x_pos + ( $width / 10 ) ),
1001                 y => ( $y_pos + ( $height / 10 ) ),
1002                 value         => "*$barcode*",
1003                 ySize         => ( .02 * $height ),
1004                 xSize         => $xsize_ratio,
1005                 hide_asterisk => 1,
1006                                 text         => 0,
1007             );
1008         };
1009
1010         if ($@) {
1011             warn "$barcodetype, $barcode FAILED:$@";
1012         }
1013     }
1014
1015
1016     elsif ( $barcodetype eq 'COOP2OF5' ) {
1017         $bar_length = '9.43333333333333';
1018         $tot_bar_length =
1019           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1020         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1021         eval {
1022             PDF::Reuse::Barcode::COOP2of5(
1023                 x => ( $x_pos + ( $width / 10 ) ),
1024                 y => ( $y_pos + ( $height / 10 ) ),
1025                 value => $barcode,
1026                 ySize => ( .02 * $height ),
1027                 xSize => $xsize_ratio,
1028             );
1029         };
1030         if ($@) {
1031             warn "$barcodetype, $barcode FAILED:$@";
1032         }
1033     }
1034
1035     elsif ( $barcodetype eq 'INDUSTRIAL2OF5' ) {
1036         $bar_length = '13.1333333333333';
1037         $tot_bar_length =
1038           ( $bar_length * $num_of_bars ) + ( $guard_length * 2 );
1039         $xsize_ratio = ( $bar_width / $tot_bar_length ) * .9;
1040         eval {
1041             PDF::Reuse::Barcode::Industrial2of5(
1042                 x => ( $x_pos + ( $width / 10 ) ),
1043                 y => ( $y_pos + ( $height / 10 ) ),
1044                 value => $barcode,
1045                 ySize => ( .02 * $height ),
1046                 xSize => $xsize_ratio,
1047             );
1048         };
1049         if ($@) {
1050             warn "$barcodetype, $barcode FAILED:$@";
1051         }
1052     }
1053
1054     my $moo2 = $tot_bar_length * $xsize_ratio;
1055
1056     warn "$x_pos, $y_pos, $barcode, $barcodetype" if $DEBUG;
1057     warn "BAR_WDTH = $bar_width, TOT.BAR.LGHT=$tot_bar_length  R*TOT.BAR =$moo2" if $DEBUG;
1058 }
1059
1060 =item build_circ_barcode;
1061
1062   build_circ_barcode( $x_pos, $y_pos, $barcode,
1063                 $barcodetype, \$item);
1064
1065 $item is the result of a previous call to get_label_items();
1066
1067 =cut
1068
1069 #'
1070 sub build_circ_barcode {
1071     my ( $x_pos_circ, $y_pos, $value, $barcodetype, $item ) = @_;
1072
1073     #warn Dumper \$item;
1074
1075     #warn "value = $value\n";
1076
1077     #$DB::single = 1;
1078
1079     if ( $barcodetype eq 'EAN13' ) {
1080
1081         #testing EAN13 barcodes hack
1082         $value = $value . '000000000';
1083         $value =~ s/-//;
1084         $value = substr( $value, 0, 12 );
1085
1086         #warn $value;
1087         eval {
1088             PDF::Reuse::Barcode::EAN13(
1089                 x     => ( $x_pos_circ + 27 ),
1090                 y     => ( $y_pos + 15 ),
1091                 value => $value,
1092
1093                 #            prolong => 2.96,
1094                 #            xSize   => 1.5,
1095
1096                 # ySize   => 1.2,
1097
1098 # added for xpdf compat. doesnt use type3 fonts., but increases filesize from 20k to 200k
1099 # i think its embedding extra fonts in the pdf file.
1100 #  mode => 'graphic',
1101             );
1102         };
1103         if ($@) {
1104             $item->{'barcodeerror'} = 1;
1105
1106             #warn "EAN13BARCODE FAILED:$@";
1107         }
1108
1109         #warn $barcodetype;
1110
1111     }
1112     elsif ( $barcodetype eq 'Code39' ) {
1113
1114         eval {
1115             PDF::Reuse::Barcode::Code39(
1116                 x     => ( $x_pos_circ + 9 ),
1117                 y     => ( $y_pos + 15 ),
1118                 value => $value,
1119
1120                 #           prolong => 2.96,
1121                 xSize => .85,
1122
1123                 ySize => 1.3,
1124             );
1125         };
1126         if ($@) {
1127             $item->{'barcodeerror'} = 1;
1128
1129             #warn "CODE39BARCODE $value FAILED:$@";
1130         }
1131
1132         #warn $barcodetype;
1133
1134     }
1135
1136     elsif ( $barcodetype eq 'Matrix2of5' ) {
1137
1138         #warn "MATRIX ELSE:";
1139
1140         #testing MATRIX25  barcodes hack
1141         #    $value = $value.'000000000';
1142         $value =~ s/-//;
1143
1144         #    $value = substr( $value, 0, 12 );
1145         #warn $value;
1146
1147         eval {
1148             PDF::Reuse::Barcode::Matrix2of5(
1149                 x     => ( $x_pos_circ + 27 ),
1150                 y     => ( $y_pos + 15 ),
1151                 value => $value,
1152
1153                 #        prolong => 2.96,
1154                 #       xSize   => 1.5,
1155
1156                 # ySize   => 1.2,
1157             );
1158         };
1159         if ($@) {
1160             $item->{'barcodeerror'} = 1;
1161
1162             #warn "BARCODE FAILED:$@";
1163         }
1164
1165         #warn $barcodetype;
1166
1167     }
1168
1169     elsif ( $barcodetype eq 'EAN8' ) {
1170
1171         #testing ean8 barcodes hack
1172         $value = $value . '000000000';
1173         $value =~ s/-//;
1174         $value = substr( $value, 0, 8 );
1175
1176         #warn $value;
1177
1178         #warn "EAN8 ELSEIF";
1179         eval {
1180             PDF::Reuse::Barcode::EAN8(
1181                 x       => ( $x_pos_circ + 42 ),
1182                 y       => ( $y_pos + 15 ),
1183                 value   => $value,
1184                 prolong => 2.96,
1185                 xSize   => 1.5,
1186
1187                 # ySize   => 1.2,
1188             );
1189         };
1190
1191         if ($@) {
1192             $item->{'barcodeerror'} = 1;
1193
1194             #warn "BARCODE FAILED:$@";
1195         }
1196
1197         #warn $barcodetype;
1198
1199     }
1200
1201     elsif ( $barcodetype eq 'UPC-E' ) {
1202         eval {
1203             PDF::Reuse::Barcode::UPCE(
1204                 x       => ( $x_pos_circ + 27 ),
1205                 y       => ( $y_pos + 15 ),
1206                 value   => $value,
1207                 prolong => 2.96,
1208                 xSize   => 1.5,
1209
1210                 # ySize   => 1.2,
1211             );
1212         };
1213
1214         if ($@) {
1215             $item->{'barcodeerror'} = 1;
1216
1217             #warn "BARCODE FAILED:$@";
1218         }
1219
1220         #warn $barcodetype;
1221
1222     }
1223     elsif ( $barcodetype eq 'NW7' ) {
1224         eval {
1225             PDF::Reuse::Barcode::NW7(
1226                 x       => ( $x_pos_circ + 27 ),
1227                 y       => ( $y_pos + 15 ),
1228                 value   => $value,
1229                 prolong => 2.96,
1230                 xSize   => 1.5,
1231
1232                 # ySize   => 1.2,
1233             );
1234         };
1235
1236         if ($@) {
1237             $item->{'barcodeerror'} = 1;
1238
1239             #warn "BARCODE FAILED:$@";
1240         }
1241
1242         #warn $barcodetype;
1243
1244     }
1245     elsif ( $barcodetype eq 'ITF' ) {
1246         eval {
1247             PDF::Reuse::Barcode::ITF(
1248                 x       => ( $x_pos_circ + 27 ),
1249                 y       => ( $y_pos + 15 ),
1250                 value   => $value,
1251                 prolong => 2.96,
1252                 xSize   => 1.5,
1253
1254                 # ySize   => 1.2,
1255             );
1256         };
1257
1258         if ($@) {
1259             $item->{'barcodeerror'} = 1;
1260
1261             #warn "BARCODE FAILED:$@";
1262         }
1263
1264         #warn $barcodetype;
1265
1266     }
1267     elsif ( $barcodetype eq 'Industrial2of5' ) {
1268         eval {
1269             PDF::Reuse::Barcode::Industrial2of5(
1270                 x       => ( $x_pos_circ + 27 ),
1271                 y       => ( $y_pos + 15 ),
1272                 value   => $value,
1273                 prolong => 2.96,
1274                 xSize   => 1.5,
1275
1276                 # ySize   => 1.2,
1277             );
1278         };
1279         if ($@) {
1280             $item->{'barcodeerror'} = 1;
1281
1282             #warn "BARCODE FAILED:$@";
1283         }
1284
1285         #warn $barcodetype;
1286
1287     }
1288     elsif ( $barcodetype eq 'IATA2of5' ) {
1289         eval {
1290             PDF::Reuse::Barcode::IATA2of5(
1291                 x       => ( $x_pos_circ + 27 ),
1292                 y       => ( $y_pos + 15 ),
1293                 value   => $value,
1294                 prolong => 2.96,
1295                 xSize   => 1.5,
1296
1297                 # ySize   => 1.2,
1298             );
1299         };
1300         if ($@) {
1301             $item->{'barcodeerror'} = 1;
1302
1303             #warn "BARCODE FAILED:$@";
1304         }
1305
1306         #warn $barcodetype;
1307
1308     }
1309
1310     elsif ( $barcodetype eq 'COOP2of5' ) {
1311         eval {
1312             PDF::Reuse::Barcode::COOP2of5(
1313                 x       => ( $x_pos_circ + 27 ),
1314                 y       => ( $y_pos + 15 ),
1315                 value   => $value,
1316                 prolong => 2.96,
1317                 xSize   => 1.5,
1318
1319                 # ySize   => 1.2,
1320             );
1321         };
1322         if ($@) {
1323             $item->{'barcodeerror'} = 1;
1324
1325             #warn "BARCODE FAILED:$@";
1326         }
1327
1328         #warn $barcodetype;
1329
1330     }
1331     elsif ( $barcodetype eq 'UPC-A' ) {
1332
1333         eval {
1334             PDF::Reuse::Barcode::UPCA(
1335                 x       => ( $x_pos_circ + 27 ),
1336                 y       => ( $y_pos + 15 ),
1337                 value   => $value,
1338                 prolong => 2.96,
1339                 xSize   => 1.5,
1340
1341                 # ySize   => 1.2,
1342             );
1343         };
1344         if ($@) {
1345             $item->{'barcodeerror'} = 1;
1346
1347             #warn "BARCODE FAILED:$@";
1348         }
1349
1350         #warn $barcodetype;
1351
1352     }
1353
1354 }
1355
1356 =item draw_boundaries
1357
1358  sub draw_boundaries ($x_pos_spine, $x_pos_circ1, $x_pos_circ2,
1359                 $y_pos, $spine_width, $label_height, $circ_width)
1360
1361 This sub draws boundary lines where the label outlines are, to aid in printer testing, and debugging.
1362
1363 =cut
1364
1365 #'
1366 sub draw_boundaries {
1367
1368     my (
1369         $x_pos_spine, $x_pos_circ1,  $x_pos_circ2, $y_pos,
1370         $spine_width, $label_height, $circ_width
1371     ) = @_;
1372
1373     my $y_pos_initial = ( ( 792 - 36 ) - 90 );
1374     $y_pos            = $y_pos_initial; # FIXME - why are we ignoring the y_pos parameter by redefining it?
1375     my $i             = 1;
1376
1377     for ( $i = 1 ; $i <= 8 ; $i++ ) {
1378
1379         &drawbox( $x_pos_spine, $y_pos, ($spine_width), ($label_height) );
1380
1381    #warn "OLD BOXES  x=$x_pos_spine, y=$y_pos, w=$spine_width, h=$label_height";
1382         &drawbox( $x_pos_circ1, $y_pos, ($circ_width), ($label_height) );
1383         &drawbox( $x_pos_circ2, $y_pos, ($circ_width), ($label_height) );
1384
1385         $y_pos = ( $y_pos - $label_height );
1386
1387     }
1388 }
1389
1390 =item drawbox
1391
1392         sub drawbox {   $lower_left_x, $lower_left_y,
1393                         $upper_right_x, $upper_right_y )
1394
1395 this is a low level sub, that draws a pdf box, it is called by draw_boxes
1396
1397 FYI: the  $upper_right_x and $upper_right_y values are RELATIVE to  $lower_left_x and $lower_left_y
1398
1399 and $lower_left_x, $lower_left_y are ABSOLUTE, this caught me out!
1400
1401 =cut
1402
1403 #'
1404 sub drawbox {
1405     my ( $llx, $lly, $urx, $ury ) = @_;
1406
1407     #    warn "llx,y= $llx,$lly  ,   urx,y=$urx,$ury \n";
1408
1409     my $str = "q\n";    # save the graphic state
1410     $str .= "0.5 w\n";              # border color red
1411     $str .= "1.0 0.0 0.0  RG\n";    # border color red
1412          #   $str .= "0.5 0.75 1.0 rg\n";           # fill color blue
1413     $str .= "1.0 1.0 1.0  rg\n";    # fill color white
1414
1415     $str .= "$llx $lly $urx $ury re\n";    # a rectangle
1416     $str .= "B\n";                         # fill (and a little more)
1417     $str .= "Q\n";                         # save the graphic state
1418
1419     prAdd($str);
1420
1421 }
1422
1423 END { }    # module clean-up code here (global destructor)
1424
1425 1;
1426 __END__
1427
1428 =back
1429
1430 =head1 AUTHOR
1431
1432 Mason James <mason@katipo.co.nz>
1433
1434 =cut
1435