#! /usr/bin/perl -w
use
vars
qw($VERSION @ISA @EXPORT)
;
@ISA
=
qw(Exporter)
;
@EXPORT
=
qw()
;
$VERSION
=
'0.06p3'
;
my
%pscolours
= (
black
=>
"0 0 0"
,
brightred
=>
"1 0 0"
,
brightgreen
=>
"0 1 0"
,
brightblue
=>
"0 0 1"
,
red
=>
"0.8 0 0"
,
green
=>
"0 0.8 0"
,
blue
=>
"0 0 0.8"
,
darkred
=>
"0.5 0 0"
,
darkgreen
=>
"0 0.5 0"
,
darkblue
=>
"0 0 0.5"
,
grey10
=>
"0.1 0.1 0.1"
,
grey20
=>
"0.2 0.2 0.2"
,
grey30
=>
"0.3 0.3 0.3"
,
grey40
=>
"0.4 0.4 0.4"
,
grey50
=>
"0.5 0.5 0.5"
,
grey60
=>
"0.6 0.6 0.6"
,
grey70
=>
"0.7 0.7 0.7"
,
grey80
=>
"0.8 0.8 0.8"
,
grey90
=>
"0.9 0.9 0.9"
,
white
=>
"1 1 1"
,
);
my
%pspaper
= (
A0
=>
'2384 3370'
,
A1
=>
'1684 2384'
,
A2
=>
'1191 1684'
,
A3
=>
"841.88976 1190.5512"
,
A4
=>
"595.27559 841.88976"
,
A5
=>
"420.94488 595.27559"
,
A6
=>
'297 420'
,
A7
=>
'210 297'
,
A8
=>
'148 210'
,
A9
=>
'105 148'
,
B0
=>
'2920 4127'
,
B1
=>
'2064 2920'
,
B2
=>
'1460 2064'
,
B3
=>
'1032 1460'
,
B4
=>
'729 1032'
,
B5
=>
'516 729'
,
B6
=>
'363 516'
,
B7
=>
'258 363'
,
B8
=>
'181 258'
,
B9
=>
'127 181 '
,
B10
=>
'91 127'
,
Executive
=>
'522 756'
,
Folio
=>
'595 935'
,
'Half-Letter'
=>
'612 397'
,
Letter
=>
"612 792"
,
'US-Letter'
=>
'612 792'
,
Legal
=>
'612 1008'
,
'US-Legal'
=>
'612 1008'
,
Tabloid
=>
'792 1224'
,
'SuperB'
=>
'843 1227'
,
Ledger
=>
'1224 792'
,
'Comm #10 Envelope'
=>
'297 684'
,
'Envelope-Monarch'
=>
'280 542'
,
'Envelope-DL'
=>
'312 624'
,
'Envelope-C5'
=>
'461 648'
,
'EuroPostcard'
=>
'298 420'
,
);
my
@fonts
= (
'Courier'
,
'Courier-Bold'
,
'Courier-BoldOblique'
,
'Courier-Oblique'
,
'Helvetica'
,
'Helvetica-Bold'
,
'Helvetica-BoldOblique'
,
'Helvetica-Oblique'
,
'Times-Roman'
,
'Times-Bold'
,
'Times-BoldItalic'
,
'Times-Italic'
,
'Symbol'
);
my
%psorigin
= (
'LeftBottom'
=>
'0 0'
,
'LeftTop'
=>
'0 -1'
,
'RightBottom'
=>
'-1 0'
,
'RightTop'
=>
'-1 -1'
,
);
my
%psdirs
= (
'RightUp'
=>
'1 1'
,
'RightDown'
=>
'1 -1'
,
'LeftUp'
=>
'-1 1'
,
'LeftDown'
=>
'-1 -1'
,
);
my
%psunits
= (
pt
=>
"72 72.27"
,
pc
=>
"72 6.0225"
,
in
=>
"72 1"
,
bp
=>
"1 1"
,
cm
=>
"72 2.54"
,
mm
=>
"72 25.4"
,
dd
=>
"72 67.567"
,
cc
=>
"72 810.804"
,
);
sub
new
{
my
(
$class
,
%data
) =
@_
;
my
$self
= {
xsize
=>
undef
,
ysize
=>
undef
,
papersize
=>
undef
,
units
=>
"bp"
,
landscape
=> 0,
copies
=> 1,
colour
=> 0,
clip
=> 0,
eps
=> 1,
page
=> 1,
reencode
=>
"ISOLatin1Encoding"
,
bbx1
=> 0,
bby1
=> 0,
bbx2
=> 0,
bby2
=> 0,
pscomments
=>
""
,
psprolog
=>
""
,
psfunctions
=>
""
,
pssetup
=>
""
,
pspages
=>
""
,
pstrailer
=>
""
,
lastfontsize
=> 0,
pspagecount
=> 0,
usedcircle
=> 0,
usedcircletext
=> 0,
usedbox
=> 0,
usedrotabout
=> 0,
usedimporteps
=> 0,
coordorigin
=>
'LeftBottom'
,
direction
=>
'RightUp'
,
};
foreach
(
keys
%data
)
{
$self
->{
$_
} =
$data
{
$_
};
}
bless
$self
,
$class
;
$self
->init();
return
$self
;
}
sub
init
{
my
$self
=
shift
;
my
(
$m
,
$d
) = (1, 1);
my
(
$u
,
$mm
);
my
(
$dx
,
$dy
);
if
(
defined
$self
->{units})
{
$self
->{units} =
lc
$self
->{units};
}
if
(
defined
(
$psunits
{
$self
->{units}}))
{
(
$m
,
$d
) =
split
(/\s+/,
$psunits
{
$self
->{units}});
}
else
{
$self
->_error(
"unit '$self->{units}' undefined"
);
}
(
$dx
,
$dy
) =
split
(/\s+/,
$psdirs
{
$self
->{direction}});
$mm
=
$m
*
$dx
;
$u
=
"{"
;
if
(
$mm
!= 1) {
$u
.=
"$mm mul "
}
if
(
$d
!= 1) {
$u
.=
"$d div "
}
$u
=~ s/ $//;
$u
.=
"}"
;
$self
->{psfunctions} .=
"/ux $u def\n"
;
$mm
=
$m
*
$dy
;
$u
=
"{"
;
if
(
$mm
!= 1) {
$u
.=
"$mm mul "
}
if
(
$d
!= 1) {
$u
.=
"$d div "
}
$u
=~ s/ $//;
$u
.=
"}"
;
$self
->{psfunctions} .=
"/uy $u def\n"
;
$u
=
"{"
;
if
(
$m
!= 1) {
$u
.=
"$m mul "
}
if
(
$d
!= 1) {
$u
.=
"$d div "
}
$u
=~ s/ $//;
$u
.=
"}"
;
$self
->{psfunctions} .=
"/u $u def\n"
;
if
(
defined
$self
->{papersize})
{
$self
->{papersize} =
ucfirst
lc
$self
->{papersize};
}
if
(!
defined
$self
->{xsize} || !
defined
$self
->{ysize})
{
if
(
defined
$self
->{papersize} &&
defined
$pspaper
{
$self
->{papersize}})
{
(
$self
->{xsize},
$self
->{ysize}) =
split
(/\s+/,
$pspaper
{
$self
->{papersize}});
$self
->{bbx2} =
int
(
$self
->{xsize});
$self
->{bby2} =
int
(
$self
->{ysize});
$self
->{pscomments} .=
"\%\%DocumentMedia: $self->{papersize} $self->{xsize} "
;
$self
->{pscomments} .=
"$self->{ysize} 0 ( ) ( )\n"
;
}
else
{
(
$self
->{xsize},
$self
->{ysize}) = (100,100);
$self
->_error(
"page size undefined"
);
}
}
else
{
$self
->{bbx2} =
int
((
$self
->{xsize} *
$m
) /
$d
);
$self
->{bby2} =
int
((
$self
->{ysize} *
$m
) /
$d
);
}
if
(
$self
->{landscape})
{
my
$swap
;
$self
->{psfunctions} .= "/landscape {
$self
->{bbx2} 0 translate
90 rotate
}
bind
def
";
$self
->{pscomments} .=
"\%\%Orientation: Portrait\n"
;
$swap
=
$self
->{bbx2};
$self
->{bbx2} =
$self
->{bby2};
$self
->{bby2} =
$swap
;
if
(
$self
->{eps}) {
$self
->{pssetup} .=
"landscape\n"
}
}
else
{
$self
->{pscomments} .=
"\%\%Orientation: Portrait\n"
;
}
if
(
$self
->{clip})
{
$self
->{psfunctions} .= "/pageclip {newpath
$self
->{bbx1}
$self
->{bby1} moveto
$self
->{bbx1}
$self
->{bby2} lineto
$self
->{bbx2}
$self
->{bby2} lineto
$self
->{bbx2}
$self
->{bby1} lineto
$self
->{bbx1}
$self
->{bby1} lineto
closepath clip}
bind
def
";
if
(
$self
->{eps}) {
$self
->{pssetup} .=
"pageclip\n"
}
}
if
(
$self
->{reencode})
{
my
$encoding
;
my
$ext
;
if
(
ref
$self
->{reencode} eq
'ARRAY'
)
{
die
"Custom reencoding of fonts not really implemented yet, sorry..."
;
$encoding
=
shift
@{
$self
->{reencode}};
$ext
=
shift
@{
$self
->{reencode}};
}
else
{
$encoding
=
$self
->{reencode};
$ext
=
'-iso'
;
}
$self
->{psfunctions} .=
<<'EOP';
/STARTDIFFENC { mark } bind def
/ENDDIFFENC {
% /NewEnc BaseEnc STARTDIFFENC number or glyphname ... ENDDIFFENC -
counttomark 2 add -1 roll 256 array copy
/TempEncode exch def
% pointer for sequential encodings
/EncodePointer 0 def
{
% Get the bottom object
counttomark -1 roll
% Is it a mark?
dup type dup /marktype eq {
% End of encoding
pop pop exit
} {
/nametype eq {
% Insert the name at EncodePointer
% and increment the pointer.
TempEncode EncodePointer 3 -1 roll put
/EncodePointer EncodePointer 1 add def
} {
% Set the EncodePointer to the number
/EncodePointer exch def
} ifelse
} ifelse
} loop
TempEncode def
} bind def
% Define ISO Latin1 encoding if it doesnt exist
/ISOLatin1Encoding where {
% (ISOLatin1 exists!) =
pop
} {
(ISOLatin1 does not exist, creating...) =
/ISOLatin1Encoding StandardEncoding STARTDIFFENC
144 /dotlessi /grave /acute /circumflex /tilde
/macron /breve /dotaccent /dieresis /.notdef /ring
/cedilla /.notdef /hungarumlaut /ogonek /caron /space
/exclamdown /cent /sterling /currency /yen /brokenbar
/section /dieresis /copyright /ordfeminine
/guillemotleft /logicalnot /hyphen /registered
/macron /degree /plusminus /twosuperior
/threesuperior /acute /mu /paragraph /periodcentered
/cedilla /onesuperior /ordmasculine /guillemotright
/onequarter /onehalf /threequarters /questiondown
/Agrave /Aacute /Acircumflex /Atilde /Adieresis
/Aring /AE /Ccedilla /Egrave /Eacute /Ecircumflex
/Edieresis /Igrave /Iacute /Icircumflex /Idieresis
/Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde
/Odieresis /multiply /Oslash /Ugrave /Uacute
/Ucircumflex /Udieresis /Yacute /Thorn /germandbls
/agrave /aacute /acircumflex /atilde /adieresis
/aring /ae /ccedilla /egrave /eacute /ecircumflex
/edieresis /igrave /iacute /icircumflex /idieresis
/eth /ntilde /ograve /oacute /ocircumflex /otilde
/odieresis /divide /oslash /ugrave /uacute
/ucircumflex /udieresis /yacute /thorn /ydieresis
ENDDIFFENC
} ifelse
% Name: Re-encode Font
% Description: Creates a new font using the named encoding.
/REENCODEFONT { % /Newfont NewEncoding /Oldfont
findfont dup length 4 add dict
begin
{ % forall
1 index /FID ne
2 index /UniqueID ne and
2 index /XUID ne and
{ def } { pop pop } ifelse
} forall
/Encoding exch def
% defs for DPS
/BitmapWidths false def
/ExactSize 0 def
/InBetweenSize 0 def
/TransformedChar 0 def
currentdict
end
definefont pop
} bind def
% Reencode the std fonts:
EOP
for
my
$font
(
@fonts
)
{
$self
->{psfunctions} .=
"/${font}$ext $encoding /$font REENCODEFONT\n"
;
}
}
}
sub
newpage
{
my
$self
=
shift
;
my
$nextpage
=
shift
;
my
(
$x
,
$y
);
if
(
defined
(
$nextpage
)) {
$self
->{page} =
$nextpage
; }
if
(
$self
->{eps})
{
$self
->_error(
"Do not use newpage for eps files!"
);
return
0;
}
if
(
$self
->{pspagecount} != 0)
{
$self
->{pspages} .=
"\%\%PageTrailer\npagelevel restore\nshowpage\n"
;
}
$self
->{pspagecount} ++;
$self
->{pspages} .=
"\%\%Page: $self->{page} $self->{pspagecount}\n"
;
if
(
$self
->{page} >= 0)
{
$self
->{page} ++;
}
else
{
$self
->{page} --;
}
$self
->{pspages} .=
"\%\%BeginPageSetup\n"
;
$self
->{pspages} .=
"/pagelevel save def\n"
;
if
(
$self
->{landscape}) {
$self
->{pspages} .=
"landscape\n"
}
if
(
$self
->{clip}) {
$self
->{pspages} .=
"pageclip\n"
}
(
$x
,
$y
) =
split
(/\s+/,
$psorigin
{
$self
->{coordorigin}});
$x
=
$self
->{xsize}
if
(
$x
< 0);
$y
=
$self
->{ysize}
if
(
$y
< 0);
$self
->{pspages} .=
"$x $y translate\n"
if
((
$x
!= 0) || (
$y
!= 0));
$self
->{pspages} .=
"\%\%EndPageSetup\n"
;
return
1;
}
sub
_buildpage
{
my
$self
=
shift
;
my
$title
=
shift
;
my
$page
;
my
$date
=
scalar
localtime
;
my
$user
;
$title
=
'undefined'
unless
$title
;
$page
= [];
eval
{
$user
=
getlogin
; };
$user
=
'Console'
unless
$user
;
push
@$page
,
"%!PS-Adobe-3.0"
;
push
@$page
,
" EPSF-1.2"
if
(
$self
->{eps});
push
@$page
,
"\n"
;
push
@$page
,
"\%\%Title: ($title)\n"
;
push
@$page
,
"\%\%LanguageLevel: 1\n"
;
push
@$page
,
"\%\%Creator: PostScript::Simple perl module version $VERSION\n"
;
push
@$page
,
"\%\%CreationDate: $date\n"
;
push
@$page
,
"\%\%For: $user\n"
;
push
@$page
, \
$self
->{pscomments};
if
(
$self
->{eps})
{
push
@$page
,
"\%\%BoundingBox: $self->{bbx1} $self->{bby1} $self->{bbx2} $self->{bby2}\n"
;
}
else
{
push
@$page
,
"\%\%Pages: $self->{pspagecount}\n"
;
}
push
@$page
,
"\%\%EndComments\n"
;
push
@$page
,
"\%\%BeginProlog\n"
;
push
@$page
, \
$self
->{psprolog};
push
@$page
,
"\%\%BeginResource: PostScript::Simple\n"
;
push
@$page
, \
$self
->{psfunctions};
push
@$page
,
"\%\%EndResource\n"
;
push
@$page
,
"\%\%EndProlog\n"
;
if
(
length
(
$self
->{pssetup}) || (
$self
->{copies} > 1))
{
push
@$page
,
"\%\%BeginSetup\n"
;
if
(
$self
->{copies} > 1)
{
push
@$page
,
"/#copies "
.
$self
->{copies} .
" def\n"
;
}
push
@$page
, \
$self
->{pssetup};
push
@$page
,
"\%\%EndSetup\n"
;
}
push
@$page
, \
$self
->{pspages};
if
((!
$self
->{eps}) && (
$self
->{pspagecount} > 0))
{
push
@$page
,
"\%\%PageTrailer\n"
;
push
@$page
,
"pagelevel restore\n"
;
push
@$page
,
"showpage\n"
;
}
if
(
length
(
$self
->{pstrailer}))
{
push
@$page
,
"\%\%Trailer\n"
;
push
@$page
, \
$self
->{pstrailer};
}
push
@$page
,
"\%\%EOF\n"
;
return
$page
;
}
sub
output
{
my
$self
=
shift
;
my
$file
=
shift
||
die
(
"Must supply a filename for output"
);
my
$page
;
my
$i
;
$page
= _buildpage(
$self
,
$file
);
local
*OUT
;
open
(OUT,
'>'
.
$file
) or
die
(
"Cannot write to file $file: $!"
);
foreach
$i
(
@$page
) {
if
(
ref
(
$i
) eq
"SCALAR"
) {
print
OUT
$$i
;
}
else
{
print
OUT
$i
;
}
}
close
OUT;
return
1;
}
sub
get
{
my
$self
=
shift
;
my
$page
;
my
$i
;
my
$doc
;
$page
= _buildpage(
$self
,
"PostScript::Simple generated page"
);
$doc
=
""
;
foreach
$i
(
@$page
) {
if
(
ref
(
$i
) eq
"SCALAR"
) {
$doc
.=
$$i
;
}
else
{
$doc
.=
$i
;
}
}
return
$doc
;
}
sub
geteps
{
my
$self
=
shift
;
my
$page
;
my
$i
;
my
$doc
;
my
$eps
;
croak
"document is not EPS"
unless
(
$$self
{eps} == 1);
$eps
= new PostScript::Simple::EPS(
source
=>
$self
->get);
return
$eps
;
}
sub
setcolour
{
my
$self
=
shift
;
my
(
$r
,
$g
,
$b
) =
@_
;
if
(
@_
== 1 )
{
$r
=
lc
$r
;
if
(
defined
$pscolours
{
$r
})
{
(
$r
,
$g
,
$b
) =
split
(/\s+/,
$pscolours
{
$r
});
}
else
{
$self
->_error(
"bad colour name '$r'"
);
return
0;
}
}
elsif
(
@_
== 3 )
{
$r
/= 255;
$g
/= 255;
$b
/= 255;
}
else
{
if
(not
defined
$r
) {
$r
=
'undef'
}
if
(not
defined
$g
) {
$g
=
'undef'
}
if
(not
defined
$b
) {
$b
=
'undef'
}
$self
->_error(
"setcolour given invalid arguments: $r, $g, $b"
);
return
0;
}
if
(
$self
->{colour})
{
$self
->{pspages} .=
"$r $g $b setrgbcolor\n"
;
}
else
{
$r
= 0.3
*$r
+ 0.59
*$g
+ 0.11
*$b
;
$self
->{pspages} .=
"$r setgray\n"
;
}
return
1;
}
sub
setlinewidth
{
my
$self
=
shift
;
my
$width
=
shift
||
do
{
$self
->_error(
"setlinewidth not given a width"
);
return
0;
};
if
(
$width
eq
"thin"
) {
$width
=
"0.4"
}
else
{
$width
.=
" u"
}
$self
->{pspages} .=
"$width setlinewidth\n"
;
return
1;
}
sub
line
{
my
$self
=
shift
;
my
(
$x1
,
$y1
,
$x2
,
$y2
,
$r
,
$g
,
$b
) =
@_
;
if
((!
$self
->{pspagecount}) and (!
$self
->{eps}))
{
return
0;
}
if
(
@_
== 7 )
{
$self
->setcolour(
$r
,
$g
,
$b
);
}
elsif
(
@_
!= 4 )
{
$self
->_error(
"wrong number of args for line"
);
return
0;
}
$self
->newpath;
$self
->moveto(
$x1
,
$y1
);
$self
->{pspages} .=
"$x2 ux $y2 uy lineto stroke\n"
;
return
1;
}
sub
linextend
{
my
$self
=
shift
;
my
(
$x
,
$y
) =
@_
;
unless
(
@_
== 2 )
{
$self
->_error(
"wrong number of args for linextend"
);
return
0;
}
$self
->{pspages} =~ s/eto stroke\n$/eto\n
$x
ux
$y
uy lineto stroke\n/;
return
1;
}
sub
arc
{
my
$self
=
shift
;
my
%opt
= ();
if
(
ref
(
$_
[0])) {
%opt
= %{;
shift
};
}
if
((!
$self
->{pspagecount}) and (!
$self
->{eps})) {
return
0;
}
my
(
$x
,
$y
,
$r
,
$sa
,
$ea
) =
@_
;
unless
(
@_
== 5) {
$self
->_error(
"arc: wrong number of arguments"
);
return
0;
}
$self
->{pspages} .=
"$x ux $y uy $r u $sa $ea arc "
;
if
(
$opt
{
'filled'
}) {
$self
->{pspages} .=
"fill\n"
}
else
{
$self
->{pspages} .=
"stroke\n"
}
return
1;
}
sub
polygon
{
my
$self
=
shift
;
my
%opt
= ();
my
(
$xoffset
,
$yoffset
) = (0,0);
my
(
$rotate
,
$rotatex
,
$rotatey
) = (0,0,0);
if
(
$#_
< 3)
{
$self
->_error(
"bad polygon - not enough points"
);
return
0;
}
if
(
ref
(
$_
[0]))
{
%opt
= %{;
shift
};
}
my
$x
=
shift
;
my
$y
=
shift
;
if
(
defined
$opt
{
'rotate'
})
{
if
(
ref
(
$opt
{
'rotate'
}))
{
(
$rotate
,
$rotatex
,
$rotatey
) = @{
$opt
{
'rotate'
}};
}
else
{
(
$rotate
,
$rotatex
,
$rotatey
) = (
$opt
{
'rotate'
},
$x
,
$y
);
}
}
if
(
defined
$opt
{
'offset'
})
{
if
(
ref
(
$opt
{
'offset'
}))
{
(
$xoffset
,
$yoffset
) = @{
$opt
{
'offset'
}};
}
else
{
$self
->_error(
"polygon: bad offset option"
);
return
0;
}
}
if
(!
defined
$opt
{
'filled'
})
{
$opt
{
'filled'
} = 0;
}
unless
(
defined
(
$x
) &&
defined
(
$y
))
{
$self
->_error(
"polygon: no start point"
);
return
0;
}
my
$savestate
= (
$xoffset
||
$yoffset
||
$rotate
) ? 1 : 0 ;
if
(
$savestate
)
{
$self
->{pspages} .=
"gsave "
;
}
if
(
$xoffset
||
$yoffset
)
{
$self
->{pspages} .=
"$xoffset ux $yoffset uy translate\n"
;
}
if
(
$rotate
)
{
if
(!
$self
->{usedrotabout})
{
$self
->{psfunctions} .= "/rotabout {3 copy
pop
translate rotate exch 0 exch
sub
exch 0 exch
sub
translate} def\n";
$self
->{usedrotabout} = 1;
}
$self
->{pspages} .=
"$rotatex ux $rotatey uy $rotate rotabout\n"
;
}
$self
->newpath;
$self
->moveto(
$x
,
$y
);
while
(
$#_
> 0)
{
my
$x
=
shift
;
my
$y
=
shift
;
$self
->{pspages} .=
"$x ux $y uy lineto "
;
}
if
(
$opt
{
'filled'
})
{
$self
->{pspages} .=
"fill\n"
;
}
else
{
$self
->{pspages} .=
"stroke\n"
;
}
if
(
$savestate
)
{
$self
->{pspages} .=
"grestore\n"
;
}
return
1;
}
sub
circle
{
my
$self
=
shift
;
my
%opt
= ();
if
(
ref
(
$_
[0]))
{
%opt
= %{;
shift
};
}
my
(
$x
,
$y
,
$r
) =
@_
;
unless
(
@_
== 3)
{
$self
->_error(
"circle: wrong number of arguments"
);
return
0;
}
if
(!
$self
->{usedcircle})
{
$self
->{psfunctions} .=
"/circle {newpath 0 360 arc closepath} bind def\n"
;
$self
->{usedcircle} = 1;
}
$self
->{pspages} .=
"$x ux $y uy $r u circle "
;
if
(
$opt
{
'filled'
}) {
$self
->{pspages} .=
"fill\n"
}
else
{
$self
->{pspages} .=
"stroke\n"
}
return
1;
}
sub
circletext
{
my
$self
=
shift
;
my
%opt
= ();
if
(
ref
(
$_
[0]))
{
%opt
= %{;
shift
};
}
my
(
$x
,
$y
,
$r
,
$a
,
$text
) =
@_
;
unless
(
@_
== 5) {
$self
->_error(
"circletext: wrong number of arguments"
);
return
0;
}
unless
(
defined
$self
->{lastfontsize}) {
$self
->_error(
"circletext: must set font first"
);
return
0;
}
if
(!
$self
->{usedcircletext}) {
$self
->{psfunctions} .=
<<'EOCT';
/outsidecircletext
{ $circtextdict begin
/radius exch def
/centerangle exch def
/ptsize exch def
/str exch def
/xradius radius ptsize 4 div add def
gsave
centerangle str findhalfangle add rotate
str { /charcode exch def ( ) dup 0 charcode put outsideshowcharandrotate } forall
grestore
end
} def
/insidecircletext
{ $circtextdict begin
/radius exch def
/centerangle exch def
/ptsize exch def
/str exch def
/xradius radius ptsize 3 div sub def
gsave
centerangle str findhalfangle sub rotate
str { /charcode exch def ( ) dup 0 charcode put insideshowcharandrotate } forall
grestore
end
} def
/$circtextdict 16 dict def
$circtextdict begin
/findhalfangle
{ stringwidth pop 2 div 2 xradius mul pi mul div 360 mul
} def
/outsideshowcharandrotate
{ /char exch def
/halfangle char findhalfangle def
gsave
halfangle neg rotate radius 0 translate -90 rotate
char stringwidth pop 2 div neg 0 moveto char show
grestore
halfangle 2 mul neg rotate
} def
/insideshowcharandrotate
{ /char exch def
/halfangle char findhalfangle def
gsave
halfangle rotate radius 0 translate 90 rotate
char stringwidth pop 2 div neg 0 moveto char show
grestore
halfangle 2 mul rotate
} def
/pi 3.1415926 def
end
EOCT
$self
->{usedcircletext} = 1;
}
$self
->{pspages} .=
"gsave\n"
;
$self
->{pspages} .=
" $x ux $y uy translate\n"
;
$self
->{pspages} .=
" ($text) $self->{lastfontsize} $a $r u "
;
if
(
$opt
{
'align'
} && (
$opt
{
'align'
} eq
"outside"
)) {
$self
->{pspages} .=
"outsidecircletext\n"
;
}
else
{
$self
->{pspages} .=
"insidecircletext\n"
;
}
$self
->{pspages} .=
"grestore\n"
;
return
1;
}
sub
box
{
my
$self
=
shift
;
my
%opt
= ();
if
(
ref
(
$_
[0]))
{
%opt
= %{;
shift
};
}
my
(
$x1
,
$y1
,
$x2
,
$y2
) =
@_
;
unless
(
@_
== 4) {
$self
->_error(
"box: wrong number of arguments"
);
return
0;
}
if
(!
defined
(
$opt
{
'filled'
}))
{
$opt
{
'filled'
} = 0;
}
unless
(
$self
->{usedbox})
{
$self
->{psfunctions} .= "/box {
newpath 3 copy
pop
exch 4 copy
pop
pop
8 copy
pop
pop
pop
pop
exch
pop
exch
3 copy
pop
pop
exch moveto lineto
lineto lineto
pop
pop
pop
pop
closepath
}
bind
def
";
$self
->{usedbox} = 1;
}
$self
->{pspages} .=
"$x1 ux $y1 uy $x2 ux $y2 uy box "
;
if
(
$opt
{
'filled'
}) {
$self
->{pspages} .=
"fill\n"
}
else
{
$self
->{pspages} .=
"stroke\n"
}
return
1;
}
sub
setfont
{
my
$self
=
shift
;
my
(
$name
,
$size
,
$ysize
) =
@_
;
unless
(
@_
== 2) {
$self
->_error(
"wrong number of arguments for setfont"
);
return
0;
}
$self
->{pspages} .=
"/$name findfont $size scalefont setfont\n"
;
$self
->{lastfontsize} =
$size
;
return
1;
}
sub
text
{
my
$self
=
shift
;
my
$rot
=
""
;
my
$rot_m
=
""
;
my
$align
=
""
;
my
%opt
= ();
if
(
ref
(
$_
[0]))
{
%opt
= %{;
shift
};
}
unless
(
@_
== 3 )
{
$self
->_error(
"text: wrong number of arguments"
);
return
0;
}
my
(
$x
,
$y
,
$text
) =
@_
;
unless
(
defined
(
$x
) &&
defined
(
$y
) &&
defined
(
$text
))
{
$self
->_error(
"text: wrong number of arguments"
);
return
0;
}
$text
=~ s|([\\\(\)])|\\$1|g;
$text
=~ s/([\x00-\x1f\x7f-\xff])/
sprintf
(
'\\%03o'
,
ord
($1))/ge;
$self
->newpath;
$self
->moveto(
$x
,
$y
);
if
(
defined
$opt
{
'rotate'
})
{
my
$rot_a
=
$opt
{
'rotate'
};
if
(
$rot_a
!= 0 )
{
$rot
=
" $rot_a rotate "
;
$rot_a
= -
$rot_a
;
$rot_m
=
" $rot_a rotate "
;
};
}
$align
=
" show stroke"
;
if
(
defined
$opt
{
'align'
})
{
$align
=
" dup stringwidth pop neg 0 rmoveto show"
if
$opt
{
'align'
} eq
'right'
;
$align
=
" dup stringwidth pop 2 div neg 0 rmoveto show"
if
$opt
{
'align'
} eq
'center'
or
$opt
{
'align'
} eq
'centre'
;
}
$self
->{pspages} .=
"($text) $rot $align $rot_m\n"
;
return
1;
}
sub
curve
{
my
$self
=
shift
;
my
(
$x1
,
$y1
,
$x2
,
$y2
,
$x3
,
$y3
,
$x4
,
$y4
) =
@_
;
unless
(
@_
== 8 )
{
$self
->_error(
"bad curve definition, wrong number of args"
);
return
0;
}
if
((!
$self
->{pspagecount}) and (!
$self
->{eps}))
{
return
0;
}
$self
->newpath;
$self
->moveto(
$x1
,
$y1
);
$self
->{pspages} .=
"$x2 ux $y2 uy $x3 ux $y3 uy $x4 ux $y4 uy curveto stroke\n"
;
return
1;
}
sub
curvextend
{
my
$self
=
shift
;
my
(
$x1
,
$y1
,
$x2
,
$y2
,
$x3
,
$y3
) =
@_
;
unless
(
@_
== 6 )
{
$self
->_error(
"bad curvextend definition, wrong number of args"
);
return
0;
}
$self
->{pspages} =~ s/eto stroke\n$/eto\n
$x1
ux
$y1
uy
$x2
ux
$y2
uy
$x3
ux
$y3
uy curveto stroke\n/;
return
1;
}
sub
newpath
{
my
$self
=
shift
;
$self
->{pspages} .=
"newpath\n"
;
return
1;
}
sub
moveto
{
my
$self
=
shift
;
my
(
$x
,
$y
) =
@_
;
$self
->{pspages} .=
"$x ux $y uy moveto\n"
;
return
1;
}
sub
importepsfile
{
my
$self
=
shift
;
my
$bbllx
;
my
$bblly
;
my
$bburx
;
my
$bbury
;
my
$bbw
;
my
$bbh
;
my
$pagew
;
my
$pageh
;
my
$scalex
;
my
$scaley
;
my
$line
;
my
$eps
;
my
%opt
= ();
if
(
ref
(
$_
[0])) {
%opt
= %{;
shift
};
}
my
(
$file
,
$x1
,
$y1
,
$x2
,
$y2
) =
@_
;
unless
(
@_
== 5) {
$self
->_error(
"importepsfile: wrong number of arguments"
);
return
0;
}
$opt
{
'overlap'
} = 0
if
(!
defined
(
$opt
{
'overlap'
}));
$opt
{
'stretch'
} = 0
if
(!
defined
(
$opt
{
'stretch'
}));
$eps
= new PostScript::Simple::EPS(
file
=>
$file
);
(
$bbllx
,
$bblly
,
$bburx
,
$bbury
) =
$eps
->get_bbox();
$pagew
=
$x2
-
$x1
;
$pageh
=
$y2
-
$y1
;
$bbw
=
$bburx
-
$bbllx
;
$bbh
=
$bbury
-
$bblly
;
if
((
$bbw
== 0) || (
$bbh
== 0)) {
$self
->_error(
"importeps: Bounding Box has zero dimension"
);
return
0;
}
$scalex
=
$pagew
/
$bbw
;
$scaley
=
$pageh
/
$bbh
;
if
(
$opt
{
'stretch'
} == 0) {
if
(
$opt
{
'overlap'
} == 0) {
if
(
$scalex
>
$scaley
) {
$scalex
=
$scaley
;
}
else
{
$scaley
=
$scalex
;
}
}
else
{
if
(
$scalex
>
$scaley
) {
$scaley
=
$scalex
;
}
else
{
$scalex
=
$scaley
;
}
}
}
$eps
->scale(
$scalex
,
$scaley
);
$eps
->translate(-
$bbllx
, -
$bblly
);
$self
->_add_eps(
$eps
,
$x1
,
$y1
);
return
1;
}
sub
importeps
{
my
$self
=
shift
;
my
(
$epsobj
,
$xpos
,
$ypos
) =
@_
;
unless
(
@_
== 3) {
$self
->_error(
"importeps: wrong number of arguments"
);
return
0;
}
$self
->_add_eps(
$epsobj
,
$xpos
,
$ypos
);
return
1;
}
sub
_add_eps
{
my
$self
=
shift
;
my
$epsobj
;
my
$xpos
;
my
$ypos
;
if
(
ref
(
$_
[0]) ne
"PostScript::Simple::EPS"
) {
croak
"internal error: _add_eps[0] must be eps object"
;
}
if
((!
$self
->{pspagecount}) and (!
$self
->{eps})) {
$self
->_error(
"importeps: no current page"
);
return
0;
}
if
(
@_
!= 3 ) {
croak
"internal error: wrong number of arguments for _add_eps"
;
return
0;
}
unless
(
$self
->{usedimporteps}) {
$self
->{psfunctions} .=
<<'EOEPS';
/BeginEPSF { /b4_Inc_state save def /dict_count countdictstack def
/op_count count 1 sub def userdict begin /showpage { } def 0 setgray
0 setlinecap 1 setlinewidth 0 setlinejoin 10 setmiterlimit [ ]
0 setdash newpath /languagelevel where { pop languagelevel 1 ne {
false setstrokeadjust false setoverprint } if } if } bind def
/EndEPSF { count op_count sub {pop} repeat countdictstack dict_count
sub {end} repeat b4_Inc_state restore } bind def
EOEPS
$self
->{usedimporteps} = 1;
}
(
$epsobj
,
$xpos
,
$ypos
) =
@_
;
$self
->{pspages} .=
"BeginEPSF\n"
;
$self
->{pspages} .=
"$xpos ux $ypos uy translate\n"
;
$self
->{pspages} .=
"1 ux 1 uy scale\n"
;
$self
->{pspages} .=
$epsobj
->_get_include_data(
$xpos
,
$ypos
);
$self
->{pspages} .=
"EndEPSF\n"
;
return
1;
}
sub
_error {
my
$self
=
shift
;
my
$msg
=
shift
;
$self
->{pspages} .=
"(error: $msg\n) print flush\n"
;
}
1;