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 - ( 2* $left_text_margin);
 366
 367     while ( $strwidth < $textlimit ) {
 368         $count++;
 369         $strwidth = prStrWidth( $string, $font, $fontsize );
 370         $string = $string . '0';
 371         #warn "strwidth:$strwidth, textlimit:$textlimit, count:$count string:$string";
 372     }
 373     return $count;
 374 }
 375
 376 sub GetActiveLabelTemplate {
 377     my $dbh   = C4::Context->dbh;
 378     my $query = " SELECT * FROM labels_templates where active = 1 limit 1";
 379     my $sth   = $dbh->prepare($query);
 380     $sth->execute();
 381     my $active_tmpl = $sth->fetchrow_hashref;
 382     $sth->finish;
 383     return $active_tmpl;
 384 }
 385
 386 sub GetSingleLabelTemplate {
 387     my ($tmpl_id) = @_;
 388     my $dbh       = C4::Context->dbh;
 389     my $query     = " SELECT * FROM labels_templates where tmpl_id = ?";
 390     my $sth       = $dbh->prepare($query);
 391     $sth->execute($tmpl_id);
 392     my $template = $sth->fetchrow_hashref;
 393     $sth->finish;
 394     return $template;
 395 }
 396
 397 sub SetActiveTemplate {
 398
 399     my ($tmpl_id) = @_;
 400
 401     my $dbh   = C4::Context->dbh;
 402     my $query = " UPDATE labels_templates SET active = NULL";
 403     my $sth   = $dbh->prepare($query);
 404     $sth->execute();
 405
 406     $query = "UPDATE labels_templates SET active = 1 WHERE tmpl_id = ?";
 407     $sth   = $dbh->prepare($query);
 408     $sth->execute($tmpl_id);
 409     $sth->finish;
 410 }
 411
 412 sub set_active_layout {
 413
 414     my ($layout_id) = @_;
 415     my $dbh         = C4::Context->dbh;
 416     my $query       = " UPDATE labels_conf SET active = NULL";
 417     my $sth         = $dbh->prepare($query);
 418     $sth->execute();
 419
 420     $query = "UPDATE labels_conf SET active = 1 WHERE id = ?";
 421     $sth   = $dbh->prepare($query);
 422     $sth->execute($layout_id);
 423     $sth->finish;
 424 }
 425
 426 sub DeleteTemplate {
 427     my ($tmpl_id) = @_;
 428     my $dbh       = C4::Context->dbh;
 429     my $query     = " DELETE  FROM labels_templates where tmpl_id = ?";
 430     my $sth       = $dbh->prepare($query);
 431     $sth->execute($tmpl_id);
 432     $sth->finish;
 433 }
 434
 435 sub SaveTemplate {
 436     my (
 437         $tmpl_id,     $tmpl_code,   $tmpl_desc,    $page_width,
 438         $page_height, $label_width, $label_height, $topmargin,
 439         $leftmargin,  $cols,        $rows,         $colgap,
 440         $rowgap,      $font,        $fontsize,     $units
 441     ) = @_;
 442     warn "Passed \$font:$font";
 443     my $dbh = C4::Context->dbh;
 444     my $query =
 445       " UPDATE labels_templates SET tmpl_code=?, tmpl_desc=?, page_width=?,
 446                page_height=?, label_width=?, label_height=?, topmargin=?,
 447                leftmargin=?, cols=?, rows=?, colgap=?, rowgap=?, font=?, fontsize=?,
 448                            units=?
 449                   WHERE tmpl_id = ?";
 450
 451     my $sth = $dbh->prepare($query);
 452     $sth->execute(
 453         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 454         $label_width, $label_height, $topmargin,  $leftmargin,
 455         $cols,        $rows,         $colgap,     $rowgap,
 456         $font,        $fontsize,     $units,      $tmpl_id
 457     );
 458     my $dberror = $sth->errstr;
 459     $sth->finish;
 460     return $dberror;
 461 }
 462
 463 sub CreateTemplate {
 464     my $tmpl_id;
 465     my (
 466         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 467         $label_width, $label_height, $topmargin,  $leftmargin,
 468         $cols,        $rows,         $colgap,     $rowgap,
 469         $font,        $fontsize,     $units
 470     ) = @_;
 471
 472     my $dbh = C4::Context->dbh;
 473
 474     my $query = "INSERT INTO labels_templates (tmpl_code, tmpl_desc, page_width,
 475                          page_height, label_width, label_height, topmargin,
 476                          leftmargin, cols, rows, colgap, rowgap, font, fontsize, units)
 477                          VALUES(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)";
 478
 479     my $sth = $dbh->prepare($query);
 480     $sth->execute(
 481         $tmpl_code,   $tmpl_desc,    $page_width, $page_height,
 482         $label_width, $label_height, $topmargin,  $leftmargin,
 483         $cols,        $rows,         $colgap,     $rowgap,
 484         $font,        $fontsize,    $units
 485     );
 486     my $dberror = $sth->errstr;
 487     $sth->finish;
 488     return $dberror;
 489 }
 490
 491 sub GetAllLabelTemplates {
 492     my $dbh = C4::Context->dbh;
 493
 494     # get the actual items to be printed.
 495     my @data;
 496     my $query = " Select * from labels_templates ";
 497     my $sth   = $dbh->prepare($query);
 498     $sth->execute();
 499     my @resultsloop;
 500     while ( my $data = $sth->fetchrow_hashref ) {
 501         push( @resultsloop, $data );
 502     }
 503     $sth->finish;
 504
 505     #warn Dumper @resultsloop;
 506     return @resultsloop;
 507 }
 508
 509 #sub SaveConf {
 510 sub add_layout {
 511
 512     my (
 513         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 514         $itemtype,     $bcn,            $dcn,        $classif,
 515         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 516         $printingtype, $guidebox,       $startlabel, $layoutname
 517     ) = @_;
 518
 519     my $dbh    = C4::Context->dbh;
 520     my $query2 = "update labels_conf set active = NULL";
 521     my $sth2   = $dbh->prepare($query2);
 522     $sth2->execute();
 523     $query2 = "INSERT INTO labels_conf
 524             ( barcodetype, title, subtitle, isbn,issn, itemtype, barcode,
 525               dewey, class, subclass, itemcallnumber, author, printingtype,
 526                 guidebox, startlabel, layoutname, active )
 527                values ( ?, ?, ?, ?, ?, ?, ?,  ?,?, ?, ?, ?, ?, ?,?,?, 1 )";
 528     $sth2 = $dbh->prepare($query2);
 529     $sth2->execute(
 530         $barcodetype, $title, $subtitle, $isbn, $issn,
 531
 532         $itemtype, $bcn,            $dcn,    $classif,
 533         $subclass, $itemcallnumber, $author, $printingtype,
 534         $guidebox, $startlabel,     $layoutname
 535     );
 536     $sth2->finish;
 537
 538     SetActiveTemplate($tmpl_id);
 539     return;
 540 }
 541
 542 sub save_layout {
 543
 544     my (
 545         $barcodetype,  $title,          $subtitle,      $isbn,       $issn,
 546         $itemtype,     $bcn,            $dcn,        $classif,
 547         $subclass,     $itemcallnumber, $author,     $tmpl_id,
 548         $printingtype, $guidebox,       $startlabel, $layoutname,
 549         $layout_id
 550     ) = @_;
 551 ### $layoutname
 552 ### $layout_id
 553
 554     my $dbh    = C4::Context->dbh;
 555     my $query2 = "update labels_conf set
 556              barcodetype=?, title=?, subtitle=?, isbn=?,issn=?,
 557             itemtype=?, barcode=?,    dewey=?, class=?,
 558              subclass=?, itemcallnumber=?, author=?,  printingtype=?,
 559                guidebox=?, startlabel=?, layoutname=? where id = ?";
 560     my $sth2 = $dbh->prepare($query2);
 561     $sth2->execute(
 562         $barcodetype, $title,          $subtitle,       $isbn,       $issn,
 563         $itemtype,    $bcn,            $dcn,        $classif,
 564         $subclass,    $itemcallnumber, $author,     $printingtype,
 565         $guidebox,    $startlabel,     $layoutname, $layout_id
 566     );
 567     $sth2->finish;
 568
 569     return;
 570 }
 571
 572 =item GetAllPrinterProfiles;
 573
 574     @profiles = GetAllPrinterProfiles()
 575
 576 Returns an array of references-to-hash, whos keys are .....
 577
 578 =cut
 579
 580 sub GetAllPrinterProfiles {
 581
 582     my $dbh = C4::Context->dbh;
 583     my @data;
 584     my $query = "SELECT * FROM printers_profile AS pp INNER JOIN labels_templates AS lt ON pp.tmpl_id = lt.tmpl_id; ";
 585     my $sth = $dbh->prepare($query);
 586     $sth->execute();
 587     my @resultsloop;
 588     while ( my $data = $sth->fetchrow_hashref ) {
 589         push( @resultsloop, $data );
 590     }
 591     $sth->finish;
 592
 593     return @resultsloop;
 594 }
 595
 596 =item GetSinglePrinterProfile;
 597
 598     $profile = GetSinglePrinterProfile()
 599
 600 Returns a hashref whos keys are...
 601
 602 =cut
 603
 604 sub GetSinglePrinterProfile {
 605     my ($prof_id) = @_;
 606     my $dbh       = C4::Context->dbh;
 607     my $query     = " SELECT * FROM printers_profile WHERE prof_id = ?; ";
 608     my $sth       = $dbh->prepare($query);
 609     $sth->execute($prof_id);
 610     my $template = $sth->fetchrow_hashref;
 611     $sth->finish;
 612     return $template;
 613 }
 614
 615 =item SaveProfile;
 616
 617     SaveProfile('parameters')
 618
 619 When passed a set of parameters, this function updates the given profile with the new parameters.
 620
 621 =cut
 622
 623 sub SaveProfile {
 624     my (
 625         $prof_id,       $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units
 626     ) = @_;
 627     my $dbh = C4::Context->dbh;
 628     my $query =
 629       " UPDATE printers_profile
 630         SET offset_horz=?, offset_vert=?, creep_horz=?, creep_vert=?, unit=?
 631         WHERE prof_id = ? ";
 632     my $sth = $dbh->prepare($query);
 633     $sth->execute(
 634         $offset_horz,   $offset_vert,   $creep_horz,    $creep_vert,    $units,         $prof_id
 635     );
 636     $sth->finish;
 637 }
 638
 639 =item CreateProfile;
 640
 641     CreateProfile('parameters')
 642
 643 When passed a set of parameters, this function creates a new profile containing those parameters
 644 and returns any errors.
 645
 646 =cut
 647
 648 sub CreateProfile {
 649     my (
 650         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 651         $offset_vert,   $creep_horz,    $creep_vert,    $units
 652     ) = @_;
 653     my $dbh = C4::Context->dbh;
 654     my $query =
 655         " INSERT INTO printers_profile (prof_id, printername, paper_bin, tmpl_id,
 656                                         offset_horz, offset_vert, creep_horz, creep_vert, unit)
 657           VALUES(?,?,?,?,?,?,?,?,?) ";
 658     my $sth = $dbh->prepare($query);
 659     $sth->execute(
 660         $prof_id,       $printername,   $paper_bin,     $tmpl_id,     $offset_horz,
 661         $offset_vert,   $creep_horz,    $creep_vert,    $units
 662     );
 663     my $error =  $sth->errstr;
 664     $sth->finish;
 665     return $error;
 666 }
 667
 668 =item DeleteProfile;
 669
 670     DeleteProfile(prof_id)
 671
 672 When passed a profile id, this function deletes that profile from the database and returns any errors.
 673
 674 =cut
 675
 676 sub DeleteProfile {
 677     my ($prof_id) = @_;
 678     my $dbh       = C4::Context->dbh;
 679     my $query     = " DELETE FROM printers_profile WHERE prof_id = ?";
 680     my $sth       = $dbh->prepare($query);
 681     $sth->execute($prof_id);
 682     my $error = $sth->errstr;
 683     $sth->finish;
 684     return $error;
 685 }
 686
 687 =item GetAssociatedProfile;
 688
 689     $assoc_prof = GetAssociatedProfile(tmpl_id)
 690
 691 When passed a template id, this function returns the parameters from the currently associated printer profile
 692 in a hashref where key=fieldname and value=fieldvalue.
 693
 694 =cut
 695
 696 sub GetAssociatedProfile {
 697     my ($tmpl_id) = @_;
 698     my $dbh   = C4::Context->dbh;
 699     # First we find out the prof_id for the associated profile...
 700     my $query = "SELECT * FROM labels_profile WHERE tmpl_id = ?";
 701     my $sth   = $dbh->prepare($query);
 702     $sth->execute($tmpl_id);
 703     my $assoc_prof = $sth->fetchrow_hashref;
 704     $sth->finish;
 705     # Then we retrieve that profile and return it to the caller...
 706     $assoc_prof = GetSinglePrinterProfile($assoc_prof->{'prof_id'});
 707     return $assoc_prof;
 708 }
 709
 710 =item SetAssociatedProfile;
 711
 712     SetAssociatedProfile($prof_id, $tmpl_id)
 713
 714 When passed both a profile id and template id, this function establishes an association between the two. No more
 715 than one profile may be associated with any given template at the same time.
 716
 717 =cut
 718
 719 sub SetAssociatedProfile {
 720
 721     my ($prof_id, $tmpl_id) = @_;
 722
 723     my $dbh = C4::Context->dbh;
 724     my $query = "INSERT INTO labels_profile (prof_id, tmpl_id) VALUES (?,?) ON DUPLICATE KEY UPDATE prof_id = ?";
 725     my $sth = $dbh->prepare($query);
 726     $sth->execute($prof_id, $tmpl_id, $prof_id);
 727     $sth->finish;
 728 }
 729
 730 =item get_label_items;
 731
 732         $options = get_label_items()
 733
 734 Returns an array of references-to-hash, whos keys are the field from the biblio, biblioitems, items and labels tables in the Koha database.
 735
 736 =cut
 737
 738 #'
 739 sub get_label_items {
 740     my ($batch_id) = @_;
 741     my $dbh = C4::Context->dbh;
 742
 743     my @resultsloop = ();
 744     my $count;
 745     my @data;
 746     my $sth;
 747
 748     if ($batch_id) {
 749         my $query3 = "Select * from labels where batch_id = ? order by labelid ";
 750         $sth = $dbh->prepare($query3);
 751         $sth->execute($batch_id);
 752
 753     }
 754     else {
 755
 756         my $query3 = "Select * from labels";
 757         $sth = $dbh->prepare($query3);
 758         $sth->execute();
 759     }
 760     my $cnt = $sth->rows;
 761     my $i1  = 1;
 762     while ( my $data = $sth->fetchrow_hashref ) {
 763
 764         # lets get some summary info from each item
 765         my $query1 = "
 766          select i.*, bi.*, b.*  from items i,biblioitems bi,biblio b
 767                 where itemnumber=? and  i.biblioitemnumber=bi.biblioitemnumber and
 768                 bi.biblionumber=b.biblionumber";
 769
 770                 my $sth1 = $dbh->prepare($query1);
 771         $sth1->execute( $data->{'itemnumber'} );
 772
 773         my $data1 = $sth1->fetchrow_hashref();
 774         $data1->{'labelno'}  = $i1;
 775         $data1->{'labelid'}  = $data->{'labelid'};
 776         $data1->{'batch_id'} = $batch_id;
 777         $data1->{'summary'} =
 778           "$data1->{'barcode'}, $data1->{'title'}, $data1->{'isbn'}";
 779
 780         push( @resultsloop, $data1 );
 781         $sth1->finish;
 782
 783         $i1++;
 784     }
 785     $sth->finish;
 786     return @resultsloop;
 787
 788 }
 789
 790 sub GetItemFields {
 791     my @fields = qw (
 792       barcode title subtitle
 793       dewey isbn issn author class
 794       itemtype subclass itemcallnumber
 795
 796     );
 797     return @fields;
 798 }
 799
 800 sub deduplicate_batch {
 801         my $batch_id = shift or return undef;
 802         my $query = "
 803         SELECT DISTINCT
 804                         batch_id,itemnumber,
 805                         count(labelid) as count
 806         FROM     labels
 807         WHERE    batch_id = ?
 808         GROUP BY itemnumber,batch_id
 809         HAVING   count > 1
 810         ORDER BY batch_id,
 811                          count DESC  ";
 812         my $sth = C4::Context->dbh->prepare($query);
 813         $sth->execute($batch_id);
 814         $sth->rows or return undef;
 815
 816         my $del_query = qq(
 817         DELETE
 818         FROM     labels
 819         WHERE    batch_id = ?
 820         AND      itemnumber = ?
 821         ORDER BY timestamp ASC
 822         );
 823         my $killed = 0;
 824         while (my $data = $sth->fetchrow_hashref()) {
 825                 my $itemnumber = $data->{itemnumber} or next;
 826                 my $limit      = $data->{count} - 1  or next;
 827                 my $sth2 = C4::Context->dbh->prepare("$del_query  LIMIT $limit");
 828                 # die sprintf "$del_query LIMIT %s\n (%s, %s)", $limit, $batch_id, $itemnumber;
 829                 # $sth2->execute($batch_id, C4::Context->dbh->quote($data->{itemnumber}), $data->{count} - 1)
 830                 $sth2->execute($batch_id, $itemnumber) and
 831                         $killed += ($data->{count} - 1);
 832         }
 833         return $killed;
 834 }
 835
 836 sub DrawSpineText {
 837
 838     my ( $y_pos, $label_height, $label_width, $font, $fontsize, $x_pos, $left_text_margin,
 839         $text_wrap_cols, $item, $conf_data, $printingtype )
 840       = @_;
 841 # hack to fix column name mismatch betwen labels_conf.class, and bibitems.classification
 842         $$item->{'class'} = $$item->{'classification'};
 843
 844     $Text::Wrap::columns   = $text_wrap_cols;
 845     $Text::Wrap::separator = "\n";
 846
 847     my $str;
 848     ##      $item
 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     ### @fields
 863
 864     my $vPos   = ( $y_pos + ( $label_height - $top_text_margin ) );
 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 length...
 901                     my $stringwidth = prStrWidth($str, $font, $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";
 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