File Coverage

blib/lib/PDF/Kit.pm

Criterion	Covered	Total	%
statement	27	316	8.5
branch	0	90	0.0
condition	0	59	0.0
subroutine	9	23	39.1
pod	13	13	100.0
total	49	501	9.7

#!/
# --------------------------------------
#
#   Title: PDF Kit
# Purpose: A collection of subroutines for PDF::API2.
#
#    Name: PDF::Kit
#    File: Kit.pm
# Created: June  2, 2009
#
# Copyright: Copyright 2009 by Shawn H. Corey.  All rights reserved.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

# --------------------------------------
# Package
package PDF::Kit;

# --------------------------------------
# Pragmas

use strict;
use warnings;

# --------------------------------------
# Version
use version; our $VERSION = qv(v1.0.5);

# --------------------------------------
# Exports
use base qw( Exporter );
our @EXPORT = qw(
  in2pts
  cm2pts
  mm2pts
  baselines
  column_blocks
  small_caps
  flatten
  as_text
  format_paragraph
  align_lines
  justify_lines
  print_lines
  print_paragraph
);
our @EXPORT_OK = qw(
  add_fonts
);
our %EXPORT_TAGS = (
  all => [ @EXPORT, @EXPORT_OK ],
);

# --------------------------------------
# Modules
use Carp;
use Data::Dumper;
use English qw( -no_match_vars ) ;  # Avoids regex performance penalty
use File::Basename;
use POSIX;

# --------------------------------------
# Configuration Parameters

my $SPACE = "\x20";

# Make Data::Dumper pretty
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Indent   = 1;
$Data::Dumper::Maxdepth = 0;

# --------------------------------------
# Variables

# --------------------------------------
# Subroutines

# --------------------------------------
#       Name: in2pts
#      Usage: @points = in2pts( @inches );
#             $points = in2pts( @inches );
#    Purpose: Convert inches to points.
# Parameters: @inches -- List of numbers in inches.
#    Returns: $points -- Single value in points.
#             @points -- List of values in points.
#
sub in2pts {
  my @points = @_;

  $_ *= 72 for @points;
  return wantarray ? @points : $points[0];
}

# --------------------------------------
#       Name: cm2pts
#      Usage: @points = cm2pts( @cm );
#             $points = cm2pts( @cm );
#    Purpose: Convert centimetres to points.
# Parameters:     @cm -- List of numbers in centimetres.
#    Returns: $points -- Single value in points.
#             @points -- List of values in points.
#
sub cm2pts {
  my @points = @_;

  $_ *= 72/2.54 for @points;
  return wantarray ? @points : $points[0];
}

# --------------------------------------
#       Name: mm2pts
#      Usage: @points = mm2pts( @mm );
#             $points = mm2pts( @mm );
#    Purpose: Convert millimetres to points.
# Parameters:     @mm -- List of numbers in millimetres.
#    Returns: $points -- Single value in points.
#             @points -- List of values in points.
#
sub mm2pts {
  my @points = @_;

  $_ *= 72/25.4 for @points;
  return wantarray ? @points : $points[0];
}

# --------------------------------------
#       Name: baselines
#      Usage: @y_values = baselines( $height, $size; $spacing, $bottom );
#    Purpose: Compute the Y values for the baselines.
# Parameters:   $height -- The height of the box.
#                 $size -- Size of the font.
#              $spacing -- Optional line spacing.  Typical values are 1.0, 1.5, 2.0.  Default is 1.0.
#               $bottom -- Optional bottom margin; will be added to the Y values.
#    Returns: @y_values -- List of Y values.
#
sub baselines {
  my $height   = shift @_;
  my $size     = shift @_;
  my $spacing  = shift @_ || 1;
  my $bottom   = shift @_ || 0;
  my $leading  = $size * $spacing;

  my @y_values = ();
  my $y = $height - $size;
  while( $y >= 0 ){
    push @y_values, $y + $bottom;
    $y -= $leading;
  }

  return @y_values;
}

# --------------------------------------
#       Name: column_blocks
#      Usage: \@blocks = column_blocks( \@block, $columns; $gap );
#    Purpose: Calculate the block of the column that fit in the given block
# Parameters:  \@block -- [ min_x, min_y, max_x, max_y ]
#             $columns -- Number of columns
#                 $gap -- Gap between columns; optional, default is 0 (zero).
#    Returns: \@blocks -- List of columns
#
sub column_blocks {
  my $block   = shift @_;
  my $columns = shift @_;
  my $gap     = shift @_ || 0;
  my $blocks  = [];

  my $width = ( $block->[2] - $block->[0] - $gap * ( $columns - 1 ) ) / $columns;

  my $offset = $block->[0];
  for my $i ( 1 .. $columns ){
    push @$blocks, [ @$block ]; # make a copy
    $blocks->[-1][0] = $offset;
    $offset += $width;
    $blocks->[-1][2] = $offset;
    $offset += $gap;
  }

  return $blocks;
}

# --------------------------------------
#       Name: small_caps
#      Usage: \@mut = small_caps( $size, $factor, @text );
#    Purpose: Convert the text to small caps.
# Parameters:   $size -- Size of resulting text.
#             $factor -- The relative size of the lowercase characters.
#                        Recommended factors are from 0.65 to 0.75.
#               @text -- List of text items.
#    Returns:   \@mut -- L.
#
sub small_caps {
  my $size   = shift @_;
  my $factor = shift @_;
  my @text   = @_;
  my $mut    = [];
  my $lc_size = $size * $factor;
  my $prev = '';

  for my $text ( @text ){
    for my $c ( split( //, $text ) ){
      if( isupper( $c ) ){
        if( $prev ne 'u' ){
          push @$mut, { -size=>$size };
          $prev = 'u';
        }
        push @$mut, $c;
      }else{
        if( $prev ne 'l' ){
          push @$mut, { -size=>$lc_size };
          $prev = 'l';
        }
        push @$mut, uc( $c );
      }
    }
  }

  return [ $mut ];
}

# --------------------------------------
#       Name: flatten
#      Usage: \@flattened = flatten( @attributed_text );
#    Purpose: Change nested attributed text into flatten attributed text.
# Parameters: @attributed_text -- nested attributed text
#    Returns:      \@flattened -- flatten attributed text
#
sub flatten {
  my $list = [];
  my @context = (
    {
      -opts => {},
      -items => [ @_ ],
    }
  );

  while( @context ){
    my %opts = %{ $context[-1]{-opts} };
    my $items = $context[-1]{-items};
    pop @context;

    if( @$list && ref( $list->[-1] ) ){
      $list->[-1] = { %opts };
    }else{
      push @$list, { %opts };
    }

    while( @$items ){
      my $item = shift @$items;

      if( my $ref = ref( $item ) ){
        if( $ref eq 'ARRAY' ){
          push @context, {
            -opts => { %opts },
            -items => [ @$items ],
          };
          $items = $item;
        }elsif( $ref eq 'HASH' ){
          @opts{ keys %$item } = values %$item;
          if( @$list && ref( $list->[-1] ) ){
            $list->[-1] = { %opts };
          }else{
            push @$list, { %opts };
          }
        }
      }else{
        unless( @$list && ! ref( $list->[-1] ) ){
          push @$list, '';
        }
        $list->[-1] .= $SPACE if $opts{-space_before};
        $list->[-1] .= $item;
        $list->[-1] .= $SPACE if $opts{-space_after};
      }
    }
  }

  while( @$list && ref( $list->[-1] ) ){
    pop @$list;
  }

  my $flattened = [];
  while( @$list ){
    my %opts = %{ shift @$list };
    delete $opts{-space_before} if exists $opts{-space_before};
    delete $opts{-space_after} if exists $opts{-space_after};
    push @$flattened, [ { %opts }, shift @$list ];
  }

  return $flattened;
}

# --------------------------------------
#       Name: as_text
#      Usage: $text = as_text( @mut );
#    Purpose: Convert nested attributed text to regular text.
# Parameters:   @mut -- List of L items.
#    Returns:  $text -- Its text.
#
sub as_text {
  my $mut   = flatten( @_ );
  my $text  = '';

  for my $item ( @$mut ){
    $text .= $item unless ref( $item );
  }

  return $text;
}

# --------------------------------------
#       Name: format_paragraph
#      Usage: ( \@lines, \@mut ) = format_paragraph( \%paragraph_options, @mut );
#
#    Purpose: Format the L to fit into a paragraph.
#             Items may be text, sub-lists, or mark-up options.
#             Text is broken into words via whitespace, C.
#             Use the UTF character C<\x{a0}> for non-breaking spaces.
#             Leading whitespace in the first text item is ignored.
#
#             Text will formatted with a single space character between each word
#             unless the C<-two_spaces> option is used.
#
#             See POD for more details.
#
#
# Parameters: \%paragraph_options -- Mark-up options for the paragraph.
#                                    See Mark-up Text in the POD for details.
#                            @mut -- Mark-up Text to format.
#    Returns:             \@lines -- A list of formatted lines.
#                           \@mut -- Leftover mut that did not fit into the paragraph.
#                                    These may be used, as is, in another L call.
#
sub format_paragraph {

  # flatten makes things easier
  my $mut = flatten( @_ );

  # remove leading spaces in first text item
  $mut->[1] =~ s{ \A \s+ }{}msx if @$mut > 1;

  # save the indent
  my $indent = 0;
  if( @$mut && exists( $mut->[0][0]{-indent} ) ){
    $indent = $mut->[0][0]{-indent} || 0;
  }

  my $lines = [];
  my $space_pending = 0;
  my $space_width = 0;
  my $trailing_width = 0;
  my $trailing_spaces = '';
  my $two_spaces = 0;

  my $add_p_end = 1;

MUT_LOOP:
  while( @$mut ){
    my %opts = %{ $mut->[0][0] };
    my $text = $mut->[0][1];
    shift @$mut;

    # add a new segment
    if( @$lines ){
      push @{ $lines->[-1]{-segments} }, {
        %opts,
        -offset => $lines->[-1]{-segments}[-1]{-offset} + $lines->[-1]{-segments}[-1]{-length},
        -length => 0,
        -text => '',
      };
    }else{
      push @{ $lines->[0]{-segments} }, {
        %opts,
        -offset => $indent,
        -length => 0,
        -text => '',
      };
    }

    if( $space_pending ){
      $trailing_spaces = $SPACE;
      $trailing_width = $space_width;
      if( $two_spaces ){
        $trailing_spaces .= $SPACE;
        $trailing_width .= $space_width;
      }
    }

    $space_width = &{$opts{-compute_length}}( { %opts, -print=>0, }, $SPACE ); # must redo every time since might have changed from previous

    # process the text
    my @text = split m{ ( \s+ ) }msx, $text;
    while( @text ){
      my $word = shift @text;

      if( $word =~ m{ \A \s }msx ){
        $space_pending = 1;
        next;
      }

      my $word_length = &{$opts{-compute_length}}( { %opts, -print=>0, }, $word );
      my $extended_length = $word_length;
      # a word at end of text may be joined to next
      unless( @text ){
        for my $item ( @$mut ){
          last if $item->[1] =~ m{ \A \s }msx;
          if( $item->[1] =~ m{ \A (\S+) (?=\s) }msx ){
            my $look_ahead = $1;
            $extended_length += &{$opts{-compute_length}}( { %opts, -print=>0, }, $look_ahead );
            last;
          }
          $extended_length += &{$opts{-compute_length}}( { %opts, -print=>0, }, $item->[1] );
        }
      }
      my $right = $lines->[-1]{-segments}[-1]{-offset} + $lines->[-1]{-segments}[-1]{-length} + $extended_length;
      my $new_line = 0;

      if( $trailing_width ){
        if( $trailing_width + $right > $lines->[-1]{-segments}[-1]{-width} ){
          $new_line = 1;
        }
      }elsif( $space_pending ){
        my $spw = $space_width;
        $spw += $space_width if $two_spaces;
        if( $spw + $right > $lines->[-1]{-segments}[-1]{-width} ){
          $new_line = 1;
        }
      }

      # add a new line
      if( $new_line ){
        $lines->[-1]{-width} = $lines->[-1]{-segments}[-1]{-width};
        if( exists( $opts{-max_lines} ) && @$lines >= $opts{-max_lines} ){
          delete $opts{-offset};
          delete $opts{-length};
          delete $opts{-text};
          $opts{-indent} = 0; # everything left over is still part of this paragraph, so it's indent must be zero.
          unshift @$mut, [ { %opts }, join( '', $word, @text ) ];
          $add_p_end = 0;
          last MUT_LOOP;
        }
        push @$lines, {
          -length => 0,
          -segments =>[{
            %opts,
            -offset => 0,
            -length => 0,
            -text => '',
          }],
        };
        $space_pending = 0;
        $trailing_width = 0;
      }

      if( $trailing_width ){
        $lines->[-1]{-length} += $trailing_width;
        $lines->[-1]{-segments}[-1]{-offset} += $trailing_width;
        $lines->[-1]{-segments}[-2]{-length} += $trailing_width;
        $lines->[-1]{-segments}[-2]{-text}   .= $trailing_spaces;
        $trailing_width = 0;
      }elsif( $space_pending ){
        $lines->[-1]{-length} += $space_width;
        $lines->[-1]{-segments}[-1]{-length} += $space_width;
        $lines->[-1]{-segments}[-1]{-text}   .= $SPACE;
        if( $two_spaces ){
          $lines->[-1]{-length} += $space_width;
          $lines->[-1]{-segments}[-1]{-length} += $space_width;
          $lines->[-1]{-segments}[-1]{-text}   .= $SPACE;
        }
      }

      $lines->[-1]{-length} += $word_length;
      $lines->[-1]{-segments}[-1]{-length} += $word_length;
      $lines->[-1]{-segments}[-1]{-text}   .= $word;

      $space_pending = 0;
      $trailing_width = 0;

      # check for two_spaces after word
      $two_spaces = 0;
      if( $opts{-two_spaces} ){
        $two_spaces = $word =~ $opts{-two_spaces} || 0;
      }
    }
  }
  $lines->[-1]{-width} = $lines->[-1]{-segments}[-1]{-width};
  if( @$lines && $add_p_end ){
    $lines->[-1]{-last_line} = 1;
  }

  return ( $lines, $mut );
}

# --------------------------------------
#       Name: align_lines
#      Usage: align_lines( $alignment, $lines );
#    Purpose: Change the offsets in the lines outputted by L to align the paragraph.
# Parameters: $alignment -- A value of 0.0 will left align;
#                           a value of 0.5 will center align;
#                           a value of 1.0 will right align.
#                           Other values will create weird, special effects.
#                 $lines -- Output from L.
#    Returns: none
#
sub align_lines {
  my $alignment = shift @_;
  my $lines     = shift @_;

  # first line may have indent, so do it separate
  my $indent = $lines->[0]{-segments}[0]{-indent} || 0;
  my $gap = $lines->[0]{-width} - $lines->[0]{-length};
  my $offset = $gap * $alignment;
  for my $segment ( @{ $lines->[0]{-segments} } ){
    $segment->{-offset} = $offset;
    $offset += $segment->{-length};
  }

  # do the rest
  for my $line ( @{ $lines }[ 1 .. $#$lines ] ){
    $gap = $line->{-width} - $line->{-length};
    $offset = $gap * $alignment;
    for my $segment ( @{ $line->{-segments} } ){
      $segment->{-offset} = $offset;
      $offset += $segment->{-length};
    }
  }

  return;
}

# --------------------------------------
#       Name: _justify_line
#      Usage: _justify_line( $word_spacing_weight, $character_spacing_weight, $horizontal_scaling_weight, $line; $indent );
#    Purpose: Calculate the amount to adjust the spacing and scaling to justify the line.
# Parameters:       $word_spacing_weight -- How much attributed to spaces between words.
#              $character_spacing_weight -- How much attributed to spaces between characters.
#             $horizontal_scaling_weight -- How much attributed to scaling the glyphs horizontally.
#                                  $line -- The line to adjust.
#                                $indent -- Possible indentation of the line.
#    Returns: none
#
sub _justify_line {
  my $word_spacing_weight       = shift @_;
  my $character_spacing_weight  = shift @_;
  my $horizontal_scaling_weight = shift @_;
  my $line                      = shift @_;
  my $indent                    = shift @_ || 0;

  my $gap = $line->{-width} - $line->{-length} - $indent;

  my $char = 0;
  my $sp   = 0;
  for my $segment ( @{ $line->{-segments} } ){
    $char += length( $segment->{-text} );
    $sp   += $segment->{-text} =~ tr/\x20/\x20/;
  }

  # calculate character spacing
  if( $sp <= 0 ){
    # no spaces if narrow width or non-breaking spaces
    $word_spacing_weight = 0;
    $line->{-wordspace} = 0;

    my $sum = $character_spacing_weight + $horizontal_scaling_weight;
    if( $sum == 0 ){
      $character_spacing_weight  = 0.5;
      $horizontal_scaling_weight = 0.5;
    }else{
      $character_spacing_weight  /= $sum;
      $horizontal_scaling_weight /= $sum;
    }
  }else{
    $line->{-wordspace} = $gap * $word_spacing_weight / $sp;
  }

  # calculate word spacing
  $line->{-charspace} = $gap * $character_spacing_weight / $char;

  # calculate horizontal scaling
  $line->{-hspace} = ( $line->{-width} - $indent ) / ( $line->{-length} + $gap * ( 1 - $horizontal_scaling_weight ) ) * 100;

  # calculate justified offsets
  my $joffset = $indent;
  for my $segment ( @{ $line->{-segments} } ){
    $segment->{-joffset} = $joffset;
    $segment->{-wordspace} = $line->{-wordspace};
    $segment->{-charspace} = $line->{-charspace};
    $segment->{-hspace} = $line->{-hspace};

    $char = length( $segment->{-text} );
    $sp   = $segment->{-text} =~ tr/\x20/\x20/;
    $joffset += $line->{-wordspace} * $sp
              + $line->{-charspace} * $char
              + $line->{-hspace} * $segment->{-length} / 100;
  }

  return;
}

# --------------------------------------
#       Name: justify_lines
#      Usage: justify_lines( $word_spacing_weight, $character_spacing_weight, $horizontal_scaling_weight, $lines );
#    Purpose: Modify the output of format_paragraph() so that the lines are fully justified.
#             See the POD for details.
# Parameters:       $word_spacing_weight -- The weight of the adjustment for word spacing.
#              $character_spacing_weight -- The weight of the adjustment for character spacing.
#             $horizontal_scaling_weight -- The weight of the adjustment for horizontal scaling.
#                                 $lines -- The output of L.
#    Returns: none
#
sub justify_lines {
  my $word_spacing_weight       = abs( shift @_ );
  my $character_spacing_weight  = abs( shift @_ );
  my $horizontal_scaling_weight = abs( shift @_ );
  my $lines                     = shift @_;

  # normalize the weights
  my $sum = $word_spacing_weight + $character_spacing_weight + $horizontal_scaling_weight;
  $word_spacing_weight       /= $sum;
  $character_spacing_weight  /= $sum;
  $horizontal_scaling_weight /= $sum;

  # first line may have an indent, so do it separately
  _justify_line( $word_spacing_weight, $character_spacing_weight, $horizontal_scaling_weight, $lines->[0], $lines->[0]{-segments}[0]{-indent} );

  for my $line ( @{ $lines }[ 1 .. $#$lines ] ){
    # don't do the last line.
    next if $line->{-last_line};

    _justify_line( $word_spacing_weight, $character_spacing_weight, $horizontal_scaling_weight, $line );
  }

  return;
}

# --------------------------------------
#       Name: print_lines
#      Usage: ( \@y_values, $lines ) = print_lines( $left, \@y_values, $lines );
#    Purpose: Print the lines created by L.
# Parameters:      $left -- Left offset for the lines.
#             \@y_values -- A list of baselines for the lines.
#                 $lines -- Formatted lines.
#    Returns: \@y_values -- Left over baselines.
#                 $lines -- Left over lines.
#
sub print_lines {
  my $left     = shift @_;
  my $y_values = shift @_;
  my $lines    = shift @_;

  while( @$y_values && @$lines ){
    my $line = shift @$lines;
    my $y = shift @$y_values;
    for my $segment ( @{ $line->{-segments} } ){
      my %opts = %$segment;
      $opts{-print} = 1;

      my $x = $segment->{-offset};
      if( exists( $segment->{-joffset} ) ){
        $x = $segment->{-joffset};
      }

      $opts{-x} = $x + $left;
      $opts{-y} = $y;
      &{ $segment->{-print_text} }( \%opts, $segment->{-text} );
    }
  }

  return ( $y_values, $lines );
}

# --------------------------------------
#       Name: print_paragraph
#      Usage: ( $bottom, \@mut ) = print_paragraph( \%print_options, \%paragraph_options, @mut );
#    Purpose: Print the paragraph.
#             This subroutine uses L to format the paragraph
#             and then determines where each segment of text should go.
#             It uses the application specified print routine to print it.
#
#             See the POD for details.
#
# Parameters:     \%print_options -- See the POD for details.
#             \%paragraph_options -- Mark-up Text for the paragraph.
#                                    Same as format_paragraph().
#                            @mut -- A list of mut to print with L.
#    Returns:             $bottom -- The bottom of the paragraph.
#                                    Can be used as the top of the next.
#                           \@mut -- A list of mut that did not fit into the paragraph.
#
sub print_paragraph {
  my %opts = ();
  while( @_ && ref( $_[0] ) eq 'HASH' ){
    my %hash = %{ shift @_ };
    @opts{keys %hash} = values %hash;
  }

  my $height = $opts{-block}[3] - $opts{-block}[1];
  my @y_values = baselines( $height, $opts{-size}, ( $opts{-spacing} || 1 ), $opts{-block}[1] );
  my $bottom = $y_values[-1] - $opts{-size} * (( $opts{-spacing} || 1 ) - 1 );

  my $width = $opts{-block}[2] - $opts{-block}[0];
  my ( $lines, $mut ) = format_paragraph( { %opts, -width=>$width, -max_lines=>scalar( @y_values ) }, @_ );

  if( $opts{-justify_word} || $opts{-justify_char} || $opts{-justify_scale} ){
    justify_lines( $opts{-justify_word} || 0, $opts{-justify_char} || 0, $opts{-justify_scale} || 0, $lines );
  }elsif( $opts{-alignment} ){
    align_lines( $opts{-alignment}, $lines );
  }

  my ( $y_values, undef ) = print_lines( $opts{-block}[0], \@y_values, $lines );
  if( @$y_values ){
    $bottom = $y_values->[0] - $opts{-size} * (( $opts{-spacing} || 1 ) - 1 );
  }

  return $bottom, $mut;
}

1;
__DATA__