/usr/local/CPAN/pod2pdf/App/pod2pdf.pm
# App::pod2pdf
#
# Copyright (C) 2007 Jon Allen <jj@jonallen.info>
#
# This software is licensed under the terms of the Artistic
# License version 2.0.
#
# For full license details, please read the file 'artistic-2_0.txt'
# included with this distribution, or see
# http://www.perlfoundation.org/legal/licenses/artistic-2_0.html
package App::pod2pdf;
use strict;
use warnings;
use Carp;
use List::Util qw/max min/;
use PDF::API2;
use Pod::Escapes qw/e2char/;
use Pod::Parser;
use Pod::ParseLink;
use constant TRUE => 1;
use constant FALSE => 0;
BEGIN {
our @ISA = qw/Pod::Parser/;
our $VERSION = '0.42';
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my %user_options = @_;
my %default_options = (
header => TRUE, # Include header on all pages
footer => TRUE, # Include footer on all pages
page_width => 595, # A4
page_height => 842, # A4
left_margin => $user_options{margins} || 48, # 0.75"
right_margin => $user_options{margins} || 48, # 0.75"
top_margin => $user_options{margins} || 60, #
bottom_margin => $user_options{margins} || 60, #
font_face => 'Helvetica', # Sans-Serif text
font_size => 10, # Text size = 10 points
icon_scale => 0.25, # Icon scaling (%age)
);
my $self = $class->SUPER::new(%default_options,%user_options);
$self->create_pdf;
return $self;
}
#-----------------------------------------------------------------------
sub command {
my ($self, $command, $paragraph, $line_num) = @_;
my $expansion = $self->interpolate($paragraph, $line_num);
COMMAND: {
if ($command eq 'ff') {
$self->formfeed if ($self->print_flag);
}
if ($command =~ /^head[1234]$/) {
$self->indent(0);
$self->set_style('default');
$self->newline;
my $default_space = $self->{line_spacing};
$self->set_style($command);
my $heading_space = $self->{line_spacing};
# Checks to see if there is space for a content line after
# the heading - if not then starts a new page
if ( ($self->{y_position} - $heading_space - $default_space - $self->{spacer}) <
($self->{bottom_margin} + $self->{footer_height}) ) {
$self->formfeed;
} else {
$self->{y_position} -= ($heading_space - $default_space);
}
$self->print_text_with_style($expansion,$command);
$self->spacer;
$self->indent(48);
}
if ($command eq 'over') {
my $indentlevel = $expansion || 4;
$self->set_style;
$self->push_indent($indentlevel * $self->em);
$self->reset_item_textblock_flag;
}
if ($command eq 'back') {
$self->pop_indent;
$self->spacer;
}
if ($command eq 'item') {
$self->spacer if ($self->item_textblock_flag);
$self->reset_item_textblock_flag;
if ($expansion =~ '^\s*\*?\s*$') {
# First check to see if there is space for any text
if ($self->{y_position} - $self->{line_spacing} < ($self->{bottom_margin} + $self->{footer_height})) {
$self->formfeed;
}
my $indent = $self->pop_indent;
$self->bullet($indent);
$self->push_indent($indent);
} elsif ($expansion =~ '^\s*(\d+\.?)\s*$') {
# First check to see if there is space for any text
if ($self->{y_position} - $self->{line_spacing} < ($self->{bottom_margin} + $self->{footer_height})) {
$self->formfeed;
}
my $indent = $self->pop_indent;
$self->{y_position} -= $self->{line_spacing};
$self->print_text_with_style($1,'default');
$self->push_indent($indent);
$self->{y_position} += $self->{line_spacing};
} else {
my $indent = $self->pop_indent;
$self->set_style;
$self->newline;
$self->parse_text({-expand_ptree => 'print_tree'},$paragraph,$line_num);
$self->spacer;
$self->push_indent($indent);
}
}
}
}
#-----------------------------------------------------------------------
sub verbatim {
my ($self, $paragraph, $line_num) = @_;
if ($paragraph =~ /^[ \t]/) {
$self->set_style('verbatim');
$self->reset_space_flag;
$self->set_item_textblock_flag;
foreach my $line (split /\n/,$paragraph) {
# todo: expand tabs
if ($line =~ /\S/) {
$self->newline;
$self->print_text_with_style($line,'verbatim');
$self->reset_space_flag;
}
}
$self->newline;
$self->spacer unless ($self->over);
}
}
#-----------------------------------------------------------------------
sub textblock {
my ($self, $text, $line_num) = @_;
if ($text =~ /\S/) { # ignore blank paragraphs
$self->set_item_textblock_flag;
$self->reset_space_flag;
$self->set_style;
$self->newline;
$self->parse_text({-expand_ptree => 'print_tree'},$text,$line_num);
$self->spacer;
$self->spacer unless ($self->over);
}
}
#-----------------------------------------------------------------------
sub interior_sequence {
my ($self,$command,$text) = @_;
#
# need to check content of $text, i.e.
# is there a nested formatting command?
#
# also this doesn't handle the L<> formatting
# command, check with perlpodspec if this is
# allowed in =head blocks
#
COMMAND: {
if ($command eq 'X') {
# no-op
last COMMAND;
}
if ($command eq 'Z') {
# no-op
last COMMAND;
}
if ($command eq 'E') {
return e2char($text);
}
DEFAULT: {
return $text;
}
}
}
#-----------------------------------------------------------------------
sub print_tree {
my $self = shift;
my $tree = shift;
NODE: foreach my $node ($tree->children) {
if (ref $node) {
COMMAND: {
my $command = $node->cmd_name;
if ($command eq 'L') {
#warn("Found link: ".$node->raw_text."\n");
my $left_delimiter = $node->left_delimiter;
my $right_delimiter = $node->right_delimiter;
(my $link_text = $node->raw_text) =~ s/L$left_delimiter\s*(.*?)\s*$right_delimiter$/$1/s;
my ($text, $inferred, $name, $section, $type) = parselink($link_text);
$text =~ s/^"(.*?)"$/$1/ if ($text);
$inferred =~ s/^"(.*?)"$/$1/ if ($inferred);
$name =~ s/^"(.*?)"$/$1/ if ($name);
$self->push_format('I');
$self->parse_text({-expand_ptree => 'print_tree'},($text || $inferred || $name));
$self->pop_format;
last COMMAND;
}
if ($command eq 'O') {
my $left_delimiter = $node->left_delimiter;
my $right_delimiter = $node->right_delimiter;
(my $object_text = $node->raw_text) =~ s/O$left_delimiter\s*(.*?)\s*$right_delimiter$/$1/;
my ($object_title,$object_location) = parseobject($object_text);
if ($object_location =~ /\A\W+:[^:\s]\S*\z/) {
# URL - cannot load (yet!)
$self->warnonce('HTTP object loading not supported');
$self->print_text_with_style($object_location,'I');
} elsif (-e $object_location) {
# Found file
if ($self->images) {
my $mime_type = File::Type->new->mime_type($object_location);
if ($mime_type =~ /^image/) {
unless ($self->insert_image($object_location)) {
$self->print_text_with_style($object_location,'I');
}
} else {
$self->print_text_with_style($object_location,'I');
}
} else {
$self->print_text_with_style($object_location,'I');
}
} else {
# Non-existant file
$self->warnonce("Object not found: $object_location");
$self->print_text_with_style("Object not found: $object_location",'I');
}
last COMMAND;
}
if ($command eq 'X') {
# no-op
}
DEFAULT: {
$self->push_format($node->cmd_name);
$self->print_tree($node->parse_tree);
$self->pop_format;
}
}
} else {
FORMAT: {
$_ = $self->format;
if (/X/) {
# no-op
last FORMAT;
}
if (/Z/) {
# no-op
last FORMAT;
}
if (/E/) {
$node = e2char($node);
}
if (/BC.*I/) {
$self->print_text_with_style($node,'BCI');
last FORMAT;
}
if (/C.*I/) {
$self->print_text_with_style($node,'CI');
last FORMAT;
}
if (/B.*I/) {
$self->print_text_with_style($node,'BI');
last FORMAT;
}
if (/BC/) {
$self->print_text_with_style($node,'BC');
last FORMAT;
}
if (/B/) {
$self->print_text_with_style($node,'B');
last FORMAT;
}
if (/C/) {
$self->print_text_with_style($node,'C');
last FORMAT;
}
if (/I/) {
$self->print_text_with_style($node,'I');
last FORMAT;
}
DEFAULT: {
#warn "Line 414: $_\n";
$self->print_text_with_style($node,'default');
last FORMAT;
}
}
}
}
}
#-----------------------------------------------------------------------
sub insert_image {
my $self = shift;
my $filename = shift;
if ($self->images) {
if (-e $filename) {
my $image;
my $type = File::Type->new->checktype_filename($filename);
SWITCH: {
if ($type eq 'image/jpeg') {$image = $self->{pdf}->image_jpeg($filename); last}
if ($type eq 'image/tiff') {$image = $self->{pdf}->image_tiff($filename); last}
if ($type eq 'image/gif') {$image = $self->{pdf}->image_gif($filename); last}
if ($type eq 'image/x-png') {$image = $self->{pdf}->image_png($filename); last}
if ($type eq 'image/x-pnm') {$image = $self->{pdf}->image_pnm($filename); last}
$self->warnonce("[Warning] Unknown image format '$type' for image '$filename'");
return FALSE;
}
unless ($image) {
$self->warnonce("[Warning] Cannot load image file '$filename'");
return FALSE;
}
my ($width,$height) = imgsize($filename);
my $available_width = $self->{page_width} - $self->{right_margin} - $self->{x_position};
my $scale_default = 0.5;
my $scale_min = 0.4;
my $scale = min($available_width / $width, $scale_default);
my $height_in_points = $height * $scale;
if ($self->{y_position} < ($self->{bottom_margin} + $self->{footer_height} + $height_in_points + ($self->{line_spacing} / 2))) {
my $available_height = $self->{y_position} - $self->{bottom_margin} - $self->{footer_height} - $self->{line_spacing};
if ($available_height / $height > $scale_min) {
$scale = $available_height / $height;
$height_in_points = $height * $scale;
} else {
$self->formfeed;
$self->set_print_flag;
}
}
$self->{y_position} -= $height_in_points;
$self->{y_position} += ($self->{line_spacing} / 2);
$self->{gfx} = $self->{page}->gfx unless (exists $self->{gfx});
$self->{gfx}->image($image,$self->{x_position},$self->{y_position},$scale);
return TRUE;
} else {
$self->warnonce("Image '$filename' does not exist");
return FALSE;
}
}
}
#-----------------------------------------------------------------------
sub images {
my $self = shift;
unless ($self->{image_modules_check}) {
# Check if image modules are installed
eval "use File::Type;use Image::Size;";
if ($@) {
$self->warnonce('Cannot use images, modules Image::Size and/or File::Type not installed');
} else {
$self->{image_modules_loaded} = TRUE;
}
$self->{image_modules_check} = TRUE;
}
return $self->{image_modules_loaded};
}
#-----------------------------------------------------------------------
sub warnonce {
my $self = shift;
my $warning = shift;
unless ($self->{issued_warnings}->{$warning}) {
warn("[Warning] $warning\n");
$self->{issued_warnings}->{$warning} = TRUE;
}
}
#-----------------------------------------------------------------------
sub parseobject {
# Parses the O<...> formatting code as specified in perlpodextensions
my $object_text = shift;
if ($object_text =~ /(.*?)\|(.*)/) {
return ($1,$2);
} else {
return (undef,$object_text);
}
}
#-----------------------------------------------------------------------
sub create_pdf {
my $self = shift;
my $class = ref $self;
my $version = $::{$class.'::'}{VERSION} ? ${ $::{$class.'::'}{VERSION} } : 'unknown';
# Define styles
#
# Future enhancement: move the style definitions into a separate
# module (e.g. Pod::Pdf::Styles) which can be subclassed to allow
# non-core fonts to be used.
#
$self->{stylist} = {
'header' => {font=>'Helvetica-Bold', size=>10 },
'footer' => {font=>'Helvetica-Bold', size=>10 },
'head1' => {font=>'Helvetica-Bold', size=>12 },
'head2' => {font=>'Helvetica-Bold', size=>11 },
'head3' => {font=>'Helvetica-Bold', size=>10 },
'head4' => {font=>'Helvetica', size=>10 },
'verbatim' => {font=>'Courier', verbatim=>TRUE },
'B' => {font=>'Helvetica-Bold' },
'BC' => {font=>'Courier-Bold', verbatim=>TRUE },
'BI' => {font=>'Helvetica-BoldOblique' },
'BCI' => {font=>'Courier-BoldOblique', verbatim=>TRUE },
'C' => {font=>'Courier', verbatim=>TRUE },
'CI' => {font=>'Courier-Oblique', verbatim=>TRUE },
'I' => {font=>'Helvetica-Oblique' },
};
# Set up first page
PAGE_SIZE: {
if ($self->{page_size}) {
eval "use Paper::Specs 0.10 units=>'pt';";
if ($@) {
$self->warnonce("Cannot use '--page-size' option, module Paper::Specs (v0.10) not installed");
} else {
if (my $form = Paper::Specs->find(code=>$self->{page_size}, brand=>'standard')) {
$self->{page_width} = int($form->sheet_width + 0.5);
$self->{page_height} = int($form->sheet_height + 0.5);
} else {
$self->warnonce("Unknown page size '".$self->{page_size}."'");
}
}
}
}
PAGE_ORIENTATION: {
if ($self->{page_orientation}) {
if (lc $self->{page_orientation} eq 'landscape') {
($self->{page_width},$self->{page_height}) = (
max($self->{page_width},$self->{page_height}),
min($self->{page_width},$self->{page_height})
);
last PAGE_ORIENTATION;
}
if (lc $self->{page_orientation} eq 'portrait') {
($self->{page_width},$self->{page_height}) = (
min($self->{page_width},$self->{page_height}),
max($self->{page_width},$self->{page_height})
);
last PAGE_ORIENTATION;
}
$self->warnonce("Unknown page orientation '".$self->{page_orientation}."', must be 'portrait' or 'landscape'");
}
}
$self->{page_number} = 0;
$self->{line_spacing} = $self->{font_size}+2 unless ($self->{line_spacing});
$self->{x_position} = $self->{left_margin};
$self->{y_position} = $self->{page_height} - $self->{top_margin};
$self->{indent} = 0;
$self->{pdf} = PDF::API2->new;
$self->{pdf}->info('Producer'=>"$class version $version");
$self->{pdf}->mediabox($self->{page_width},$self->{page_height});
if ($self->{icon} && $self->images) {
if (-e $self->{icon}) {
my $type = File::Type->new->checktype_filename($self->{icon});
SWITCH: {
if ($type eq 'image/jpeg') {$self->{icon_img} = $self->{pdf}->image_jpeg($self->{icon}); last}
if ($type eq 'image/tiff') {$self->{icon_img} = $self->{pdf}->image_tiff($self->{icon}); last}
if ($type eq 'image/gif') {$self->{icon_img} = $self->{pdf}->image_gif($self->{icon}); last}
if ($type eq 'image/x-png') {$self->{icon_img} = $self->{pdf}->image_png($self->{icon}); last}
if ($type eq 'image/x-pnm') {$self->{icon_img} = $self->{pdf}->image_pnm($self->{icon}); last}
warn "[Warning] Unknown image format '$type' for icon ".$self->{icon}."\n";
}
if ($self->{icon_img}) {
($self->{icon_width},$self->{icon_height}) = imgsize($self->{icon});
}
} else {
warn("[Warning] Cannot open icon file: ".$self->{icon}."\n");
}
}
$self->formfeed;
$self->set_style;
$self->{indent} = 0;
$self->{over} = 0;
$self->{spacer} = 4; # default spacing between paragraphs
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Item_textblock_flag methods
#
# This flag is used to control line spacing within =over sections. The
# flag is cleared after each =item command and set whenever a textblock
# is printed.
#
# At the start of processing an =item command, an extra half line space
# (4 points) is inserted if the textblock flag is set. Because half
# spacing is the default in =over sections, this extra space between
# individual =items acts to visually group the =item paragraphs as a
# single element.
#-----------------------------------------------------------------------
sub item_textblock_flag {
my $self = shift;
return $self->{item_textblock_flag}->{$self->over} || 0;
}
#-----------------------------------------------------------------------
sub set_item_textblock_flag {
my $self = shift;
$self->{item_textblock_flag}->{$self->over} = TRUE;
}
#-----------------------------------------------------------------------
sub reset_item_textblock_flag {
my $self = shift;
$self->{item_textblock_flag}->{$self->over} = FALSE;
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Print_flag methods
#
# The Print flag is used to prevent blank lines from appearing at the
# start of a page, which can happen if a verbatim block or =over list
# crosses a page break.
#
# When a new page is started, the print flag is reset. In this state
# any calls to newline() or spacer() will have no effect. Whenever any
# text is printed, the print flag will be set, then newlines will
# operate nomally.
#-----------------------------------------------------------------------
sub print_flag {
my $self = shift;
return $self->{print_flag} || 0;
}
#-----------------------------------------------------------------------
sub set_print_flag {
my $self = shift;
$self->{print_flag} = TRUE;
}
#-----------------------------------------------------------------------
sub reset_print_flag {
my $self = shift;
$self->{print_flag} = FALSE;
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Space_flag methods
#
# The space flag is used to prevent the display of whitespace characters
# at the end of a paragraph. If these characters are not suppressed,
# then occasionally they will wrap onto the next line, causing unsightly
# spaces in the finished document.
#
# Each string presented to the print_text_with_style() method is checked
# for trailling whitespace. If so, the space_flag is set. At the next
# call to print_text_with_style(), an extra space character is printed
# if the space_flag is set. The space_flag is cleared either when the
# spacer() method is called (to mark the 'real' end of a text block), or
# after the flag has caused a new space to be inserted.
#-----------------------------------------------------------------------
sub space_flag {
my $self = shift;
return $self->{space_flag} || 0;
}
#-----------------------------------------------------------------------
sub set_space_flag {
my $self = shift;
$self->{space_flag} = TRUE;
}
#-----------------------------------------------------------------------
sub reset_space_flag {
my $self = shift;
$self->{space_flag} = FALSE;
}
#-----------------------------------------------------------------------
sub flag {
my $self = shift;
my $flag = shift or return FALSE;
return $self->{flags}->{$flag} || FALSE;
}
#-----------------------------------------------------------------------
sub set_flag {
my $self = shift;
my $flag = shift or return FALSE;
$self->{flags}->{$flag} = TRUE;
}
#-----------------------------------------------------------------------
sub clear_flag {
my $self = shift;
my $flag = shift or return FALSE;
$self->{flags}->{$flag} = FALSE;
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Text indent methods
#-----------------------------------------------------------------------
sub indent {
# Sets the current indent (measured in points)
my $self = shift;
$self->{indent} = shift;
$self->{x_position} = $self->{left_margin} + $self->{indent};
}
#-----------------------------------------------------------------------
sub over {
# Returns the current number of nested =over blocks
my $self = shift;
return $self->{over};
}
#-----------------------------------------------------------------------
sub em {
# Returns the width (in points) of an 'm' character, used by =over X
# to decide how much to indent by
my $self = shift;
return $self->{mspace};
}
#-----------------------------------------------------------------------
sub push_indent {
my $self = shift;
my $indent = shift;
push @{$self->{indent_list}},$indent;
$self->indent($self->{indent} + $indent);
$self->{over}++;
}
#-----------------------------------------------------------------------
sub pop_indent {
my $self = shift;
$self->{over}--;
if (@{$self->{indent_list}}) {
my $indent = pop @{$self->{indent_list}};
$self->indent($self->{indent} - $indent);
return $indent;
} else {
return 0;
}
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Text format methods
#
# During parsing, as each Pod::InteriorSequence object is encountered
# the formatting code (B, I, etc) is pushed onto a stack. When the
# parser gets to the individual text elements, the format() method will
# return the complete set of codes which need to be applied to the text.
#-----------------------------------------------------------------------
sub push_format {
my $self = shift;
my $format = shift;
push @{$self->{format}},$format;
}
#-----------------------------------------------------------------------
sub pop_format {
my $self = shift;
return pop @{$self->{format}} if (@{$self->{format}});
}
#-----------------------------------------------------------------------
sub format {
# Returns the current text format as a scalar, e.g. 'BEI' for Bold
# Italic with Escapes to be processed. Formatting codes are listed in
# alphabetical order with duplicates removed.
my $self = shift;
my %format;
foreach (@{$self->{format}}) {
# Treat F<> as a synonym for I<> (renders filenames in italic)
tr/F/I/;
$format{$_}++;
}
return join '',sort keys %format;
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
sub bullet {
# Draws a bullet point (filled circle) at the current text position
#
# Todo: need to remove the integer values here and replace with
# percentages of the current line spacing to handle different fonts
my $self = shift;
my $indent = shift;
my $bullet = $self->{page}->gfx;
my $x_coord = $self->{left_margin} + $self->{indent} + 4 + $indent - 20;
my $y_coord = $self->{y_position} - 9 + ($self->print_flag ? 0 : $self->{line_spacing});
my $radius = 2;
$bullet->circle($x_coord,$y_coord,$radius);
$bullet->fillstroke;
}
#-----------------------------------------------------------------------
sub newline {
my $self = shift;
if ($self->print_flag) {
$self->linefeed;
$self->set_flag('newline');
}
}
#-----------------------------------------------------------------------
sub linefeed {
my $self = shift;
$self->{y_position} -= $self->{line_spacing};
$self->{x_position} = $self->{left_margin} + $self->{indent};
if ($self->{y_position} < ($self->{bottom_margin} + $self->{footer_height})) {
my $style = $self->{style};
$self->formfeed;
$self->set_style($style);
}
}
#-----------------------------------------------------------------------
sub spacer {
my $self = shift;
$self->reset_space_flag;
if ($self->print_flag) {
$self->{y_position} -= $self->{spacer};
$self->{x_position} = $self->{left_margin} + $self->{indent};
if ($self->{y_position} < ($self->{bottom_margin} + $self->{footer_height})) {
$self->formfeed;
}
}
}
#-----------------------------------------------------------------------
sub formfeed {
my $self = shift;
$self->{page} = $self->{pdf}->page;
$self->{x_position} = $self->{left_margin} + $self->{indent};
$self->{page_number}++;
delete $self->{text};
delete $self->{gfx};
$self->{gfx} = $self->{page}->gfx;
$self->{text} = $self->{page}->text;
$self->{y_position} = $self->{page_height} - $self->{top_margin} - $self->{line_spacing};
$self->{header_height} = ($self->{header}) ? $self->generate_header : 0;
$self->{footer_height} = ($self->{footer}) ? $self->generate_footer : 0;
$self->{y_position} -= $self->{header_height};
$self->reset_print_flag;
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Page header and footer methods
#
# Future enhancement: pass the page number, filename, etc details as
# parameters to generate_header() and generate_footer(), allow these
# methods to be overridden by the user for custom page formatting.
#-----------------------------------------------------------------------
sub generate_header {
my $self = shift;
$self->set_style('header');
my $header_padding = 2;
my $header_spacing = 3;
my $header_height = $self->{text_size} + $header_spacing + $header_padding;
# Draw header icon
if ($self->{icon_img}) {
my $icon_height_in_points = $self->{icon_height} * $self->{icon_scale};
if ($icon_height_in_points > $self->{text_size}) {
$header_height += ($icon_height_in_points - $self->{text_size});
}
my $ypos = $self->{page_height} - $self->{top_margin} - $icon_height_in_points;
$self->{gfx}->image($self->{icon_img},$self->{left_margin},$ypos,$self->{icon_scale});
}
# Add page title
my $x = $self->{page_width} - $self->{right_margin} - $self->{text}->advancewidth($self->{title});
my $y = $self->{page_height} - $self->{top_margin} - $header_height + $header_spacing + $header_padding;
$self->{text}->textlabel($x,$y,$self->{fontcache}->{$self->{font}},$self->{text_size},$self->{title});
# Draw horizontal line
$self->{gfx}->move($self->{left_margin},$self->{page_height}-$self->{top_margin}-$header_height + $header_padding);
$self->{gfx}->line($self->{page_width}-$self->{right_margin},$self->{page_height}-$self->{top_margin}-$header_height + $header_padding);
$self->{gfx}->stroke;
return $header_height;
}
#-----------------------------------------------------------------------
sub generate_footer {
my $self = shift;
$self->set_style('footer');
# Add page footer
my $t = 'Page '.$self->{page_number};
my $x = $self->{page_width} - $self->{right_margin} - $self->{text}->advancewidth($t);
my $y = $self->{bottom_margin};
$self->{text}->textlabel($x,$y,$self->{fontcache}->{$self->{font}},$self->{text_size},$t);
if ($self->{footer_text}) {
$x = $self->{left_margin};
$self->{text}->textlabel($x,$y,$self->{fontcache}->{$self->{font}},$self->{text_size},$self->{footer_text});
}
$self->{gfx} = $self->{page}->gfx unless (exists $self->{gfx});
$self->{gfx}->move($self->{left_margin},$self->{bottom_margin}+10);
$self->{gfx}->line($self->{page_width}-$self->{right_margin},$self->{bottom_margin}+10);
$self->{gfx}->stroke;
return 18; # Footer height in points
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# PDF file output
#
# When the PDF object goes out of scope, the generated PDF file will be
# printed to STDOUT.
#
# Update - this doesn't work with PAR, need explicit $pdf->output() method
#-----------------------------------------------------------------------
sub output {
my $self = shift;
print $self->{pdf}->stringify;
#$self->{pdf}->end;
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Text printing methods
#-----------------------------------------------------------------------
sub print {
my $self = shift;
my $text = shift;
$self->newline;
$self->print_text_with_style($text);
}
#-----------------------------------------------------------------------
sub print_text_with_style {
my $self = shift;
my $text = shift;
my $style = shift;
#warn "print_text_with_style called with style '$style', text '$text'\n";
$self->set_style($style);
# Remove double spaces unless we are printing verbatim text
unless ($self->{stylist}->{$self->{style}}->{verbatim}) {
$text =~ s/(\s)\s+/$1/g;
}
if ($self->space_flag) {
#
# Note that this space appears in the default style,
# but it should be printed in the previous style.
#
$self->reset_space_flag;
$self->set_style('default');
$self->print_word(' ');
$self->set_style($style);
}
if ($text =~ s/\s+$//) {
$self->set_space_flag;
}
while ($text =~ /(\s+|\S+)/g) {
my $word = $1;
$self->print_word($word);
}
}
#-----------------------------------------------------------------------
sub print_word {
my $self = shift;
my $word = shift;
# If we are at the start of a line (newline flag is set) and we are
# NOT printing verbatim text, then suppress any whitespace.
if ($self->flag('newline')) {
#warn "newline flag set\n";
#warn "x position = $self->{x_position}\n";
}
$self->set_print_flag;
$self->clear_flag('newline');
my $width = $self->{text}->advancewidth($word);
if ($self->{x_position} + $width > $self->{page_width} - $self->{right_margin}) {
# If the word will not fit on one line, split it up and recurse the 'print_word' sub
if ($width > ($self->{page_width} - $self->{left_margin} - $self->{right_margin} - $self->{indent})) {
my $fit = int(($self->{page_width} - $self->{left_margin} - $self->{right_margin} - $self->{indent}) / $self->{nspace});
my @words = (substr($word,0,$fit),substr($word,$fit));
#warn "Recursing... Word=$word Fit=$fit Xpos=$$self{x_position}\n";
$self->print_word($_) foreach @words;
return;
}
$self->newline;
if ($word =~ /^\s+$/) {
unless ($self->{stylist}->{$self->{style}}->{verbatim}) {
return;
}
}
}
$self->{x_position} += $self->{text}->textlabel($self->{x_position},
$self->{y_position},
$self->{fontcache}->{$self->{font}},
$self->{text_size},
$word,
-color => $self->{text_color});
if ($self->{x_position} > $self->{page_width} - $self->{right_margin}) {
$self->newline;
}
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
# Text style methods
#-----------------------------------------------------------------------
sub set_style {
my $self = shift;
my $style = shift || 'default';
$style = (exists $self->{stylist}->{$style}) ? $style : 'default';
#carp "Setting style to $style";
# Create font object if necessary
my $font = ($self->{stylist}->{$style}->{font} || $self->{font_face}) .
((exists $self->{stylist}->{$style}->{type}) ? '-'.$self->{stylist}->{$style}->{type} : '');
unless (exists $self->{fontcache}->{$font}) {
$self->{fontcache}->{$font} = $self->{pdf}->corefont($font);
}
$self->{style} = $style;
$self->{font} = $font;
$self->{text_color} = $self->{stylist}->{$style}->{color} || '#000000';
$self->{text_size} = $self->{stylist}->{$style}->{size} || $self->{font_size};
$self->{text}->font($self->{fontcache}->{$font},$self->{text_size});
$self->{nspace} = $self->{text}->advancewidth('n');
$self->{mspace} = $self->{text}->advancewidth('m');
}
#-----------------------------------------------------------------------
#-----------------------------------------------------------------------
1;