File Coverage

blib/lib/Tk/Enscript.pm

Criterion	Covered	Total	%
statement	1	3	33.3
branch			n/a
condition			n/a
subroutine	1	1	100.0
pod			n/a
total	2	4	50.0

# -*- perl -*-

#
# $Id: Enscript.pm,v 1.10 2007/10/29 22:57:00 eserte Exp $
# Author: Slaven Rezic
#
# Copyright (C) 1998,2007 Slaven Rezic. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# Mail: [e-mail]
# WWW:  http://www.sourceforge.net/projects/srezic
#

package Tk::Enscript;
use Tk;
use Text::Tabs;
require Exporter;

use strict;
use vars qw(%media %postscript_to_x11_font
	    $VERSION @ISA @EXPORT);

@ISA = qw(Exporter);
@EXPORT = qw(enscript);

$VERSION = sprintf "%d.%02d", q$Revision: 1.10 $ =~ /(\d+)\.(\d+)/;

parse_cfg();

sub enscript {
    my($top, %args) = @_;

    my $external = $args{-external};

    if (!$args{'-columns'}) {
	$args{'-columns'} = 1;
    }

    if (defined $external and $external eq 'best') {
	if (_is_in_path("enscript")) {
	    $external = "enscript";
	} elsif (_is_in_path("a2ps")) {
	    $external = "a2ps";
	} else {
	    undef $external;
	}
    }
    if (defined $external) {
	if ($external eq 'enscript') {
	    return ext_enscript(%args);
	} elsif ($external eq 'a2ps') {
	    return ext_a2ps(%args);
	} else {
	    die "Unknown external program $external";
	}
    }

    my $fontname = $args{-font};
    my $output   = $args{-output} || "/tmp/enscript.%d.ps";
    my $filename = $args{-file};
    my $text     = $args{-text};

    my $media    = $args{-media} || 'A4';
    die "Unknown media $media" if !exists $media{$media};
    my %media_desc = %{$media{$media}};

    my $width  = $args{-width}  || $media_desc{Width};
    my $height = $args{-height} || $media_desc{Height};

    my $t = $top->Toplevel;
    my $c = $t->Canvas(-width => $width, -height => $height);
    $t->withdraw;

    my($llx, $lly, $urx, $ury) = @{$args{-bbox}} if exists $args{-bbox};

    $llx = $args{-llx} || $media_desc{LLX};
    $lly = $args{-lly} || $media_desc{LLY};
    $urx = $args{-urx} || $media_desc{URX};
    $ury = $args{-ury} || $media_desc{URY};

    my $uly = $height - $ury;	# XXX unsure
    my $lry = $height - $lly;

    my $y = $uly;

    my $font = x11_font_to_tk_font($t, postscript_to_x11_font($fontname || 'Courier12'));

    my $page = 0;
    my $line;

    my $ps_output_sub = sub {
	$c->update;
	$c->postscript(-file => sprintf($output, $page),
		       -pagewidth => $width,
		       -pageheight => $height,
		       -width => $width,
		       -height => $height);
	$y = $uly;
	$page++;
	$c->delete('all');
    };

    if (defined $filename) {
	$text = _read_file($filename);
    }

    my $try_again = 0;
    foreach $line (split(/\n/, $text)) {
	$line = expand($line);
	my $i;
	my @text_args = ($llx, $y,
			 -width => $urx-$llx,
			 -text => $line, -anchor => 'nw',
			);
	eval {
	    $i = $c->createText(@text_args,
				-font => $font,
			       );
	};
	warn $@ if $@;
	if (!defined $i) {
	    warn "Can't get font <$font>, fallback to default font.\n";
	    $i = $c->createText(@text_args);
	}
	$y = ($c->bbox($i))[3];
	if ($y > $lry && !$try_again) {
	    $c->delete($i);
	    $ps_output_sub->();
	    $try_again++;
	    redo;
	}
	$try_again = 0;
    }

    $ps_output_sub->();
    $c->destroy;

    ($output, $page-1);		# gibt Output-Dateiname und Anzahl der Seiten zurück
}

sub _read_file {
    my $filename = shift;
    my $text;
    open(F, $filename) or die "Can't open $filename: $!";
    local($/) = undef;
    $text = ;
    close F;
    $text;
}

sub parse_cfg {
    my $cfg_file = shift;
    my @cfg_files = (Tk->findINC('enscript.cfg'));
    if (!defined $cfg_file) {
	my $home_dir = eval { local $SIG{__DIE__};
			      (getpwuid($<))[7];
			  } || $ENV{'HOME'} || '';
	my $pers_cfg_file = "$home_dir/.enscriptrc";
	if (-f $pers_cfg_file && -r $pers_cfg_file) {
	    $cfg_file = $pers_cfg_file;
	}
    }
    if (defined $cfg_file) {
	push @cfg_files, $cfg_file;
    }
    if (!@cfg_files) {
	die "Can't found any configuration enscript.cfg.";
    }

    %media = ();
    %postscript_to_x11_font = ();

    for my $cfg_file (@cfg_files) {
	open(CFG, $cfg_file)
	    or die "Can't open config file <$cfg_file>: $!";
	while() {
	    s/\s*\#.*//;
	    next if /^\s*$/;
	    if (/^\s*Media:\s*(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)\s+(\S+)/) {
		$media{$1} = {Width  => $2,
			      Height => $3,
			      LLX    => $4,
			      LLY    => $5,
			      URX    => $6,
			      URY    => $7};
	    } elsif (/^\s*FontMap:\s*(\S+)\s+(.*)/) {
		$postscript_to_x11_font{$1} = $2;
	    } else {
		#warn "Can't parse $_";
	    }
	}
	close CFG;
    }
}

sub postscript_to_x11_font {
    my($psfont) = @_;
    my $x11font;
    if ($psfont !~ /^(.*?)(\d+)?$/) {
	die "Can't parse postscript font $psfont";
    }
    my($font, $size) = (lc($1), $2);
    if (!defined $size) { $size = 10 }
    my $x11font_fmt = $postscript_to_x11_font{$font};
    if (!defined $x11font_fmt) {
	die "No X11 font for $font defined";
    }
    $x11font = sprintf($x11font_fmt, $size*10);
    $x11font;
}

sub x11_font_to_tk_font {
    my($t, $x11font) = @_;

    my $Font;
    if ($Tk::VERSION >= 800.012) {
	require Tk::X11Font;
	$Font = 'Tk::X11Font';
    } else {
	require Tk::Font;
	$Font = 'Tk::Font';
    }

    my $font = new $Font($t, $x11font);

    $font;
}

sub ext_enscript {
    my(%args) = @_;
    my @cmd = ("enscript");
    if ($args{'-columns'}) {
	push @cmd, "--columns", $args{'-columns'};
    }
    if ($args{'-header'}) {
	push @cmd, "--header", $args{'-header'};
    }
    if ($args{'-font'}) {
	push @cmd, "--font", $args{'-font'};
    }
    if ($args{'-output'}) {
	push @cmd, "--output", $args{'-output'};
    }
    print STDERR "Cmd: " . join(" ", @cmd) . "\n" if $args{-verbose};
    if ($args{'-file'}) {
	system(@cmd, $args{'-file'});
    } else {
	require IO::Pipe;
	my $pipe = IO::Pipe->new;
	$pipe->writer(@cmd);
	$pipe->print($args{'-text'});
	$pipe->close;
    }
    ($args{'-output'}, 1);
}

sub ext_a2ps {
    my(%args) = @_;

    die "Sorry, a2ps is not supported anymore\n";

    my @cmd = ("a2ps", #"-8",
	       "--output=-");
    if ($args{'-columns'} =~ /^[12]$/) {
	push @cmd, "--columns=" . $args{'-columns'};
    }
    if ($args{'-font'} and $args{'-font'} =~ /(\d+)$/) {
	push @cmd, "--font-size=". $1;
    }
    if ($args{'-header'}) {
	push @cmd, "--header=".$args{'-header'};
    } else {
	push @cmd, "--no-header";
    }
    # "-nP" würde ich auch gerne setzen, existiert aber nicht?!
#XXX?    push @cmd, "-ns", "-nu", "-nL";

    my $tmpfile;
    if (!$args{'-file'}) {
	$tmpfile = "/tmp/tkenscript-a2ps.$$.txt"; # XXX better solution?
	open(TMP, ">$tmpfile")
	  or die "Can't write to tempory file $tmpfile: $!";
	print TMP $args{'-text'};
	close TMP;
	$args{'-file'} = $tmpfile;
    }
    push @cmd, $args{'-file'};
    require IO::Pipe;
    my $pipe = IO::Pipe->new;
    print STDERR "Cmd: " . join(" ", @cmd) . "\n" if $args{-verbose};
    $pipe->reader(@cmd);
    open(OUT, ">$args{-output}") or die "Can't write to $args{-output}: $!";
    while(<$pipe>) {
	print OUT $_;
    }
    close OUT;
    $pipe->close;

    unlink $tmpfile if defined $tmpfile;

    ($args{'-output'}, 1);
}

sub _is_in_path {
    my($prog) = @_;
    require Config;
    my $sep = $Config::Config{'path_sep'} || ':';
    foreach (split(/$sep/o, $ENV{PATH})) {
	return $_ if -x "$_/$prog";
    }
    undef;
}

1;

=head1 NAME

Tk::Enscript - a text-to-postscript converter using Tk::Canvas

=head1 SYNOPSIS

    use Tk::Enscript;

    enscript($top,
	     -text   => $text,
	     -media  => 'A4',
	     -output => "/tmp/bla.%d.ps",
    );

=head1 DESCRIPTION

=head1 AUTHOR

Slaven Rezic

=head1 COPYRIGHT

Copyright (c) 1998 Slaven Rezic. All rights reserved.
This module is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L, L, L

=cut