PostScript-Simple-0.07/0000700000175000017500000000000010362031024014332 5ustar mcnmcn00000000000000PostScript-Simple-0.07/examples/0000700000175000017500000000000010362031024016150 5ustar mcnmcn00000000000000PostScript-Simple-0.07/examples/demo.ps0000644000175000017500000004574310067116607017504 0ustar mcnmcn00000000000000%!PS-Adobe-3.0 %%Title: (demo.ps) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%DocumentMedia: A4 595.27559 841.88976 0 ( ) ( ) %%Orientation: Portrait %%Pages: 2 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {72 mul 25.4 div} def /uy {72 mul 25.4 div} def /u {72 mul 25.4 div} def /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 /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 %%EndResource %%EndProlog %%BeginSetup ll 2 ge { << /PageSize [ 595.27559 841.88976 ] /ImagingBBox null >> setpagedevice } if %%EndSetup %%Page: 1 1 %%BeginPageSetup /pagelevel save def %%EndPageSetup 10 ux 10 uy 200 ux 287 uy box stroke newpath 10 ux 277 uy moveto 200 ux 277 uy lineto stroke /Times-Roman findfont 14 scalefont setfont newpath 15 ux 280 uy moveto (PostScript::Simple example file: EPS import functions \(from a file\)) show stroke /Courier findfont 10 scalefont setfont 0.8 0 0 setrgbcolor 20 ux 210 uy 45 ux 260 uy box stroke BeginEPSF 20 ux 210 uy translate 1 ux 1 uy scale 0.25 0.25 scale 0 0 translate newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %%BeginDocument: demo-square.eps %!PS-Adobe-3.0 EPSF-1.2 %%Title: (demo-square.eps) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF %%EndDocument EndEPSF 0.5 0 0 setrgbcolor newpath 14 ux 270 uy moveto ($ps->importepsfile\("demo-square.eps", 20, 210, 45, 260\);) -90 rotate show stroke 90 rotate 0 0.8 0 setrgbcolor 80 ux 210 uy 105 ux 260 uy box stroke BeginEPSF 80 ux 210 uy translate 1 ux 1 uy scale 0.25 0.5 scale 0 0 translate newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %%BeginDocument: demo-square.eps %!PS-Adobe-3.0 EPSF-1.2 %%Title: (demo-square.eps) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF %%EndDocument EndEPSF 0 0.5 0 setrgbcolor newpath 74 ux 270 uy moveto ($ps->importepsfile\({stretch => 1}, "demo-square.eps", 80, 210, 105, 260\);) -90 rotate show stroke 90 rotate 0 0 0.8 setrgbcolor 140 ux 210 uy 165 ux 260 uy box stroke BeginEPSF 140 ux 210 uy translate 1 ux 1 uy scale 0.5 0.5 scale 0 0 translate newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %%BeginDocument: demo-square.eps %!PS-Adobe-3.0 EPSF-1.2 %%Title: (demo-square.eps) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF %%EndDocument EndEPSF 0 0 0.5 setrgbcolor newpath 134 ux 270 uy moveto ($ps->importepsfile\({overlap => 1}, "demo-square.eps", 140, 210, 165, 260\);) -90 rotate show stroke 90 rotate 0.784313725490196 0 0.784313725490196 setrgbcolor 30 ux 30 uy 90 ux 90 uy box stroke BeginEPSF 30 ux 30 uy translate 1 ux 1 uy scale 0.6 0.6 scale 50 50 translate 20 rotate -50 -50 translate newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %%BeginDocument: demo-square.eps %!PS-Adobe-3.0 EPSF-1.2 %%Title: (demo-square.eps) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF %%EndDocument EndEPSF /Courier findfont 10 scalefont setfont newpath 100 ux 85 uy moveto ($eps = new PostScript::Simple::EPS) show stroke newpath 110 ux 80 uy moveto (\(file => "demo-square.eps"\);) show stroke newpath 100 ux 75 uy moveto ($eps->scale\(60/100\);) show stroke newpath 100 ux 70 uy moveto ($eps->translate\(50, 50\);) show stroke newpath 100 ux 65 uy moveto ($eps->rotate\(20\);) show stroke newpath 100 ux 60 uy moveto ($eps->translate\(-50, -50\);) show stroke newpath 100 ux 55 uy moveto ($ps->importeps\($eps, 30, 30\);) show stroke %%PageTrailer pagelevel restore showpage %%Page: 2 2 %%BeginPageSetup /pagelevel save def %%EndPageSetup 10 ux 10 uy 200 ux 287 uy box stroke newpath 10 ux 277 uy moveto 200 ux 277 uy lineto stroke /Times-Roman findfont 14 scalefont setfont newpath 15 ux 280 uy moveto (PostScript::Simple example file: EPS import functions \(using internal EPS object\)) show stroke /Courier findfont 10 scalefont setfont 0.8 0 0 setrgbcolor 20 ux 210 uy 45 ux 260 uy box stroke BeginEPSF 20 ux 210 uy translate 1 ux 1 uy scale 0.25 0.25 scale newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %!PS-Adobe-3.0 EPSF-1.2 %%Title: (PostScript::Simple generated page) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF EndEPSF 0.5 0 0 setrgbcolor newpath 30 ux 205 uy moveto ($directeps->reset\(\);) -60 rotate show stroke 60 rotate newpath 25 ux 205 uy moveto ($directeps->scale\(25/$directeps->width\(\)\);) -60 rotate show stroke 60 rotate newpath 20 ux 205 uy moveto ($ps->importeps\($directeps, 20, 210\);) -60 rotate show stroke 60 rotate 0 0.8 0 setrgbcolor 80 ux 210 uy 105 ux 260 uy box stroke BeginEPSF 80 ux 210 uy translate 1 ux 1 uy scale 0.25 0.5 scale newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %!PS-Adobe-3.0 EPSF-1.2 %%Title: (PostScript::Simple generated page) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF EndEPSF 0 0.5 0 setrgbcolor newpath 90 ux 205 uy moveto ($directeps->reset\(\);) -60 rotate show stroke 60 rotate newpath 85 ux 205 uy moveto ($directeps->scale\(25/$directeps->width\(\), 50/$directeps->height\(\)\);) -60 rotate show stroke 60 rotate newpath 80 ux 205 uy moveto ($ps->importeps\($directeps, 80, 210\);) -60 rotate show stroke 60 rotate 0 0 0.8 setrgbcolor 140 ux 210 uy 165 ux 260 uy box stroke BeginEPSF 140 ux 210 uy translate 1 ux 1 uy scale 0.5 0.5 scale newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %!PS-Adobe-3.0 EPSF-1.2 %%Title: (PostScript::Simple generated page) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF EndEPSF 0 0 0.5 setrgbcolor newpath 150 ux 205 uy moveto ($directeps->reset\(\);) -60 rotate show stroke 60 rotate newpath 145 ux 205 uy moveto ($directeps->scale\(50/$directeps->height\(\)\);) -60 rotate show stroke 60 rotate newpath 140 ux 205 uy moveto ($ps->importeps\($directeps, 140, 210\);) -60 rotate show stroke 60 rotate 0.784313725490196 0 0.784313725490196 setrgbcolor 30 ux 30 uy 90 ux 90 uy box stroke BeginEPSF 30 ux 30 uy translate 1 ux 1 uy scale 0.6 0.6 scale newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %!PS-Adobe-3.0 EPSF-1.2 %%Title: (PostScript::Simple generated page) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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: /Courier-iso ISOLatin1Encoding /Courier REENCODEFONT /Courier-Bold-iso ISOLatin1Encoding /Courier-Bold REENCODEFONT /Courier-BoldOblique-iso ISOLatin1Encoding /Courier-BoldOblique REENCODEFONT /Courier-Oblique-iso ISOLatin1Encoding /Courier-Oblique REENCODEFONT /Helvetica-iso ISOLatin1Encoding /Helvetica REENCODEFONT /Helvetica-Bold-iso ISOLatin1Encoding /Helvetica-Bold REENCODEFONT /Helvetica-BoldOblique-iso ISOLatin1Encoding /Helvetica-BoldOblique REENCODEFONT /Helvetica-Oblique-iso ISOLatin1Encoding /Helvetica-Oblique REENCODEFONT /Times-Roman-iso ISOLatin1Encoding /Times-Roman REENCODEFONT /Times-Bold-iso ISOLatin1Encoding /Times-Bold REENCODEFONT /Times-BoldItalic-iso ISOLatin1Encoding /Times-BoldItalic REENCODEFONT /Times-Italic-iso ISOLatin1Encoding /Times-Italic REENCODEFONT /Symbol-iso ISOLatin1Encoding /Symbol REENCODEFONT /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 %%EndResource %%EndProlog BeginEPSF 0 ux 0 uy translate 1 ux 1 uy scale 50 50 translate 20 rotate -50 -50 translate newpath 0 0 moveto 100 0 lineto 100 100 lineto 0 100 lineto closepath clip %!PS-Adobe-3.0 EPSF-1.2 %%Title: (PostScript::Simple generated page) %%LanguageLevel: 1 %%Creator: PostScript::Simple perl module version 0.06 %%CreationDate: Thu Jun 24 01:52:29 2004 %%For: comcn %%Orientation: Portrait %%BoundingBox: 0 0 100 100 %%EndComments %%BeginProlog /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if %%BeginResource: PostScript::Simple /ux {} def /uy {} def /u {} def /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 %%EndResource %%EndProlog 5 u setlinewidth 10 ux 10 uy 90 ux 90 uy box stroke 0.4 setlinewidth newpath 0 ux 50 uy moveto 100 ux 50 uy lineto stroke newpath 50 ux 0 uy moveto 50 ux 100 uy lineto stroke newpath 0 ux 40 uy moveto 0 ux 60 uy lineto stroke newpath 100 ux 40 uy moveto 100 ux 60 uy lineto stroke newpath 40 ux 0 uy moveto 60 ux 0 uy lineto stroke newpath 40 ux 100 uy moveto 60 ux 100 uy lineto stroke %%EOF EndEPSF %%EOF EndEPSF /Courier findfont 10 scalefont setfont newpath 100 ux 75 uy moveto ($directeps->reset\(\);) show stroke newpath 100 ux 70 uy moveto ($directeps->translate\(50, 50\);) show stroke newpath 100 ux 65 uy moveto ($directeps->rotate\(20\);) show stroke newpath 100 ux 60 uy moveto ($directeps->translate\(-50, -50\);) show stroke newpath 100 ux 55 uy moveto (# round-about way to set clipping path) show stroke newpath 100 ux 50 uy moveto ($eps = new PostScript::Simple\(eps => 1,) show stroke newpath 110 ux 45 uy moveto (xsize => 100, ysize => 100\);) show stroke newpath 100 ux 40 uy moveto ($eps->importeps\($directeps, 0, 0\);) show stroke newpath 100 ux 35 uy moveto ($directeps = $eps->geteps\(\);) show stroke newpath 100 ux 30 uy moveto ($directeps->scale\(60/100\);) show stroke newpath 100 ux 25 uy moveto ($ps->importeps\($directeps, 30, 30\);) show stroke %%PageTrailer pagelevel restore showpage %%EOF PostScript-Simple-0.07/examples/example.pl0000755000175000017500000001304310067116607020173 0ustar mcnmcn00000000000000#! /usr/bin/perl -w # Examples for PostScript::Simple module # Matthew Newton # 09 November 2003 use strict; use lib qw(../lib); use PostScript::Simple 0.06; my $ps; my $eps; my $directeps; my $y; # First, create an EPS file for use later $ps = new PostScript::Simple(xsize => 100, ysize => 100, colour => 1, eps => 1, reencode => undef); $ps->setlinewidth(5); $ps->box(10, 10, 90, 90); $ps->setlinewidth("thin"); $ps->line(0, 50, 100, 50); $ps->line(50, 0, 50, 100); $ps->line(0, 40, 0, 60); $ps->line(100, 40, 100, 60); $ps->line(40, 0, 60, 0); $ps->line(40, 100, 60, 100); $ps->output("demo-square.eps"); # Let's also create a PostScript::Simple::EPS object directly from it #$directeps = new PostScript::Simple::EPS(source => $ps->get()); $directeps = $ps->geteps(); undef $ps; # Now generate the demo document. Start by creating the A4 document. $ps = new PostScript::Simple(papersize => "a4", units => "mm", colour => 1, eps => 0, reencode => undef); # Create page (EPS import from a file, demo-square.eps) mynewpage($ps, "EPS import functions (from a file)"); $ps->setfont("Courier", 10); $ps->setcolour("red"); $ps->box(20, 210, 45, 260); $ps->importepsfile("demo-square.eps", 20, 210, 45, 260); $ps->setcolour("darkred"); $ps->text({rotate => -90}, 14, 270, '$ps->importepsfile("demo-square.eps", 20, 210, 45, 260);'); $ps->setcolour("green"); $ps->box(80, 210, 105, 260); $ps->importepsfile({stretch => 1}, "demo-square.eps", 80, 210, 105, 260); $ps->setcolour("darkgreen"); $ps->text({rotate => -90}, 74, 270, '$ps->importepsfile({stretch => 1}, "demo-square.eps", 80, 210, 105, 260);'); $ps->setcolour("blue"); $ps->box(140, 210, 165, 260); $ps->importepsfile({overlap => 1}, "demo-square.eps", 140, 210, 165, 260); $ps->setcolour("darkblue"); $ps->text({rotate => -90}, 134, 270, '$ps->importepsfile({overlap => 1}, "demo-square.eps", 140, 210, 165, 260);'); $ps->setcolour(200, 0, 200); $ps->box(30, 30, 90, 90); $eps = new PostScript::Simple::EPS(file => "demo-square.eps", clip => 1); $eps->scale(60/100); $eps->translate(50, 50); $eps->rotate(20); $eps->translate(-50, -50); $ps->importeps($eps, 30, 30); $ps->setfont("Courier", 10); $y = 90; $ps->text(100, $y-=5, '$eps = new PostScript::Simple::EPS'); $ps->text(110, $y-=5, '(file => "demo-square.eps");'); $ps->text(100, $y-=5, '$eps->scale(60/100);'); $ps->text(100, $y-=5, '$eps->translate(50, 50);'); $ps->text(100, $y-=5, '$eps->rotate(20);'); $ps->text(100, $y-=5, '$eps->translate(-50, -50);'); $ps->text(100, $y-=5, '$ps->importeps($eps, 30, 30);'); # Create page (using generated EPS object) mynewpage($ps, "EPS import functions (using internal EPS object)"); $ps->setfont("Courier", 10); $ps->setcolour("red"); $ps->box(20, 210, 45, 260); #$ps->importepsfile("demo-square.eps", 20, 210, 45, 260); $directeps->reset(); $directeps->scale(25/$directeps->width()); $ps->importeps($directeps, 20, 210); $ps->setcolour("darkred"); $ps->text({rotate => -60}, 30, 205, '$directeps->reset();'); $ps->text({rotate => -60}, 25, 205, '$directeps->scale(25/$directeps->width());'); $ps->text({rotate => -60}, 20, 205, '$ps->importeps($directeps, 20, 210);'); $ps->setcolour("green"); $ps->box(80, 210, 105, 260); #$ps->importepsfile({stretch => 1}, "demo-square.eps", 80, 210, 105, 260); $directeps->reset(); $directeps->scale(25/$directeps->width(), 50/$directeps->height()); $ps->importeps($directeps, 80, 210); $ps->setcolour("darkgreen"); $ps->text({rotate => -60}, 90, 205, '$directeps->reset();'); $ps->text({rotate => -60}, 85, 205, '$directeps->scale(25/$directeps->width(), 50/$directeps->height());'); $ps->text({rotate => -60}, 80, 205, '$ps->importeps($directeps, 80, 210);'); $ps->setcolour("blue"); $ps->box(140, 210, 165, 260); $directeps->reset(); $directeps->scale(50/$directeps->height()); $ps->importeps($directeps, 140, 210); $ps->setcolour("darkblue"); $ps->text({rotate => -60}, 150, 205, '$directeps->reset();'); $ps->text({rotate => -60}, 145, 205, '$directeps->scale(50/$directeps->height());'); $ps->text({rotate => -60}, 140, 205, '$ps->importeps($directeps, 140, 210);'); $ps->setcolour(200, 0, 200); $ps->box(30, 30, 90, 90); $directeps->reset(); $directeps->translate(50, 50); $directeps->rotate(20); $directeps->translate(-50, -50); $eps = new PostScript::Simple(eps => 1, xsize => 100, ysize => 100); $eps->importeps($directeps, 0, 0); $directeps = $eps->geteps(); $directeps->scale(60/100); $ps->importeps($directeps, 30, 30); $ps->setfont("Courier", 10); $y = 80; $ps->text(100, $y-=5, '$directeps->reset();'); $ps->text(100, $y-=5, '$directeps->translate(50, 50);'); $ps->text(100, $y-=5, '$directeps->rotate(20);'); $ps->text(100, $y-=5, '$directeps->translate(-50, -50);'); $ps->text(100, $y-=5, '# round-about way to set clipping path'); $ps->text(100, $y-=5, '$eps = new PostScript::Simple(eps => 1,'); $ps->text(110, $y-=5, 'xsize => 100, ysize => 100);'); $ps->text(100, $y-=5, '$eps->importeps($directeps, 0, 0);'); $ps->text(100, $y-=5, '$directeps = $eps->geteps();'); $ps->text(100, $y-=5, '$directeps->scale(60/100);'); $ps->text(100, $y-=5, '$ps->importeps($directeps, 30, 30);'); # Write out the document. $ps->output("demo.ps"); sub mynewpage { my $ps = shift; my $title = shift; $ps->newpage; $ps->box(10, 10, 200, 287); $ps->line(10, 277, 200, 277); $ps->setfont("Times-Roman", 14); $ps->text(15, 280, "PostScript::Simple example file: $title"); } PostScript-Simple-0.07/examples/oldexample.pl0000755000175000017500000000701710067116607020676 0ustar mcnmcn00000000000000#!/usr/bin/perl use lib qw(../lib); use PostScript::Simple; $t = new PostScript::Simple(landscape => 0, eps => 0, papersize => "a4", copies => "5", colour => 1, clip => 0, units => "mm"); $t->newpage(-1); for ($i=50; $i>10; $i-=5) { $t->arc(100,150,$i,(3*$i),180+(3*$i)); } $t->arc({filled=>1}, 100,150,10,0,270); $t->line(10,10, 10,50); $t->setlinewidth(8); $t->line(90,10, 90,50); $t->linextend(40,90); $t->setcolour("brightred"); $t->circle({filled=>1}, 40, 90, 30); $t->setcolour("darkgreen"); $t->setlinewidth(0.1); for ($i=0; $i<360; $i+=20) { $t->polygon({offset=>[0,0], rotate=>[$i,70,90], filled=>0}, 40,90, 69,92, 75,84);#, 70,88, 40,90); } $t->setlinewidth("thin"); $t->setcolour("darkgreen"); $t->box(20, 10, 80, 20); $t->setcolour("grey30"); $t->box({filled=>1}, 20, 30, 80, 40); $t->setcolour("grey10"); $t->setfont("Bookman", 12); $t->text(5,5, "Matthew"); $t->circletext({align=>"inside"},120,50,30,90,"Circular"); $t->circletext(120,50,30,-90,"Circular"); for ($i=0; $i<340; $i+=45) { $t->circletext({align=>"outside"},120,50,20,$i,"Round"); } $t->newpage; $t->line((10, 20), (30, 40)); $t->linextend(60, 50); $t->line(10,12, 20,12); $t->polygon(10,10, 20,10); $t->setcolour("grey90"); $t->polygon({offset=>[5,5], filled=>0}, 10,10, 15,20, 25,20, 30,10, 15,15, 10,10); $t->setcolour("black"); $t->polygon({offset=>[10,10], rotate=>[45,20,20], filled=>1}, 10,10, 15,20, 25,20, 30,10, 15,15, 10,10); $t->line((0, 100), (100, 0), (255, 0, 0)); $t->newpage(30); $s = new PostScript::Simple(xsize => 50, ysize => 200); $s->box(10, 10, 40, 190); $o = 10; for ($i=12; $i<80; $i+=2) { $t->setcolour($i*3, 0, 0); $t->box({filled=>1}, $o, 10, $i, 40); $o = $i; } $t->line((40, 30), (30, 10)); $t->linextend(60, 0); $t->line((0, 100), (100, 0),(0, 255, 0)); $s->output("test-b.eps"); #$t->importeps({stretch=>1}, "test-b.eps", 10, 100, 200, 200); my $ep = new PostScript::Simple::EPS(file => "test-b.eps"); $ep->rotate(30); $t->importeps($ep, 10, 100); $t->setcolour("red"); $t->box(10,150, 50,190); $t->importepsfile({stretch=>1}, "test-b.eps", 10, 150, 50, 190); $t->setcolour("blue"); $t->box(60,150, 100,190); $t->importepsfile({overlap=>1}, "test-b.eps", 60, 150, 100, 190); $t->setcolour("green"); $t->box(110,150, 150,190); $t->importepsfile("test-b.eps", 110, 150, 150, 190); $t->output("test-a.ps"); # create a new PostScript object $p = new PostScript::Simple(papersize => "a4", colour => 1, units => "in"); # draw some lines and other shapes $p->line(1,1, 1,4); $p->linextend(2,4); $p->box(1.5,1, 2,3.5); $p->circle(2,2, 1); # draw a rotated polygon in a different colour $p->setcolour(0,100,200); $p->polygon({rotate=>45}, 1,1, 1,2, 2,2, 2,1, 1,1); # add some text in red $p->setcolour("red"); $p->setfont("Times-Roman", 20); $p->text(1,1, "Hello"); # write the output to a file $p->output("test-c.eps"); # create a new PostScript object $p = new PostScript::Simple(papersize => "a4", eps => 0, colour => 1, coordorigin => "RightTop", direction => "LeftDown", units => "in"); $p->newpage; # draw some lines and other shapes $p->line(1,1, 1,4); $p->linextend(2,4); $p->box(1.5,1, 2,3.5); $p->circle(2,2, 1); # draw a rotated polygon in a different colour $p->setcolour(0,100,200); $p->polygon({rotate=>45}, 1,1, 1,2, 2,2, 2,1, 1,1); # add some text in red $p->setcolour("red"); $p->setfont("Times-Roman", 20); $p->text(1,1, "Hello"); # write the output to a file $p->output("test-d.eps"); PostScript-Simple-0.07/t/0000700000175000017500000000000010362031024014575 5ustar mcnmcn00000000000000PostScript-Simple-0.07/t/03funcs.t0000755000175000017500000001767510067116607016315 0ustar mcnmcn00000000000000#!/usr/bin/perl use strict; use lib qw(./lib ../lib t/lib); use Test::Simple tests => 44; #use Data::Dumper; use PostScript::Simple; # huge workout of all methods, OK and error conditions my $s = new PostScript::Simple(xsize => 350, ysize => 350, eps => 1, colour => 1); ok( $s ); ok( ! $s->newpage ); eval { $s->output; }; ok( $@ ); ok( $s->setcolour('black') ); ok( $s->setcolour('BLACK') ); ok( ! $s->setcolour('Geddy lee') ); ok( ! $s->setcolour(120, 240) ); ok( $s->setcolour(120, 240, 0) ); ok( $s->setlinewidth(1) ); ok( ! $s->setlinewidth ); ok( $s->line(10,10, 10,20) ); ok( ! $s->line(10,10, 10,20, 50, 50) ); ok( ! $s->line(10,10, 10) ); ok( $s->line(10,10, 10,20, 50, 50, 50) ); ok( $s->linextend(100,100) ); ok( ! $s->linextend(100) ); ok( $s->polygon(10,10, 10,20, 110,10, 110,20) ); #ok( $s->polygon(10,10, 10,20, 110,10, 110,20, 1) ); ok( $s->polygon({rotate=>45,filled=>1}, 10,10, 10,20, 110,10, 110,20) ); ok( $s->polygon({rotate=>[45,20,20]}, 10,10, 10,20, 110,10, 110,20) ); ok( $s->polygon({offset=>[10,10]}, 10,10, 10,20, 110,10, 110,20) ); ok( ! $s->polygon(10,10, 10) ); ok( $s->circle( 120, 120, 30 ) ); ok( $s->circle( {filled=>1}, 120, 120, 30 ) ); ok( ! $s->circle( 120 ) ); ok( ! $s->circle ); ok( $s->box(210,210, 220,230) ); ok( $s->box( {filled=>1}, 215,215, 225,235) ); ok( ! $s->box(210,210, 220) ); ok( $s->setfont('Helvetica', 12) ); ok( ! $s->setfont('Helvetica') ); ok( $s->text( 10, 10, 'Hello World' ) ); ok( $s->text( {align=>"left"}, 10, 10, 'Hello World' ) ); ok( $s->text( {rotate=>56}, 10, 10, 'Hello World' ) ); ok( ! $s->text( 10, 10, 'Hello World', 'foo', 'wobble' ) ); ok( ! $s->text( 10, 10 ) ); ok( ! $s->curve(10,310, 10,320, 110,310, 110) ); ok( $s->curve(10,310, 10,320, 110,310, 110,320) ); ok( $s->curvextend(110,330, 210,330, 210,320) ); ok( ! $s->curvextend(110,330, 210,330, 210) ); ok( length($s->{'pspages'}) eq length(CANNED()) ); ok( $s->{'pspages'} eq CANNED() ); ok( length($s->{'psfunctions'}) eq length(FUNCS()) ); ok( $s->{'psfunctions'} eq FUNCS() ); ok( $s->output('x03.eps') ); unlink 'x03.eps'; #print Dumper $s; ### sub FUNCS { return '/ux {} def /uy {} def /u {} def /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: /Courier-iso ISOLatin1Encoding /Courier REENCODEFONT /Courier-Bold-iso ISOLatin1Encoding /Courier-Bold REENCODEFONT /Courier-BoldOblique-iso ISOLatin1Encoding /Courier-BoldOblique REENCODEFONT /Courier-Oblique-iso ISOLatin1Encoding /Courier-Oblique REENCODEFONT /Helvetica-iso ISOLatin1Encoding /Helvetica REENCODEFONT /Helvetica-Bold-iso ISOLatin1Encoding /Helvetica-Bold REENCODEFONT /Helvetica-BoldOblique-iso ISOLatin1Encoding /Helvetica-BoldOblique REENCODEFONT /Helvetica-Oblique-iso ISOLatin1Encoding /Helvetica-Oblique REENCODEFONT /Times-Roman-iso ISOLatin1Encoding /Times-Roman REENCODEFONT /Times-Bold-iso ISOLatin1Encoding /Times-Bold REENCODEFONT /Times-BoldItalic-iso ISOLatin1Encoding /Times-BoldItalic REENCODEFONT /Times-Italic-iso ISOLatin1Encoding /Times-Italic REENCODEFONT /Symbol-iso ISOLatin1Encoding /Symbol REENCODEFONT /rotabout {3 copy pop translate rotate exch 0 exch sub exch 0 exch sub translate} def /circle {newpath 0 360 arc closepath} bind def /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 '; } sub CANNED { return '(error: Do not use newpage for eps files! ) print flush 0 0 0 setrgbcolor 0 0 0 setrgbcolor (error: bad colour name \'geddy lee\' ) print flush (error: setcolour given invalid arguments: 120, 240, undef ) print flush 0.470588235294118 0.941176470588235 0 setrgbcolor 1 u setlinewidth (error: setlinewidth not given a width ) print flush newpath 10 ux 10 uy moveto 10 ux 20 uy lineto stroke (error: wrong number of args for line ) print flush (error: wrong number of args for line ) print flush 0.196078431372549 0.196078431372549 0.196078431372549 setrgbcolor newpath 10 ux 10 uy moveto 10 ux 20 uy lineto 100 ux 100 uy lineto stroke (error: wrong number of args for linextend ) print flush newpath 10 ux 10 uy moveto 10 ux 20 uy lineto 110 ux 10 uy lineto 110 ux 20 uy lineto stroke gsave 10 ux 10 uy 45 rotabout newpath 10 ux 10 uy moveto 10 ux 20 uy lineto 110 ux 10 uy lineto 110 ux 20 uy lineto fill grestore gsave 20 ux 20 uy 45 rotabout newpath 10 ux 10 uy moveto 10 ux 20 uy lineto 110 ux 10 uy lineto 110 ux 20 uy lineto stroke grestore gsave 10 ux 10 uy translate newpath 10 ux 10 uy moveto 10 ux 20 uy lineto 110 ux 10 uy lineto 110 ux 20 uy lineto stroke grestore (error: bad polygon - not enough points ) print flush 120 ux 120 uy 30 u circle stroke 120 ux 120 uy 30 u circle fill (error: circle: wrong number of arguments ) print flush (error: circle: wrong number of arguments ) print flush 210 ux 210 uy 220 ux 230 uy box stroke 215 ux 215 uy 225 ux 235 uy box fill (error: box: wrong number of arguments ) print flush /Helvetica findfont 12 scalefont setfont (error: wrong number of arguments for setfont ) print flush newpath 10 ux 10 uy moveto (Hello World) show stroke newpath 10 ux 10 uy moveto (Hello World) show stroke newpath 10 ux 10 uy moveto (Hello World) 56 rotate show stroke -56 rotate (error: text: wrong number of arguments ) print flush (error: text: wrong number of arguments ) print flush (error: bad curve definition, wrong number of args ) print flush newpath 10 ux 310 uy moveto 10 ux 320 uy 110 ux 310 uy 110 ux 320 uy curveto 110 ux 330 uy 210 ux 330 uy 210 ux 320 uy curveto stroke (error: bad curvextend definition, wrong number of args ) print flush '; } PostScript-Simple-0.07/t/11file.t0000755000175000017500000002725010067116607016103 0ustar mcnmcn00000000000000#!/usr/bin/perl -w use strict; use lib qw(./lib ../lib t/lib); use Test::Simple tests => 11; #use Data::Dumper; use PostScript::Simple; my $f = "xtest-b.ps"; my $t = new PostScript::Simple(landscape => 0, eps => 0, papersize => "a4", colour => 1, clip => 0, units => "mm"); ok( $t ); $t->newpage(-1); $t->line(10,10, 10,50); $t->setlinewidth(8); $t->line(90,10, 90,50); $t->linextend(40,90); $t->setcolour("brightred"); $t->circle({filled=>1}, 40, 90, 30); $t->setcolour("darkgreen"); $t->setlinewidth(0.1); for (my $i = 0; $i < 360; $i += 20) { $t->polygon({offset=>[0,0], rotate=>[$i,70,90], filled=>0}, 40,90, 69,92, 75,84); } $t->setlinewidth("thin"); $t->setcolour("darkgreen"); $t->box(20, 10, 80, 20); $t->setcolour("grey30"); $t->box({filled=>1}, 20, 30, 80, 40); $t->setcolour("grey10"); $t->setfont("Bookman", 12); $t->text(5,5, "Matthew"); $t->newpage; $t->line((10, 20), (30, 40)); $t->linextend(60, 50); $t->line(10,12, 20,12); $t->polygon(10,10, 20,10); $t->setcolour("grey90"); $t->polygon({offset=>[5,5], filled=>1}, 10,10, 15,20, 25,20, 30,10, 15,15, 10,10, 0); $t->setcolour("black"); $t->polygon({offset=>[10,10], rotate=>[45,20,20]}, 10,10, 15,20, 25,20, 30,10, 15,15, 10,10, 1); $t->line((0, 100), (100, 0), (255, 0, 0)); $t->newpage(30); for (my $i = 12; $i < 80; $i += 2) { $t->setcolour($i*3, 0, 0); $t->box({filled=>1}, $i - 2, 10, $i, 40); } $t->line((40, 30), (30, 10)); $t->linextend(60, 0); $t->line((0, 100), (100, 0),(0, 255, 0)); $t->output( $f ); #$t->output( "x" ); ok( -e $f ); open( FILE, $f ) or die("Can't open $f: $!"); $/ = undef; my $lines = ; close FILE; ok( $lines =~ m/%%LanguageLevel: 1/s ); ok( $lines =~ m/%%DocumentMedia: A4 595.27559 841.88976 0 \( \) \( \)/s ); ok( $lines =~ m/%%Orientation: Portrait/s ); ok( $lines =~ m/%%Pages: 3/s ); ok( index($lines, "%!PS-Adobe-3.0\n") == 0 ); my ( $prolog ) = ( $lines =~ m/%%BeginResource: PostScript::Simple\n(.*)%%EndResource/s ); ok( $prolog ); ok( $prolog eq PROLOG()); my ( $body ) = ( $lines =~ m/%%EndProlog\n(.*)%%EOF/s ); ok( $body ); ok( $body eq BODY()); #print ">>>$body<<<<<<\n"; ### Subs sub PROLOG { return q[/ux {72 mul 25.4 div} def /uy {72 mul 25.4 div} def /u {72 mul 25.4 div} def /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: /Courier-iso ISOLatin1Encoding /Courier REENCODEFONT /Courier-Bold-iso ISOLatin1Encoding /Courier-Bold REENCODEFONT /Courier-BoldOblique-iso ISOLatin1Encoding /Courier-BoldOblique REENCODEFONT /Courier-Oblique-iso ISOLatin1Encoding /Courier-Oblique REENCODEFONT /Helvetica-iso ISOLatin1Encoding /Helvetica REENCODEFONT /Helvetica-Bold-iso ISOLatin1Encoding /Helvetica-Bold REENCODEFONT /Helvetica-BoldOblique-iso ISOLatin1Encoding /Helvetica-BoldOblique REENCODEFONT /Helvetica-Oblique-iso ISOLatin1Encoding /Helvetica-Oblique REENCODEFONT /Times-Roman-iso ISOLatin1Encoding /Times-Roman REENCODEFONT /Times-Bold-iso ISOLatin1Encoding /Times-Bold REENCODEFONT /Times-BoldItalic-iso ISOLatin1Encoding /Times-BoldItalic REENCODEFONT /Times-Italic-iso ISOLatin1Encoding /Times-Italic REENCODEFONT /Symbol-iso ISOLatin1Encoding /Symbol REENCODEFONT /circle {newpath 0 360 arc closepath} bind def /rotabout {3 copy pop translate rotate exch 0 exch sub exch 0 exch sub translate} def /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 ]; } sub BODY { return q[%%BeginSetup ll 2 ge { << /PageSize [ 595.27559 841.88976 ] /ImagingBBox null >> setpagedevice } if %%EndSetup %%Page: -1 1 %%BeginPageSetup /pagelevel save def %%EndPageSetup newpath 10 ux 10 uy moveto 10 ux 50 uy lineto stroke 8 u setlinewidth newpath 90 ux 10 uy moveto 90 ux 50 uy lineto 40 ux 90 uy lineto stroke 1 0 0 setrgbcolor 40 ux 90 uy 30 u circle fill 0 0.5 0 setrgbcolor 0.1 u setlinewidth newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke gsave 70 ux 90 uy 20 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 40 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 60 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 80 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 100 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 120 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 140 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 160 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 180 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 200 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 220 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 240 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 260 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 280 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 300 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 320 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore gsave 70 ux 90 uy 340 rotabout newpath 40 ux 90 uy moveto 69 ux 92 uy lineto 75 ux 84 uy lineto stroke grestore 0.4 setlinewidth 0 0.5 0 setrgbcolor 20 ux 10 uy 80 ux 20 uy box stroke 0.3 0.3 0.3 setrgbcolor 20 ux 30 uy 80 ux 40 uy box fill 0.1 0.1 0.1 setrgbcolor /Bookman findfont 12 scalefont setfont newpath 5 ux 5 uy moveto (Matthew) show stroke %%PageTrailer pagelevel restore showpage %%Page: -2 2 %%BeginPageSetup /pagelevel save def %%EndPageSetup newpath 10 ux 20 uy moveto 30 ux 40 uy lineto 60 ux 50 uy lineto stroke newpath 10 ux 12 uy moveto 20 ux 12 uy lineto stroke newpath 10 ux 10 uy moveto 20 ux 10 uy lineto stroke 0.9 0.9 0.9 setrgbcolor gsave 5 ux 5 uy translate newpath 10 ux 10 uy moveto 15 ux 20 uy lineto 25 ux 20 uy lineto 30 ux 10 uy lineto 15 ux 15 uy lineto 10 ux 10 uy lineto fill grestore 0 0 0 setrgbcolor gsave 10 ux 10 uy translate 20 ux 20 uy 45 rotabout newpath 10 ux 10 uy moveto 15 ux 20 uy lineto 25 ux 20 uy lineto 30 ux 10 uy lineto 15 ux 15 uy lineto 10 ux 10 uy lineto stroke grestore 1 0 0 setrgbcolor newpath 0 ux 100 uy moveto 100 ux 0 uy lineto stroke %%PageTrailer pagelevel restore showpage %%Page: 30 3 %%BeginPageSetup /pagelevel save def %%EndPageSetup 0.141176470588235 0 0 setrgbcolor 10 ux 10 uy 12 ux 40 uy box fill 0.164705882352941 0 0 setrgbcolor 12 ux 10 uy 14 ux 40 uy box fill 0.188235294117647 0 0 setrgbcolor 14 ux 10 uy 16 ux 40 uy box fill 0.211764705882353 0 0 setrgbcolor 16 ux 10 uy 18 ux 40 uy box fill 0.235294117647059 0 0 setrgbcolor 18 ux 10 uy 20 ux 40 uy box fill 0.258823529411765 0 0 setrgbcolor 20 ux 10 uy 22 ux 40 uy box fill 0.282352941176471 0 0 setrgbcolor 22 ux 10 uy 24 ux 40 uy box fill 0.305882352941176 0 0 setrgbcolor 24 ux 10 uy 26 ux 40 uy box fill 0.329411764705882 0 0 setrgbcolor 26 ux 10 uy 28 ux 40 uy box fill 0.352941176470588 0 0 setrgbcolor 28 ux 10 uy 30 ux 40 uy box fill 0.376470588235294 0 0 setrgbcolor 30 ux 10 uy 32 ux 40 uy box fill 0.4 0 0 setrgbcolor 32 ux 10 uy 34 ux 40 uy box fill 0.423529411764706 0 0 setrgbcolor 34 ux 10 uy 36 ux 40 uy box fill 0.447058823529412 0 0 setrgbcolor 36 ux 10 uy 38 ux 40 uy box fill 0.470588235294118 0 0 setrgbcolor 38 ux 10 uy 40 ux 40 uy box fill 0.494117647058824 0 0 setrgbcolor 40 ux 10 uy 42 ux 40 uy box fill 0.517647058823529 0 0 setrgbcolor 42 ux 10 uy 44 ux 40 uy box fill 0.541176470588235 0 0 setrgbcolor 44 ux 10 uy 46 ux 40 uy box fill 0.564705882352941 0 0 setrgbcolor 46 ux 10 uy 48 ux 40 uy box fill 0.588235294117647 0 0 setrgbcolor 48 ux 10 uy 50 ux 40 uy box fill 0.611764705882353 0 0 setrgbcolor 50 ux 10 uy 52 ux 40 uy box fill 0.635294117647059 0 0 setrgbcolor 52 ux 10 uy 54 ux 40 uy box fill 0.658823529411765 0 0 setrgbcolor 54 ux 10 uy 56 ux 40 uy box fill 0.682352941176471 0 0 setrgbcolor 56 ux 10 uy 58 ux 40 uy box fill 0.705882352941177 0 0 setrgbcolor 58 ux 10 uy 60 ux 40 uy box fill 0.729411764705882 0 0 setrgbcolor 60 ux 10 uy 62 ux 40 uy box fill 0.752941176470588 0 0 setrgbcolor 62 ux 10 uy 64 ux 40 uy box fill 0.776470588235294 0 0 setrgbcolor 64 ux 10 uy 66 ux 40 uy box fill 0.8 0 0 setrgbcolor 66 ux 10 uy 68 ux 40 uy box fill 0.823529411764706 0 0 setrgbcolor 68 ux 10 uy 70 ux 40 uy box fill 0.847058823529412 0 0 setrgbcolor 70 ux 10 uy 72 ux 40 uy box fill 0.870588235294118 0 0 setrgbcolor 72 ux 10 uy 74 ux 40 uy box fill 0.894117647058824 0 0 setrgbcolor 74 ux 10 uy 76 ux 40 uy box fill 0.917647058823529 0 0 setrgbcolor 76 ux 10 uy 78 ux 40 uy box fill newpath 40 ux 30 uy moveto 30 ux 10 uy lineto 60 ux 0 uy lineto stroke 0 1 0 setrgbcolor newpath 0 ux 100 uy moveto 100 ux 0 uy lineto stroke %%PageTrailer pagelevel restore showpage ]; } PostScript-Simple-0.07/t/99cleanup.t0000755000175000017500000000030110067116607016617 0ustar mcnmcn00000000000000#!/usr/bin/perl -w use strict; use lib qw(./lib ../lib t/lib); use Test::Simple tests => 3; my @files = qw/xtest-a.ps xtest-b.ps xtest-c.ps/; foreach (@files) { unlink $_; ok( ! -e $_ ); } PostScript-Simple-0.07/t/lib/0000700000175000017500000000000010362031024015343 5ustar mcnmcn00000000000000PostScript-Simple-0.07/t/lib/Test/0000700000175000017500000000000010362031024016262 5ustar mcnmcn00000000000000PostScript-Simple-0.07/t/lib/Test/More.pm0000644000175000017500000005325510067116611017556 0ustar mcnmcn00000000000000package Test::More; use 5.004; use strict; use Carp; use Test::Utils; BEGIN { require Test::Simple; *TESTOUT = \*Test::Simple::TESTOUT; *TESTERR = \*Test::Simple::TESTERR; } require Exporter; use vars qw($VERSION @ISA @EXPORT $TODO); $VERSION = '0.18'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok is isnt like skip todo pass fail eq_array eq_hash eq_set skip $TODO plan can_ok isa_ok ); sub import { my($class, $plan, @args) = @_; if( defined $plan ) { if( $plan eq 'skip_all' ) { $Test::Simple::Skip_All = 1; my $out = "1..0"; $out .= " # Skip @args" if @args; $out .= "\n"; my_print *TESTOUT, $out; exit(0); } else { Test::Simple->import($plan => @args); } } else { Test::Simple->import; } __PACKAGE__->_export_to_level(1, __PACKAGE__); } # 5.004's Exporter doesn't have export_to_level. sub _export_to_level { my $pkg = shift; my $level = shift; (undef) = shift; # XXX redundant arg my $callpkg = caller($level); $pkg->export($callpkg, @_); } =head1 NAME Test::More - yet another framework for writing test scripts =head1 SYNOPSIS use Test::More tests => $Num_Tests; # or use Test::More qw(no_plan); # or use Test::More skip_all => $reason; BEGIN { use_ok( 'Some::Module' ); } require_ok( 'Some::Module' ); # Various ways to say "ok" ok($this eq $that, $test_name); is ($this, $that, $test_name); isnt($this, $that, $test_name); like($this, qr/that/, $test_name); SKIP: { skip $why, $how_many unless $have_some_feature; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; TODO: { local $TODO = $why; ok( foo(), $test_name ); is( foo(42), 23, $test_name ); }; can_ok($module, @methods); isa_ok($object, $class); pass($test_name); fail($test_name); # Utility comparison functions. eq_array(\@this, \@that); eq_hash(\%this, \%that); eq_set(\@this, \@that); # UNIMPLEMENTED!!! my @status = Test::More::status; # UNIMPLEMENTED!!! BAIL_OUT($why); =head1 DESCRIPTION If you're just getting started writing tests, have a look at Test::Simple first. This is a drop in replacement for Test::Simple which you can switch to once you get the hang of basic testing. This module provides a very wide range of testing utilities. Various ways to say "ok", facilities to skip tests, test future features and compare complicated data structures. =head2 I love it when a plan comes together Before anything else, you need a testing plan. This basically declares how many tests your script is going to run to protect against premature failure. The prefered way to do this is to declare a plan when you C. use Test::More tests => $Num_Tests; There are rare cases when you will not know beforehand how many tests your script is going to run. In this case, you can declare that you have no plan. (Try to avoid using this as it weakens your test.) use Test::More qw(no_plan); In some cases, you'll want to completely skip an entire testing script. use Test::More skip_all => $skip_reason; Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. =head2 Test names By convention, each test is assigned a number in order. This is largely done automatically for you. However, its often very useful to assign a name to each test. Which would you rather see: ok 4 not ok 5 ok 6 or ok 4 - basic multi-variable not ok 5 - simple exponential ok 6 - force == mass * acceleration The later gives you some idea of what failed. It also makes it easier to find the test in your script, simply search for "simple exponential". All test functions take a name argument. Its optional, but highly suggested that you use it. =head2 I'm ok, you're not ok. The basic purpose of this module is to print out either "ok #" or "not ok #" depending on if a given test succeeded or failed. Everything else is just gravy. All of the following print "ok" or "not ok" depending on if the test succeeded or failed. They all also return true or false, respectively. =over 4 =item B ok($this eq $that, $test_name); This simply evaluates any expression (C<$this eq $that> is just a simple example) and uses that to determine if the test succeeded or failed. A true expression passes, a false one fails. Very simple. For example: ok( $exp{9} == 81, 'simple exponential' ); ok( Film->can('db_Main'), 'set_db()' ); ok( $p->tests == 4, 'saw tests' ); ok( !grep !defined $_, @items, 'items populated' ); (Mnemonic: "This is ok.") $test_name is a very short description of the test that will be printed out. It makes it very easy to find a test in your script when it fails and gives others an idea of your intentions. $test_name is optional, but we B strongly encourage its use. Should an ok() fail, it will produce some diagnostics: not ok 18 - sufficient mucus # Failed test 18 (foo.t at line 42) This is actually Test::Simple's ok() routine. =cut # We get ok() from Test::Simple's import(). =item B =item B is ( $this, $that, $test_name ); isnt( $this, $that, $test_name ); Similar to ok(), is() and isnt() compare their two arguments with C and C respectively and use the result of that to determine if the test succeeded or failed. So these: # Is the ultimate answer 42? is( ultimate_answer(), 42, "Meaning of Life" ); # $foo isn't empty isnt( $foo, '', "Got some foo" ); are similar to these: ok( ultimate_answer() eq 42, "Meaning of Life" ); ok( $foo ne '', "Got some foo" ); (Mnemonic: "This is that." "This isn't that.") So why use these? They produce better diagnostics on failure. ok() cannot know what you are testing for (beyond the name), but is() and isnt() know what the test was and why it failed. For example this test: my $foo = 'waffle'; my $bar = 'yarblokos'; is( $foo, $bar, 'Is foo the same as bar?' ); Will produce something like this: not ok 17 - Is foo the same as bar? # Failed test 1 (foo.t at line 139) # got: 'waffle' # expected: 'yarblokos' So you can figure out what went wrong without rerunning the test. You are encouraged to use is() and isnt() over ok() where possible, however do not be tempted to use them to find out if something is true or false! # XXX BAD! $pope->isa('Catholic') eq 1 is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); This does not check if C<$pope->isa('Catholic')> is true, it checks if it returns 1. Very different. Similar caveats exist for false and 0. In these cases, use ok(). ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); For those grammatical pedants out there, there's an C function which is an alias of isnt(). =cut sub is ($$;$) { my($this, $that, $name) = @_; my $test; { local $^W = 0; # so is(undef, undef) works quietly. $test = $this eq $that; } my $ok = @_ == 3 ? ok($test, $name) : ok($test); unless( $ok ) { $this = defined $this ? "'$this'" : 'undef'; $that = defined $that ? "'$that'" : 'undef'; my_print *TESTERR, sprintf < like( $this, qr/that/, $test_name ); Similar to ok(), like() matches $this against the regex C. So this: like($this, qr/that/, 'this is like that'); is similar to: ok( $this =~ /that/, 'this is like that'); (Mnemonic "This is like that".) The second argument is a regular expression. It may be given as a regex reference (ie. C) or (for better compatibility with older perls) as a string that looks like a regex (alternative delimiters are currently not supported): like( $this, '/that/', 'this is like that' ); Regex options may be placed on the end (C<'/that/i'>). Its advantages over ok() are similar to that of is() and isnt(). Better diagnostics on failure. =cut sub like ($$;$) { my($this, $regex, $name) = @_; my $ok = 0; if( ref $regex eq 'Regexp' ) { local $^W = 0; $ok = @_ == 3 ? ok( $this =~ $regex ? 1 : 0, $name ) : ok( $this =~ $regex ? 1 : 0 ); } # Check if it looks like '/foo/i' elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { local $^W = 0; $ok = @_ == 3 ? ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name ) : ok( $this =~ /(?$opts)$re/ ? 1 : 0 ); } else { # Can't use fail() here, the call stack will be fucked. my $ok = @_ == 3 ? ok(0, $name ) : ok(0); my_print *TESTERR, < can_ok($module, @methods); can_ok($object, @methods); Checks to make sure the $module or $object can do these @methods (works with functions, too). can_ok('Foo', qw(this that whatever)); is almost exactly like saying: ok( Foo->can('this') && Foo->can('that') && Foo->can('whatever') ); only without all the typing and with a better interface. Handy for quickly testing an interface. =cut sub can_ok ($@) { my($proto, @methods) = @_; my $class= ref $proto || $proto; my @nok = (); foreach my $method (@methods) { my $test = "$class->can('$method')"; eval $test || push @nok, $method; } my $name; $name = @methods == 1 ? "$class->can($methods[0])" : "$class->can(...)"; ok( !@nok, $name ); my_print *TESTERR, map "# $class->can('$_') failed\n", @nok; return !@nok; } =item B isa_ok($object, $class); Checks to see if the given $object->isa($class). Also checks to make sure the object was defined in the first place. Handy for this sort of thing: my $obj = Some::Module->new; isa_ok( $obj, 'Some::Module' ); where you'd otherwise have to write my $obj = Some::Module->new; ok( defined $obj && $obj->isa('Some::Module') ); to safeguard against your test script blowing up. =cut sub isa_ok ($$) { my($object, $class) = @_; my $diag; my $name = "object->isa('$class')"; if( !defined $object ) { $diag = "The object isn't defined"; } elsif( !ref $object ) { $diag = "The object isn't a reference"; } elsif( !$object->isa($class) ) { $diag = "The object isn't a '$class'"; } if( $diag ) { ok( 0, $name ); my_print *TESTERR, "# $diag\n"; return 0; } else { ok( 1, $name ); return 1; } } =item B =item B pass($test_name); fail($test_name); Sometimes you just want to say that the tests have passed. Usually the case is you've got some complicated condition that is difficult to wedge into an ok(). In this case, you can simply use pass() (to declare the test ok) or fail (for not ok). They are synonyms for ok(1) and ok(0). Use these very, very, very sparingly. =cut sub pass (;$) { my($name) = @_; return @_ == 1 ? ok(1, $name) : ok(1); } sub fail (;$) { my($name) = @_; return @_ == 1 ? ok(0, $name) : ok(0); } =back =head2 Module tests You usually want to test if the module you're testing loads ok, rather than just vomiting if its load fails. For such purposes we have C and C. =over 4 =item B BEGIN { use_ok($module); } BEGIN { use_ok($module, @imports); } These simply use the given $module and test to make sure the load happened ok. Its recommended that you run use_ok() inside a BEGIN block so its functions are exported at compile-time and prototypes are properly honored. If @imports are given, they are passed through to the use. So this: BEGIN { use_ok('Some::Module', qw(foo bar)) } is like doing this: use Some::Module qw(foo bar); =cut sub use_ok ($;@) { my($module, @imports) = @_; @imports = () unless @imports; my $pack = caller; eval <import(\@imports); USE my $ok = ok( !$@, "use $module;" ); unless( $ok ) { my_print *TESTERR, < require_ok($module); Like use_ok(), except it requires the $module. =cut sub require_ok ($) { my($module) = shift; my $pack = caller; eval < The following describes an I interface that is subject to change B! Use at your peril. Sometimes running a test under certain conditions will cause the test script to die. A certain function or method isn't implemented (such as fork() on MacOS), some resource isn't available (like a net connection) or a module isn't available. In these cases it's necessary to skip tests, or declare that they are supposed to fail but will work in the future (a todo test). For more details on skip and todo tests see L. The way Test::More handles this is with a named block. Basically, a block of tests which can be skipped over or made todo. It's best if I just show you... =over 4 =item B SKIP: { skip $why, $how_many if $condition; ...normal testing code goes here... } This declares a block of tests to skip, $how_many tests there are, $why and under what $condition to skip them. An example is the easiest way to illustrate: SKIP: { skip "Pigs don't fly here", 2 unless Pigs->can('fly'); my $pig = Pigs->new; $pig->takeoff; ok( $pig->altitude > 0, 'Pig is airborne' ); ok( $pig->airspeed > 0, ' and moving' ); } If pigs cannot fly, the whole block of tests will be skipped completely. Test::More will output special ok's which Test::Harness interprets as skipped tests. Its important to include $how_many tests are in the block so the total number of tests comes out right (unless you're using C). You'll typically use this when a feature is missing, like an optional module is not installed or the operating system doesn't have some feature (like fork() or symlinks) or maybe you need an Internet connection and one isn't available. =for _Future See L =cut #'# sub skip { my($why, $how_many) = @_; unless( $how_many >= 1 ) { # $how_many can only be avoided when no_plan is in use. carp "skip() needs to know \$how_many tests are in the block" if $Test::Simple::Planned_Tests; $how_many = 1; } for( 1..$how_many ) { Test::Simple::_skipped($why); } local $^W = 0; last SKIP; } =item B TODO: { local $TODO = $why; ...normal testing code goes here... } Declares a block of tests you expect to fail and $why. Perhaps it's because you haven't fixed a bug or haven't finished a new feature: TODO: { local $TODO = "URI::Geller not finished"; my $card = "Eight of clubs"; is( URI::Geller->your_card, $card, 'Is THIS your card?' ); my $spoon; URI::Geller->bend_spoon; is( $spoon, 'bent', "Spoon bending, that's original" ); } With a todo block, the tests inside are expected to fail. Test::More will run the tests normally, but print out special flags indicating they are "todo". Test::Harness will interpret failures as being ok. Should anything succeed, it will report it as an unexpected success. The nice part about todo tests, as opposed to simply commenting out a block of tests, is it's like having a programatic todo list. You know how much work is left to be done, you're aware of what bugs there are, and you'll know immediately when they're fixed. Once a todo test starts succeeding, simply move it outside the block. When the block is empty, delete it. =back =head2 Comparision functions Not everything is a simple eq check or regex. There are times you need to see if two arrays are equivalent, for instance. For these instances, Test::More provides a handful of useful functions. B These are NOT well-tested on circular references. Nor am I quite sure what will happen with filehandles. =over 4 =item B eq_array(\@this, \@that); Checks if two arrays are equivalent. This is a deep check, so multi-level structures are handled correctly. =cut #'# sub eq_array { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; return 1 if $a1 eq $a2; my $ok = 1; for (0..$#{$a1}) { my($e1,$e2) = ($a1->[$_], $a2->[$_]); $ok = _deep_check($e1,$e2); last unless $ok; } return $ok; } sub _deep_check { my($e1, $e2) = @_; my $ok = 0; my $eq; { # Quiet unintialized value warnings when comparing undefs. local $^W = 0; if( $e1 eq $e2 ) { $ok = 1; } else { if( UNIVERSAL::isa($e1, 'ARRAY') and UNIVERSAL::isa($e2, 'ARRAY') ) { $ok = eq_array($e1, $e2); } elsif( UNIVERSAL::isa($e1, 'HASH') and UNIVERSAL::isa($e2, 'HASH') ) { $ok = eq_hash($e1, $e2); } else { $ok = 0; } } } return $ok; } =item B eq_hash(\%this, \%that); Determines if the two hashes contain the same keys and values. This is a deep check. =cut sub eq_hash { my($a1, $a2) = @_; return 0 unless keys %$a1 == keys %$a2; return 1 if $a1 eq $a2; my $ok = 1; foreach my $k (keys %$a1) { my($e1, $e2) = ($a1->{$k}, $a2->{$k}); $ok = _deep_check($e1, $e2); last unless $ok; } return $ok; } =item B eq_set(\@this, \@that); Similar to eq_array(), except the order of the elements is B important. This is a deep check, but the irrelevancy of order only applies to the top level. =cut # We must make sure that references are treated neutrally. It really # doesn't matter how we sort them, as long as both arrays are sorted # with the same algorithm. sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } sub eq_set { my($a1, $a2) = @_; return 0 unless @$a1 == @$a2; # There's faster ways to do this, but this is easiest. return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); } =back =head1 NOTES Test::More is B tested all the way back to perl 5.004. =head1 BUGS and CAVEATS =over 4 =item Making your own ok() This will not do what you mean: sub my_ok { ok( @_ ); } my_ok( 2 + 2 == 5, 'Basic addition' ); since ok() takes it's arguments as scalars, it will see the length of @_ (2) and always pass the test. You want to do this instead: sub my_ok { ok( $_[0], $_[1] ); } The other functions act similiarly. =item The eq_* family have some caveats. =item Test::Harness upgrades no_plan and todo depend on new Test::Harness features and fixes. If you're going to distribute tests that use no_plan your end-users will have to upgrade Test::Harness to the latest one on CPAN. If you simply depend on Test::More, it's own dependencies will cause a Test::Harness upgrade. =back =head1 AUTHOR Michael G Schwern Eschwern@pobox.comE with much inspiration from Joshua Pritikin's Test module and lots of discussion with Barrie Slaymaker and the perl-qa gang. =head1 HISTORY This is a case of convergent evolution with Joshua Pritikin's Test module. I was largely unware of its existence when I'd first written my own ok() routines. This module exists because I can't figure out how to easily wedge test names into Test's interface (along with a few other problems). The goal here is to have a testing utility that's simple to learn, quick to use and difficult to trip yourself up with while still providing more flexibility than the existing Test.pm. As such, the names of the most common routines are kept tiny, special cases and magic side-effects are kept to a minimum. WYSIWYG. =head1 SEE ALSO L if all this confuses you and you just want to write some tests. You can upgrade to Test::More later (its forward compatible). L for a similar testing module. L for details on how your test results are interpreted by Perl. L describes a very featureful unit testing interface. L shows the idea of embedded testing. L is another approach to embedded testing. =cut 1; PostScript-Simple-0.07/t/lib/Test/Simple.pm0000644000175000017500000003070310067116611020076 0ustar mcnmcn00000000000000package Test::Simple; use 5.004; use strict 'vars'; use Test::Utils; use vars qw($VERSION); $VERSION = '0.18'; my(@Test_Results) = (); my($Num_Tests, $Planned_Tests, $Test_Died) = (0,0,0); my($Have_Plan) = 0; my $IsVMS = $^O eq 'VMS'; # I'd like to have Test::Simple interfere with the program being # tested as little as possible. This includes using Exporter or # anything else (including strict). sub import { # preserve caller() if( @_ > 1 ) { if( $_[1] eq 'no_plan' ) { goto &no_plan; } else { goto &plan } } } sub plan { my($class, %config) = @_; if( !exists $config{tests} ) { die "You have to tell $class how many tests you plan to run.\n". " use $class tests => 42; for example.\n"; } elsif( !defined $config{tests} ) { die "Got an undefined number of tests. Looks like you tried to tell ". "$class how many tests you plan to run but made a mistake.\n"; } elsif( !$config{tests} ) { die "You told $class you plan to run 0 tests! You've got to run ". "something.\n"; } else { $Planned_Tests = $config{tests}; } $Have_Plan = 1; my_print *TESTOUT, "1..$Planned_Tests\n"; no strict 'refs'; my($caller) = caller; *{$caller.'::ok'} = \&ok; } sub no_plan { $Have_Plan = 1; my($caller) = caller; no strict 'refs'; *{$caller.'::ok'} = \&ok; } $| = 1; open(*TESTOUT, ">&STDOUT") or _whoa(1, "Can't dup STDOUT!"); open(*TESTERR, ">&STDERR") or _whoa(1, "Can't dup STDERR!"); { my $orig_fh = select TESTOUT; $| = 1; select TESTERR; $| = 1; select $orig_fh; } =head1 NAME Test::Simple - Basic utilities for writing tests. =head1 SYNOPSIS use Test::Simple tests => 1; ok( $foo eq $bar, 'foo is bar' ); =head1 DESCRIPTION ** If you are unfamiliar with testing B first! ** This is an extremely simple, extremely basic module for writing tests suitable for CPAN modules and other pursuits. If you wish to do more complicated testing, use the Test::More module (a drop-in replacement for this one). The basic unit of Perl testing is the ok. For each thing you want to test your program will print out an "ok" or "not ok" to indicate pass or fail. You do this with the ok() function (see below). The only other constraint is you must predeclare how many tests you plan to run. This is in case something goes horribly wrong during the test and your test program aborts, or skips a test or whatever. You do this like so: use Test::Simple tests => 23; You must have a plan. =over 4 =item B ok( $foo eq $bar, $name ); ok( $foo eq $bar ); ok() is given an expression (in this case C<$foo eq $bar>). If its true, the test passed. If its false, it didn't. That's about it. ok() prints out either "ok" or "not ok" along with a test number (it keeps track of that for you). # This produces "ok 1 - Hell not yet frozen over" (or not ok) ok( get_temperature($hell) > 0, 'Hell not yet frozen over' ); If you provide a $name, that will be printed along with the "ok/not ok" to make it easier to find your test when if fails (just search for the name). It also makes it easier for the next guy to understand what your test is for. Its highly recommended you use test names. All tests are run in scalar context. So this: ok( @stuff, 'I have some stuff' ); will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { my($test, $name) = @_; unless( $Have_Plan ) { die "You tried to use ok() without a plan! Gotta have a plan.\n". " use Test::Simple tests => 23; for example.\n"; } $Num_Tests++; my_print *TESTERR, < 23; for example.\n"; } $Num_Tests++; # XXX Set this to "Skip" instead? $Test_Results[$Num_Tests-1] = 1; # We must print this all in one shot or else it will break on VMS my $msg; $msg .= "ok $Num_Tests # skip $why\n"; my_print *TESTOUT, $msg; return 1; } =back Test::Simple will start by printing number of tests run in the form "1..M" (so "1..5" means you're going to run 5 tests). This strange format lets Test::Harness know how many tests you plan on running in case something goes horribly wrong. If all your tests passed, Test::Simple will exit with zero (which is normal). If anything failed it will exit with how many failed. If you run less (or more) tests than you planned, the missing (or extras) will be considered failures. If no tests were ever run Test::Simple will throw a warning and exit with 255. If the test died, even after having successfully completed all its tests, it will still be considered a failure and will exit with 255. So the exit codes are... 0 all tests successful 255 test died any other number how many failed (including missing or extras) If you fail more than 254 tests, it will be reported as 254. =begin _private =over 4 =item B<_sanity_check> _sanity_check(); Runs a bunch of end of test sanity checks to make sure reality came through ok. If anything is wrong it will die with a fairly friendly error message. =cut #'# sub _sanity_check { _whoa($Num_Tests < 0, 'Says here you ran a negative number of tests!'); _whoa(!$Have_Plan and $Num_Tests, 'Somehow your tests ran without a plan!'); _whoa($Num_Tests != @Test_Results, 'Somehow you got a different number of results than tests ran!'); } =item B<_whoa> _whoa($check, $description); A sanity check, similar to assert(). If the $check is true, something has gone horribly wrong. It will die with the given $description and a note to contact the author. =cut sub _whoa { my($check, $desc) = @_; if( $check ) { die < _my_exit($exit_num); Perl seems to have some trouble with exiting inside an END block. 5.005_03 and 5.6.1 both seem to do odd things. Instead, this function edits $? directly. It should ONLY be called from inside an END block. It doesn't actually exit, that's your job. =cut sub _my_exit { $? = $_[0]; return 1; } =back =end _private =cut $SIG{__DIE__} = sub { # We don't want to muck with death in an eval, but $^S isn't # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing # with it. Instead, we use caller. This also means it runs under # 5.004! my $in_eval = 0; for( my $stack = 1; my $sub = (caller($stack))[3]; $stack++ ) { $in_eval = 1 if $sub =~ /^\(eval\)/; } $Test_Died = 1 unless $in_eval; }; END { _sanity_check(); # Bailout if import() was never called. This is so # "require Test::Simple" doesn't puke. do{ _my_exit(0) && return } if !$Have_Plan and !$Num_Tests; # Figure out if we passed or failed and print helpful messages. if( $Num_Tests ) { # The plan? We have no plan. unless( $Planned_Tests ) { my_print *TESTOUT, "1..$Num_Tests\n"; $Planned_Tests = $Num_Tests; } my $num_failed = grep !$_, @Test_Results[0..$Planned_Tests-1]; $num_failed += abs($Planned_Tests - @Test_Results); if( $Num_Tests < $Planned_Tests ) { my_print *TESTERR, <<"FAIL"; # Looks like you planned $Planned_Tests tests but only ran $Num_Tests. FAIL } elsif( $Num_Tests > $Planned_Tests ) { my $num_extra = $Num_Tests - $Planned_Tests; my_print *TESTERR, <<"FAIL"; # Looks like you planned $Planned_Tests tests but ran $num_extra extra. FAIL } elsif ( $num_failed ) { my_print *TESTERR, <<"FAIL"; # Looks like you failed $num_failed tests of $Planned_Tests. FAIL } if( $Test_Died ) { my_print *TESTERR, <<"FAIL"; # Looks like your test died just after $Num_Tests. FAIL _my_exit( 255 ) && return; } _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; } elsif ( $Test::Simple::Skip_All ) { _my_exit( 0 ) && return; } else { my_print *TESTERR, "# No tests run!\n"; _my_exit( 255 ) && return; } } =pod This module is by no means trying to be a complete testing system. Its just to get you started. Once you're off the ground its recommended you look at L. =head1 EXAMPLE Here's an example of a simple .t file for the fictional Film module. use Test::Simple tests => 5; use Film; # What you're testing. my $btaste = Film->new({ Title => 'Bad Taste', Director => 'Peter Jackson', Rating => 'R', NumExplodingSheep => 1 }); ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' ); ok( $btaste->Title eq 'Bad Taste', 'Title() get' ); ok( $btaste->Director eq 'Peter Jackson', 'Director() get' ); ok( $btaste->Rating eq 'R', 'Rating() get' ); ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' ); It will produce output like this: 1..5 ok 1 - new() works ok 2 - Title() get ok 3 - Director() get not ok 4 - Rating() get # Failed test (t/film.t at line 14) ok 5 - NumExplodingSheep() get # Looks like you failed 1 tests of 5 Indicating the Film::Rating() method is broken. =head1 CAVEATS Test::Simple will only report a maximum of 254 failures in its exit code. If this is a problem, you probably have a huge test script. Split it into multiple files. (Otherwise blame the Unix folks for using an unsigned short integer as the exit status). Because VMS's exit codes are much, much different than the rest of the universe, and perl does horrible mangling to them that gets in my way, it works like this on VMS. 0 SS$_NORMAL all tests successful 4 SS$_ABORT something went wrong Unfortunately, I can't differentiate any further. =head1 NOTES Test::Simple is B tested all the way back to perl 5.004. =head1 HISTORY This module was conceived while talking with Tony Bowden in his kitchen one night about the problems I was having writing some really complicated feature into the new Testing module. He observed that the main problem is not dealing with these edge cases but that people hate to write tests B. What was needed was a dead simple module that took all the hard work out of testing and was really, really easy to learn. Paul Johnson simultaneously had this idea (unfortunately, he wasn't in Tony's kitchen). This is it. =head1 AUTHOR Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern Eschwern@pobox.comE, wardrobe by Calvin Klein. =head1 SEE ALSO =over 4 =item L More testing functions! Once you outgrow Test::Simple, look at Test::More. Test::Simple is 100% forward compatible with Test::More (ie. you can just use Test::More instead of Test::Simple in your programs and things will still work). =item L The original Perl testing module. =item L Elaborate unit testing. =item L, L Embed tests in your code! =item L Interprets the output of your test program. =back =cut 1; PostScript-Simple-0.07/t/lib/Test/Utils.pm0000644000175000017500000000063410067116611017745 0ustar mcnmcn00000000000000package Test::Utils; use 5.004; use strict; require Exporter; use vars qw($VERSION @EXPORT @EXPORT_TAGS @ISA); $VERSION = '0.02'; @ISA = qw(Exporter); @EXPORT = qw( my_print print ); # Special print function to guard against $\ and -l munging. sub my_print (*@) { my($fh, @args) = @_; local $\; print $fh @args; } sub print { die "DON'T USE PRINT! Use _print instead" } 1; PostScript-Simple-0.07/t/12file.t0000755000175000017500000000411110067116607016073 0ustar mcnmcn00000000000000#!/usr/bin/perl -w use strict; use lib qw(./lib ../lib t/lib); use Test::Simple tests => 3; #use Data::Dumper; use PostScript::Simple; my $f = "xtest-c.ps"; my $p = new PostScript::Simple(papersize => "a4", colour => 1, units => "in", eps => 0, reencode => undef); ok( $p ); # create a new page $p->newpage; # draw some lines and other shapes $p->line(1,1, 1,4); $p->linextend(2,4); $p->box(1.5,1, 2,3.5); $p->circle(2,2, 1); # draw a rotated polygon in a different colour $p->setcolour(0,100,200); $p->polygon({rotate=>45}, 1,1, 1,2, 2,2, 2,1, 1,1); # add some text in red $p->setcolour("red", "blue"); $p->setcolour(255,0,0); $p->setfont("Times-Roman", 20); $p->text({rotate=>-37.5}, 1,1, "Hello"); # write the output to a file $p->output( $f ); ok( -e $f ); open( FILE, $f ) or die("Can't open $f: $!"); my $lines; while () { next if m/^%%/; $lines .= $_; } close FILE; ok( $lines eq CANNED() ); ### sub CANNED { return q[%!PS-Adobe-3.0 /ll 1 def systemdict /languagelevel known { /ll languagelevel def } if /ux {72 mul} def /uy {72 mul} def /u {72 mul} def /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 /circle {newpath 0 360 arc closepath} bind def /rotabout {3 copy pop translate rotate exch 0 exch sub exch 0 exch sub translate} def ll 2 ge { << /PageSize [ 595.27559 841.88976 ] /ImagingBBox null >> setpagedevice } if /pagelevel save def newpath 1 ux 1 uy moveto 1 ux 4 uy lineto 2 ux 4 uy lineto stroke 1.5 ux 1 uy 2 ux 3.5 uy box stroke 2 ux 2 uy 1 u circle stroke 0 0.392156862745098 0.784313725490196 setrgbcolor gsave 1 ux 1 uy 45 rotabout newpath 1 ux 1 uy moveto 1 ux 2 uy lineto 2 ux 2 uy lineto 2 ux 1 uy lineto 1 ux 1 uy lineto stroke grestore (error: setcolour given invalid arguments: red, blue, undef ) print flush 1 0 0 setrgbcolor /Times-Roman findfont 20 scalefont setfont newpath 1 ux 1 uy moveto (Hello) -37.5 rotate show stroke 37.5 rotate pagelevel restore showpage ]; } PostScript-Simple-0.07/t/10file.t0000755000175000017500000000134410067116607016076 0ustar mcnmcn00000000000000#!/usr/bin/perl -w use strict; use lib qw(./lib ../lib t/lib); use Test::Simple tests => 7; #use Data::Dumper; use PostScript::Simple; my $f = 'xtest-a.ps'; my $s = new PostScript::Simple(xsize => 50, ysize => 200); $s->box(10, 10, 40, 190); $s->output( $f ); #print STDERR Dumper $s; # check object ok( $s->{usedbox} == 1 ); ok( $s->{psfunctions} =~ m|/u | ); ok( index( $s->{pspages}, q[10 ux 10 uy 40 ux 190 uy box stroke]) > -1 ); # check output ok( -e $f ); open( CHK, $f ) or die("Can't open the file $f: $!"); $/ = undef; my $file = ; close CHK; ok( index( $file, '%!PS-Adobe-3.0 EPSF-1.2' ) == 0 ); ok( index( $file, '%%EOF' ) == (length( $file ) - 6) ); ok( index( $file, '10 ux 10 uy 40 ux 190 uy box stroke' ) > 0 ); PostScript-Simple-0.07/t/01base.t0000755000175000017500000000111110067116607016061 0ustar mcnmcn00000000000000#!/usr/bin/perl -w use strict; use lib qw(./lib ../lib t/lib); use Test::Simple tests => 10; #use Data::Dumper; use PostScript::Simple; ok( $PostScript::Simple::VERSION ); # module loads my $p = new PostScript::Simple(papersize => "A4", colour => 1,); ok( $p ); # object creation ok( $p->{xsize} == 595.27559 ); ok( $p->{ysize} == 841.88976 ); ok( $p->{colour} == 1 ); ok( $p->{eps} == 1 ); ok( $p->{page} == 1 ); ok( $p->{landscape} == 0 ); ok( $p->{units} eq 'bp' ); ok( $p->{papersize} eq 'A4' ); # basic test for default values #print Dumper $p; PostScript-Simple-0.07/t/02text.t0000755000175000017500000000371510067116607016150 0ustar mcnmcn00000000000000#!/usr/bin/perl use strict; use lib qw(./lib ../lib t/lib); use Test::Simple tests => 2; #use Data::Dumper; use PostScript::Simple; my $s = new PostScript::Simple(xsize => 200, ysize => 250, eps => 1); $s->text( 10, 10, 'Hello World' ); $s->text( {align => "right"}, 10, 10, 'Hello World' ); $s->text( 10, 20, '' ); $s->text( 10, 30, "\000" ); $s->text( 10, 40, undef ); $s->text( 10, 50, 'ONE TWO THREE~~~~' ); $s->text( {align => "center", rotate => 49}, 40, 80, 'ONE TWO THREE~~~~' ); $s->text( 10, 60, join('', map { chr $_ } (0 .. 19)) ); $s->text( 10, 70, join('', map { chr $_ } (20 .. 39)) ); $s->text( 10, 80, join('', map { chr $_ } (120 .. 139)) ); $s->text( 10, 90, join('', map { chr $_ } (140 .. 159)) ); $s->text( 10, 100, '((()))()()()}{}{}][[]]})()})(]' ); ok( length($s->{'pspages'}) eq length(CANNED()) ); ok( $s->{'pspages'} eq CANNED() ); #print STDERR $s->{'pspages'} . "\n"; #print Dumper $s; #$s->output('text.eps'); sub CANNED { return 'newpath 10 ux 10 uy moveto (Hello World) show stroke newpath 10 ux 10 uy moveto (Hello World) dup stringwidth pop neg 0 rmoveto show newpath 10 ux 20 uy moveto () show stroke newpath 10 ux 30 uy moveto (\000) show stroke (error: text: wrong number of arguments ) print flush newpath 10 ux 50 uy moveto (ONE TWO THREE~~~~) show stroke newpath 40 ux 80 uy moveto (ONE TWO THREE~~~~) 49 rotate dup stringwidth pop 2 div neg 0 rmoveto show -49 rotate newpath 10 ux 60 uy moveto (\000\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017\020\021\022\023) show stroke newpath 10 ux 70 uy moveto (\024\025\026\027\030\031\032\033\034\035\036\037 !"#$%&\') show stroke newpath 10 ux 80 uy moveto (xyz{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213) show stroke newpath 10 ux 90 uy moveto (\214\215\216\217\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237) show stroke newpath 10 ux 100 uy moveto (\(\(\(\)\)\)\(\)\(\)\(\)}{}{}][[]]}\)\(\)}\)\(]) show stroke '; } PostScript-Simple-0.07/Makefile.PL0000644000175000017500000000102310067116606016326 0ustar mcnmcn00000000000000use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'PostScript::Simple', 'VERSION_FROM' => 'lib/PostScript/Simple.pm', # finds $VERSION 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1 ($] >= 5.005 ? ## Add these new keywords supported since 5.005 (ABSTRACT_FROM => 'lib/PostScript/Simple.pm', # retrieve abstract from module AUTHOR => 'Matthew Newton ') : ()), ); PostScript-Simple-0.07/TODO0000644000175000017500000000127410067116606015054 0ustar mcnmcn00000000000000TO-DO import eps files into the postscript (in progress, core finished) better error reporting (postscript comments still?) check landscape: possible problems with rotation PostScript "compression", i.e. /n {newpath} bind def code compression using single letter dictionary defs (optional?) any postscript optimisation that can be done? hope that units are now correct... check postscript font support? define shape functions translate / scale / rotate functions? generate PostScript using a stack, rather than writing to the end of a text variable? could lead to some rather neat stuff (loops etc) (moved to ps:s "next gen") different line styles (dashes) (easy) ttf font support? (get lost!) PostScript-Simple-0.07/META.yml0000644000175000017500000000047610362031024015624 0ustar mcnmcn00000000000000# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: PostScript-Simple version: 0.07 version_from: lib/PostScript/Simple.pm installdirs: site requires: distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 PostScript-Simple-0.07/README0000644000175000017500000000463710124105467015247 0ustar mcnmcn00000000000000PostScript/Simple version 0.06 ============================== PostScript::Simple allows you to have a simple method of writing PostScript files from Perl. It has several graphics primitives that allow lines, circles, polygons and boxes to be drawn. Text can be added to the page using standard PostScript fonts. Features include: Generation of multi-page PostScript files Generation of single-page EPS files Creating lines/circles etc. Rectangles and boxes Text Colour Pre-defined paper sizes Etc. etc. The file examples/example.pl provides some bad examples of what this module does. An experimental Subversion repository of PostScript::Simple is now available at http://svn.newtoncomputing.co.uk/pss. Username is "anonymous" with a blank password. The latest version can be checked out with the following command: svn co http://svn.newtoncomputing.co.uk/pss/trunk simple This will put the files in a directory named "simple". To take a look at the next generation version of PostScript::Simple, currently in very slow development, try: svn co http://svn.newtoncomputing.co.uk/pss/branches/nextgen Which will create the directory "nextgen" for the files to go in. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install COPYRIGHT AND LICENCE Copyright (C) 2002-2003 Matthew C. Newton / Newton Computing 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 2. 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, available at http://www.gnu.org/licenses/gpl.html. ACKNOWLEDGEMENTS Many people have contributed in different ways to PostScript::Simple. Thanks go to everyone involved! People who have helped include (in no particular order): Mark Withall, Andreas Riechert, P Kent, Flemming Frandsen, Michael Tomuschat, Vladi Belperchinov-Shabanski, Eric Voisard, Martin McCarthy, Eric Wilhelm, Glen Harris, Peter Kuehn, Tomas Karlsson I apologise if you should be here and I have missed you, please let me know. If you have sent me a patch for this module, and had no reply, please re-send it. I'm particularly bad at missing e-mails... PostScript-Simple-0.07/MANIFEST0000644000175000017500000000056710067116606015521 0ustar mcnmcn00000000000000Changes MANIFEST Makefile.PL README TODO examples/example.pl examples/oldexample.pl examples/demo.ps lib/PostScript/Simple.pm lib/PostScript/Simple/EPS.pm t/01base.t t/02text.t t/03funcs.t t/10file.t t/11file.t t/12file.t t/99cleanup.t t/lib/Test/More.pm t/lib/Test/Simple.pm t/lib/Test/Utils.pm META.yml Module meta-data (added by MakeMaker) PostScript-Simple-0.07/lib/0000700000175000017500000000000010362031024015100 5ustar mcnmcn00000000000000PostScript-Simple-0.07/lib/PostScript/0000700000175000017500000000000010362031024017212 5ustar mcnmcn00000000000000PostScript-Simple-0.07/lib/PostScript/Simple/0000700000175000017500000000000010362031024020443 5ustar mcnmcn00000000000000PostScript-Simple-0.07/lib/PostScript/Simple/EPS.pm0000644000175000017500000002643610211454537021470 0ustar mcnmcn00000000000000#! /usr/bin/perl package PostScript::Simple::EPS; use strict; use Exporter; use Carp; use PostScript::Simple; use vars qw($VERSION @ISA @EXPORT); @ISA = qw(Exporter); @EXPORT = qw(); $VERSION = "0.01"; =head1 NAME PostScript::Simple::EPS - EPS support for PostScript::Simple =head1 SYNOPSIS use PostScript::Simple; # create a new PostScript object $p = new PostScript::Simple(papersize => "A4", colour => 1, units => "in"); # create a new page $p->newpage; # add an eps file $p->add_eps({xsize => 3}, "test.eps", 1,1); $p->add_eps({yscale => 1.1, xscale => 1.8}, "test.eps", 4,8); # create an eps object $e = new PostScript::Simple::EPS(file => "test.eps"); $e->rotate(90); $e->xscale(0.5); $p->add_eps($e, 3, 3); # add eps object to postscript object $e->xscale(2); $p->add_eps($e, 2, 5); # add eps object to postscript object again # write the output to a file $p->output("file.ps"); =head1 DESCRIPTION PostScript::Simple::EPS allows you to add EPS files into PostScript::Simple objects. Included EPS files can be scaled and rotated, and placed anywhere inside a PostScript::Simple page. Remember when using translate/scale/rotate that you will normally need to do the operations in the reverse order to that which you expect. =head1 PREREQUISITES This module requires C, C, C and C. =head2 EXPORT None. =cut =head1 CONSTRUCTOR =over 4 =item C Create a new PostScript::Simple::EPS object. The options that can be set are: =over 4 =item file EPS file to be included. This or C must exist when the C method is called. =item source PostScript code for the EPS document. Either this or C must be set when C is called. =item clip Set to 0 to disable clipping to the EPS bounding box. Default is to clip. =back Example: $ps = new PostScript::Simple(landscape => 1, eps => 0, xsize => 4, ysize => 3, units => "in"); $eps = new PostScript::Simple::EPS(file => "test.eps"); $eps->scale(0.5); Scale the EPS file by x0.5 in both directions. $ps->newpage(); $ps->importeps($eps, 1, 1); Add the EPS file to the PostScript document at coords (1,1). $ps->importepsfile("another.eps", 1, 2, 4, 4); Easily add an EPS file to the PostScript document using bounding box (1,2),(4,4). The methods C and C are described in the documentation of C. =back =cut sub new# {{{ { my ($class, %data) = @_; my $self = { file => undef, # filename of the eps file xsize => undef, ysize => undef, units => "bp", # measuring units (see below) clip => 1, # clip to the bounding box bbx1 => 0, # Bounding Box definitions bby1 => 0, bbx2 => 0, bby2 => 0, epsprefix => [], epsfile => undef, epspostfix => [], }; foreach (keys %data) { $self->{$_} = $data{$_}; } if ((!defined $self->{"file"}) && (!defined $self->{"source"})) { croak "must provide file or source"; } if ((defined $self->{"file"}) && (defined $self->{"source"})) { croak "cannot provide both file and source"; } bless $self, $class; $self->init(); return $self; }# }}} sub _getfilebbox# {{{ { my $self = shift; my $foundbbx = 0; return 0 if (!defined $$self{file}); open EPS, "< $$self{file}" || croak "can't open eps file $$self{file}"; SCAN: while () { s/[\r\n]*$//; #ultimate chomp if (/^\%\%BoundingBox:\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s*$/) { $$self{bbx1} = $1; $$self{bby1} = $2; $$self{bbx2} = $3; $$self{bby2} = $4; $foundbbx = 1; last SCAN; } } close EPS; return $foundbbx; }# }}} sub _getsourcebbox# {{{ { my $self = shift; return 0 if (!defined $$self{epsfile}); if ($$self{epsfile} =~ /^\%\%BoundingBox:\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)\s+(-?\d+)$/m) { $$self{bbx1} = $1; $$self{bby1} = $2; $$self{bbx2} = $3; $$self{bby2} = $4; return 1; } return 0; }# }}} sub init# {{{ { my $self = shift; my $foundbbx = 0; if (defined($$self{source})) { # with dynamic generated file, what do we do with {Begin,End}Document? # $$self{"epsfile"} = "\%\%BeginDocument: $$self{file}\n"; # $$self{"epsfile"} .= "\%\%EndDocument\n"; $$self{"epsfile"} = $$self{"source"}; delete $$self{"source"}; croak "EPS file must contain a BoundingBox" if (!$self->_getsourcebbox()); } else { croak "EPS file must contain a BoundingBox" if (!_getfilebbox($self)); } if (($$self{bbx2} - $$self{bbx1} == 0) || ($$self{bby2} - $$self{bby1} == 0)) { $self->_error("PostScript::Simple::EPS: Bounding Box has zero dimension"); return 0; } $self->reset(); return 1; }# }}} =head1 OBJECT METHODS All object methods return 1 for success or 0 in some error condition (e.g. insufficient arguments). Error message text is also drawn on the page. =over 4 =item C Returns the EPS bounding box, as specified on the %%BoundingBox line of the EPS file. Units are standard PostScript points. Example: ($x1, $y1, $x2, $y2) = $eps->get_bbox(); =cut sub get_bbox# {{{ { my $self = shift; return ($$self{bbx1}, $$self{bby1}, $$self{bbx2}, $$self{bby2}); }# }}} =item C Returns the EPS width. Example: print "EPS width is " . abs($eps->width()) . "\n"; =cut sub width# {{{ { my $self = shift; return ($$self{bbx2} - $$self{bbx1}); }# }}} =item C Returns the EPS height. Example: To scale $eps to 72 points high, do: $eps->scale(1, 72/$eps->height()); =cut sub height# {{{ { my $self = shift; return ($$self{bby2} - $$self{bby1}); }# }}} =item C Scales the EPS file. To scale in one direction only, specify 1 as the other scale. To scale the EPS file the same in both directions, you may use the shortcut of just specifying the one value. Example: $eps->scale(1.2, 0.8); # make wider and shorter $eps->scale(0.5); # shrink to half size =cut sub scale# {{{ { my $self = shift; my ($x, $y) = @_; $y = $x if (!defined $y); croak "bad arguments to scale" if (!defined $x); push @{$$self{epsprefix}}, "$x $y scale"; return 1; }# }}} =item C Rotates the EPS file by C degrees anti-clockwise. The EPS file is rotated about it's own origin (as defined by it's bounding box). To rotate by a particular co-ordinate (again, relative to the EPS file, not the main PostScript document), use translate, too. Example: $eps->rotate(180); # turn upside-down To rotate 30 degrees about point (50,50): $eps->translate(50, 50); $eps->rotate(30); $eps->translate(-50, -50); =cut sub rotate# {{{ { my $self = shift; my ($d) = @_; croak "bad arguments to rotate" if (!defined $d); push @{$$self{epsprefix}}, "$d rotate"; return 1; }# }}} =item C Move the EPS file by C,C PostScript points. Example: $eps->translate(10, 10); # move 10 points in both directions =cut sub translate# {{{ { my $self = shift; my ($x, $y) = @_; croak "bad arguments to translate" if (!defined $y); push @{$$self{epsprefix}}, "$x $y translate"; return 1; }# }}} =item C Clear all translate, rotate and scale operations. Example: $eps->reset(); =cut sub reset# {{{ { my $self = shift; @{$$self{"epsprefix"}} = (); return 1; }# }}} =item C Reads the EPS file into memory, to save reading it from file each time if inserted many times into a document. Can not be used with C. =cut sub load# {{{ { my $self = shift; local *EPS; return 1 if (defined $$self{"epsfile"}); $$self{"epsfile"} = "\%\%BeginDocument: $$self{file}\n"; open EPS, "< $$self{file}" || croak "can't open eps file $$self{file}"; while () { $$self{"epsfile"} .= $_; } close EPS; $$self{"epsfile"} .= "\%\%EndDocument\n"; return 1; }# }}} =item C Experimental: defines the EPS at in the document prolog, and just runs a command to insert it each time it is used. C is a PostScript::Simple object. If the EPS file is included more than once in the PostScript file then this will probably shrink the filesize quite a lot. Can not be used at the same time as C, or when using EPS objects defined from PostScript source. Example: $p = new PostScript::Simple(); $e = new PostScript::Simple::EPS(file => "test.eps"); $e->preload($p); =cut sub preload# {{{ { my $self = shift; my $ps = shift; my $randcode = ""; croak "already loaded" if (defined $$self{"epsfile"}); croak "no PostScript::Simple module provided" if (!defined $ps); for my $i (0..7) { $randcode .= chr(int(rand()*26)+65); # yuk } $$self{"epsfile"} = "eps$randcode\n"; $$ps{"psprolog"} .= "/eps$randcode {\n"; $$ps{"psprolog"} .= "\%\%BeginDocument: $$self{file}\n"; open EPS, "< $$self{file}" || croak "can't open eps file $$self{file}"; while () { $$ps{"psprolog"} .= $_; } close EPS; $$ps{"psprolog"} .= "\%\%EndDocument\n"; $$ps{"psprolog"} .= "} def\n"; return 1; }# }}} ### PRIVATE sub _get_include_data# {{{ { my $self = shift; my ($x, $y) = @_; my $data = ""; croak "argh... internal error (incorrect arguments)" if (scalar @_ != 2); foreach my $line (@{$$self{"epsprefix"}}) { $data .= "$line\n"; } if ($$self{"clip"}) { $data .= "newpath $$self{bbx1} $$self{bby1} moveto $$self{bbx2} $$self{bby1} lineto $$self{bbx2} $$self{bby2} lineto $$self{bbx1} $$self{bby2} lineto closepath clip newpath\n"; } if (defined $$self{"epsfile"}) { $data .= $$self{"epsfile"}; } else { $data .= "\%\%BeginDocument: $$self{file}\n"; open EPS, "< $$self{file}" || croak "can't open eps file $$self{file}"; while () { $data .= $_; } close EPS; $data .= "\%\%EndDocument\n"; } foreach my $line (@{$$self{"epspostfix"}}) { $data .= "$line\n"; } return $data; }# }}} sub _error# {{{ { my $self = shift; my $msg = shift; $self->{pspages} .= "(error: $msg\n) print flush\n"; }# }}} =back =head1 BUGS This is software in development; some current functionality may not be as expected, and/or may not work correctly. =head1 AUTHOR The PostScript::Simple::EPS module was written by Matthew Newton, after prods for such a feature from several people around the world. A useful importeps function that provides scaling and aspect ratio operations was gratefully received from Glen Harris, and merged into this module. Copyright (C) 2002-2003 Matthew C. Newton / Newton Computing 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 2. 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, available at http://www.gnu.org/licenses/gpl.html. =head1 SEE ALSO L =cut 1; # vim:foldmethod=marker: PostScript-Simple-0.07/lib/PostScript/Simple.pm0000644000175000017500000013464410362030730021032 0ustar mcnmcn00000000000000#! /usr/bin/perl -w package PostScript::Simple; use strict; use vars qw($VERSION @ISA @EXPORT); use Carp; use Exporter; use PostScript::Simple::EPS; @ISA = qw(Exporter); @EXPORT = qw(); $VERSION = '0.07'; =head1 NAME PostScript::Simple - Produce PostScript files from Perl =head1 SYNOPSIS use PostScript::Simple; # create a new PostScript object $p = new PostScript::Simple(papersize => "A4", colour => 1, eps => 0, units => "in"); # create a new page $p->newpage; # draw some lines and other shapes $p->line(1,1, 1,4); $p->linextend(2,4); $p->box(1.5,1, 2,3.5); $p->circle(2,2, 1); $p->setlinewidth( 0.01 ); $p->curve(1,5, 1,7, 3,7, 3,5); $p->curvextend(3,3, 5,3, 5,5); # draw a rotated polygon in a different colour $p->setcolour(0,100,200); $p->polygon({rotate=>45}, 1,1, 1,2, 2,2, 2,1, 1,1); # add some text in red $p->setcolour("red"); $p->setfont("Times-Roman", 20); $p->text(1,1, "Hello"); # write the output to a file $p->output("file.ps"); =head1 DESCRIPTION PostScript::Simple allows you to have a simple method of writing PostScript files from Perl. It has graphics primitives that allow lines, curves, circles, polygons and boxes to be drawn. Text can be added to the page using standard PostScript fonts. The images can be single page EPS files, or multipage PostScript files. The image size can be set by using a recognised paper size ("C", for example) or by giving dimensions. The units used can be specified ("C" or "C", etc) and are the same as those used in TeX. The default unit is a bp, or a PostScript point, unlike TeX. =head1 PREREQUISITES This module requires C and C. =head2 EXPORT None. =cut # is there another colour database that can be used instead of defining # this one here? what about the X-windows one? (apart from MS-Win-probs?) XXXXX 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", );# }}} # define page sizes here (a4, letter, etc) # should be Properly Cased 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', );# }}} # The 13 standard fonts that are available on all PS 1 implementations: 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');# }}} # define the origins for the page a document can have # (default is "LeftBottom") my %psorigin = (# {{{ 'LeftBottom' => '0 0', 'LeftTop' => '0 -1', 'RightBottom' => '-1 0', 'RightTop' => '-1 -1', );# }}} # define the co-ordinate direction (default is 'RightUp') my %psdirs = (# {{{ 'RightUp' => '1 1', 'RightDown' => '1 -1', 'LeftUp' => '-1 1', 'LeftDown' => '-1 -1', );# }}} # measuring units are two-letter acronyms as used in TeX: # bp: postscript point (72 per inch) # in: inch (72 postscript points) # pt: printer's point (72.27 per inch) # mm: millimetre (25.4 per inch) # cm: centimetre (2.54 per inch) # pi: pica (12 printer's points) # dd: didot point (67.567. per inch) # cc: cicero (12 didot points) # set up the others here (sp) XXXXX 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", );# }}} =head1 CONSTRUCTOR =over 4 =item C Create a new PostScript::Simple object. The different options that can be set are: =over 4 =item units Units that are to be used in the file. Common units would be C, C, C, C, and C. Others are as used in TeX. (Default: C) =item xsize Specifies the width of the drawing area in units. =item ysize Specifies the height of the drawing area in units. =item papersize The size of paper to use, if C or C are not defined. This allows a document to easily be created using a standard paper size without having to remember the size of paper using PostScript points. Valid choices are currently "C", "C", "C", and "C". =item landscape Use the landscape option to rotate the page by 90 degrees. The paper dimensions are also rotated, so that clipping will still work. (Note that the printer will still think that the paper is portrait.) (Default: 0) =item copies Set the number of copies that should be printed. (Default: 1) =item clip If set to 1, the image will be clipped to the xsize and ysize. This is most useful for an EPS image. (Default: 0) =item colour Specifies whether the image should be rendered in colour or not. If set to 0 (default) all requests for a colour are mapped to a greyscale. Otherwise the colour requested with C or C is used. This option is present because most modern laser printers are only black and white. (Default: 0) =item eps Generate an EPS file, rather than a standard PostScript file. If set to 1, no newpage methods will actually create a new page. This option is probably the most useful for generating images to be imported into other applications, such as TeX. (Default: 1) =item page Specifies the initial page number of the (multi page) document. The page number is set with the Adobe DSC comments, and is used nowhere else. It only makes finding your pages easier. See also the C method. (Default: 1) =item coordorigin Defines the co-ordinate origin for each page produced. Valid arguments are C, C, C and C. The default is C. =item direction The direction the co-ordinates go from the origin. Values can be C, C, C and C. The default value is C. =item reencode Requests that a font re-encode function be added and that the 13 standard PostScript fonts get re-encoded in the specified encoding. The most popular choice (other than undef) is 'ISOLatin1Encoding' which selects the iso8859-1 encoding and fits most of western Europe, including the Scandinavia. Refer to Adobes Postscript documentation for other encodings. The output file is, by default, re-encoded to ISOLatin1Encoding. To stop this happening, use 'reencode => undef'. To use the re-encoded font, '-iso' must be appended to the names of the fonts used, e.g. 'Helvetica-iso'. =back Example: $ref = new PostScript::Simple(landscape => 1, eps => 0, xsize => 4, ysize => 3, units => "in"); Create a document that is 4 by 3 inches and prints landscape on a page. It is not an EPS file, and must therefore use the C method. $ref = new PostScript::Simple(eps => 1, colour => 1, xsize => 12, ysize => 12, units => "cm", reencode => "ISOLatin1Encoding"); Create a 12 by 12 cm EPS image that is in colour. Note that "C 1>" did not have to be specified because this is the default. Re-encode the standard fonts into the iso8859-1 encoding, providing all the special characters used in Western Europe. The C method should not be used. =back =cut sub new# {{{ { my ($class, %data) = @_; my $self = { xsize => undef, ysize => undef, papersize => undef, units => "bp", # measuring units (see below) landscape => 0, # rotate the page 90 degrees copies => 1, # number of copies colour => 0, # use colour clip => 0, # clip to the bounding box eps => 1, # create eps file page => 1, # page number to start at reencode => "ISOLatin1Encoding", # Re-encode the 13 standard # fonts in this encoding bbx1 => 0, # Bounding Box definitions bby1 => 0, bbx2 => 0, bby2 => 0, pscomments => "", # the following entries store data psprolog => "", # for the same DSC areas of the psfunctions => "", # postscript file. 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); # Units# {{{ 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}}); # X 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"; # Y direction $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"; # General unit scale (circle radius, etc) $u = "{"; if ($m != 1) { $u .= "$m mul " } if ($d != 1) { $u .= "$d div " } $u =~ s/ $//; $u .="}"; $self->{psfunctions} .= "/u $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";# }}} # Paper size# {{{ 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->{eps}) { $self->{pssetup} .= "ll 2 ge { << /PageSize [ $self->{xsize} " . "$self->{ysize} ] /ImagingBBox null >>" . " setpagedevice } if\n"; } # Landscape# {{{ if ($self->{landscape}) { my $swap; $self->{psfunctions} .= "/landscape { $self->{bbx2} 0 translate 90 rotate } bind def "; # I now think that Portrait is the correct thing here, as the page is # rotated. $self->{pscomments} .= "\%\%Orientation: Portrait\n"; # $self->{pscomments} .= "\%\%Orientation: Landscape\n"; $swap = $self->{bbx2}; $self->{bbx2} = $self->{bby2}; $self->{bby2} = $swap; # for EPS files, change to landscape here, as there are no pages if ($self->{eps}) { $self->{pssetup} .= "landscape\n" } } else { $self->{pscomments} .= "\%\%Orientation: Portrait\n"; }# }}} # Clipping# {{{ 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" } }# }}} # Font reencoding# {{{ if ($self->{reencode}) { my $encoding; # The name of the encoding my $ext; # The extention to tack onto the std fontnames if (ref $self->{reencode} eq 'ARRAY') { die "Custom reencoding of fonts not really implemented yet, sorry..."; $encoding = shift @{$self->{reencode}}; $ext = shift @{$self->{reencode}}; # TODO: Do something to add the actual encoding to the postscript code. } 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"; } }# }}} }# }}} =head1 OBJECT METHODS All object methods return 1 for success or 0 in some error condition (e.g. insufficient arguments). Error message text is also drawn on the page. =over 4 =item C Generates a new page on a PostScript file. If specified, C gives the number (or name) of the page. This method should not be used for EPS files. The page number is automatically incremented each time this is called without a new page number, or decremented if the current page number is negative. Example: $p->newpage(1); $p->newpage; $p->newpage("hello"); $p->newpage(-6); $p->newpage; will generate five pages, numbered: 1, 2, "hello", -6, -7. =cut sub newpage# {{{ { my $self = shift; my $nextpage = shift; my ($x, $y); if (defined($nextpage)) { $self->{page} = $nextpage; } if ($self->{eps}) { # Cannot have multiple pages in an EPS file XXXXX $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; }# }}} =item C Writes the current PostScript out to the file named C. Will destroy any existing file of the same name. Use this method whenever output is required to disk. The current PostScript document in memory is not cleared, and can still be extended. =cut sub _builddocument# {{{ { my $self = shift; my $title = shift; my $page; my $date = scalar localtime; my $user; $title = 'undefined' unless $title; $page = []; # getlogin is unimplemented on some systems eval { $user = getlogin; }; $user = 'Console' unless $user; # Comments Section 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}; # push @$page, "\%\%DocumentFonts: \n"; 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"; # Prolog Section push @$page, "\%\%BeginProlog\n"; push @$page, "/ll 1 def systemdict /languagelevel known {\n"; push @$page, "/ll languagelevel def } if\n"; push @$page, \$self->{psprolog}; push @$page, "\%\%BeginResource: PostScript::Simple\n"; push @$page, \$self->{psfunctions}; push @$page, "\%\%EndResource\n"; push @$page, "\%\%EndProlog\n"; # Setup Section 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"; } # Pages push @$page, \$self->{pspages}; if ((!$self->{eps}) && ($self->{pspagecount} > 0)) { push @$page, "\%\%PageTrailer\n"; push @$page, "pagelevel restore\n"; push @$page, "showpage\n"; } # Trailer Section 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 = _builddocument($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; }# }}} =item C Returns the current document. Use this method whenever output is required as a scalar. The current PostScript document in memory is not cleared, and can still be extended. =cut sub get# {{{ { my $self = shift; my $page; my $i; my $doc; $page = _builddocument($self, "PostScript::Simple generated page"); $doc = ""; foreach $i (@$page) { if (ref($i) eq "SCALAR") { $doc .= $$i; } else { $doc .= $i; } } return $doc; }# }}} =item C Returns the current document as a PostScript::Simple::EPS object. Only works if the current document is EPS. This method calls new PostScript::Simple::EPS with all the default options. To change these, call it yourself as below, rather than using this method. $eps = new PostScript::Simple::EPS(source => $ps->get); =cut 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; }# }}} =item C Sets the new drawing colour to the values specified in C, C and C. The values range from 0 to 255. Alternatively, a colour name may be specified. Those currently defined are listed at the top of the PostScript::Simple module in the C<%pscolours> hash. Example: # set new colour to brown $p->setcolour(200,100,0); # set new colour to black $p->setcolour("black"); =cut 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; ##PKENT - better colour->grey conversion $self->{pspages} .= "$r setgray\n"; } return 1; }# }}} =item C Sets the new line width to C units. Example: # draw a line 10mm long and 4mm wide $p = new PostScript::Simple(units => "mm"); $p->setlinewidth(4); $p->line(10,10, 20,10); =cut sub setlinewidth# {{{ { my $self = shift; my $width = shift || do { $self->_error( "setlinewidth not given a width" ); return 0; }; # MCN should allow for option units=>"cm" on each setlinewidth / line / polygon etc ##PKENT - good idea, should we have names for line weights, like we do for colours? if ($width eq "thin") { $width = "0.4" } else { $width .= " u" } $self->{pspages} .= "$width setlinewidth\n"; return 1; }# }}} =item C Draws a line from the co-ordinates (x1,x2) to (x2,y2). If values are specified for C, C and C, then the colour is set before the line is drawn. Example: # set the colour to black $p->setcolour("black"); # draw a line in the current colour (black) $p->line(10,10, 10,20); # draw a line in red $p->line(20,10, 20,20, 255,0,0); # draw another line in red $p->line(30,10, 30,20); =cut sub line# {{{ { my $self = shift; my ($x1, $y1, $x2, $y2, $r, $g, $b) = @_; # dashed lines? XXXXX # MCN should allow for option units=>"cm" on each setlinewidth / line / polygon etc if ((!$self->{pspagecount}) and (!$self->{eps})) { # Cannot draw on to non-page when not an eps file XXXXX 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; }# }}} =item C Assuming the previous command was C, C, C or C, extend that line to include another segment to the co-ordinates (x,y). Behaviour after any other method is unspecified. Example: $p->line(10,10, 10,20); $p->linextend(20,20); $p->linextend(20,10); $p->linextend(10,10); Notes The C method may be more appropriate. =cut 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/; ##PKENT comments: lineto can follow a curveto or a lineto, hence the change in regexp ##also I thought that it'd be better to change the '.*$' in the regexp with '\n$' - perhaps ##we need something like $self->{_lastcommand} to know if operations are valid? # $self->{pspages} .= "$x ux $y uy lineto stroke\n"; # XXXXX fixme return 1; }# }}} =item C Draws an arc on the circle of radius C with centre (C,C). The arc starts at angle C and finishes at C. Angles are specified in degrees, where 0 is at 3 o'clock, and the direction of travel is anti-clockwise. Any options are passed in a hash reference as the first parameter. The available option is: =over 4 =item filled => 1 If C is 1 then the arc will be filled in. =back Example: # semi-circle $p->arc(10, 10, 5, 0, 180); # complete filled circle $p->arc({filled=>1}, 30, 30, 10, 0, 360); =cut sub arc# {{{ { my $self = shift; my %opt = (); if (ref($_[0])) { %opt = %{; shift}; } if ((!$self->{pspagecount}) and (!$self->{eps})) { # Cannot draw on to non-page when not an eps file XXXXX return 0; } my ($x, $y, $r, $sa, $ea) = @_; unless (@_ == 5) { $self->_error("arc: wrong number of arguments"); return 0; } $self->newpath; $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; }# }}} =item C The C method is multi-function, allowing many shapes to be created and manipulated. Polygon draws lines from (x1,y1) to (x2,y2) and then from (x2,y2) to (x3,y3) up to (xn-1,yn-1) to (xn,yn). Any options are passed in a hash reference as the first parameter. The available options are as follows: =over 4 =item rotate => angle =item rotate => [angle,x,y] Rotate the polygon by C degrees anti-clockwise. If x and y are specified then use the co-ordinate (x,y) as the centre of rotation, otherwise use the co-ordinate (x1,y1) from the main polygon. =item filled => 1 If C is 1 then the PostScript output is set to fill the object rather than just draw the lines. =item offset => [x,y] Displace the object by the vector (x,y). =back Example: # draw a square with lower left point at (10,10) $p->polygon(10,10, 10,20, 20,20, 20,10, 10,10); # draw a filled square with lower left point at (20,20) $p->polygon( {offset => [10,10], filled => 1}, 10,10, 10,20, 20,20, 20,10, 10,10); # draw a filled square with lower left point at (10,10) # rotated 45 degrees (about the point (10,10)) $p->polygon( {rotate => 45, filled => 1}, 10,10, 10,20, 20,20, 20,10, 10,10); =cut sub polygon# {{{ { my $self = shift; my %opt = (); my ($xoffset, $yoffset) = (0,0); my ($rotate, $rotatex, $rotatey) = (0,0,0); # PKENT comments - the first arg could be an optional hashref of options. See if # it's there with ref($_[0]) If it is, then shift it off and use those options. # Could take the form: polygon( { offset => [ 10, 10 ], filled => 0, rotate => # 45, rotate => [45, 10, 10] }, $x1, ... it seems neater to use perl native # structures instead of manipulating strings # ... done MCN 2002-10-22 if ($#_ < 3) { # cannot have polygon with just one point... $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"; #$self->{pspages} .= "$xoffset u $yoffset u 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->{pspages} .= "gsave $rotatex ux $rotatey uy translate "; # $self->{pspages} .= "$rotate rotate -$rotatex ux -$rotatey uy translate\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; }# }}} =item C Plot a circle with centre at (x,y) and radius of r. There is only one option. =over 4 =item filled => 1 If C is 1 then the PostScript output is set to fill the object rather than just draw the lines. =back Example: $p->circle(40,40, 20); $p->circle( {filled => 1}, 62,31, 15); =cut 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; }# }}} =item C Draw text in an arc centered about angle C with circle midpoint (C,C) and radius C. There is only one option. =over 4 =item align => "alignment" C can be 'inside' or 'outside'. The default is 'inside'. =back Example: # outside the radius, centered at 90 degrees from the origin $p->circletext(40, 40, 20, 90, "Hello, Outside World!"); # inside the radius centered at 270 degrees from the origin $p->circletext( {align => "inside"}, 40, 40, 20, 270, "Hello, Inside World!"); =cut 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; }# }}} =item C Draw a rectangle from lower left co-ordinates (x1,y1) to upper right co-ordinates (y1,y2). Options are: =over 4 =item filled => 1 If C is 1 then fill the rectangle. =back Example: $p->box(10,10, 20,30); $p->box( {filled => 1}, 10,10, 20,30); Notes The C method is far more flexible, but this method is quicker! =cut 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; }# }}} =item C Set the current font to the PostScript font C. Set the size in PostScript points to C. Notes This method must be called on every page before the C method is used. =cut sub setfont# {{{ { my $self = shift; my ($name, $size, $ysize) = @_; unless (@_ == 2) { $self->_error( "wrong number of arguments for setfont" ); return 0; } # set font y size XXXXX $self->{pspages} .= "/$name findfont $size scalefont setfont\n"; $self->{lastfontsize} = $size; return 1; }# }}} =item C Plot text on the current page with the lower left co-ordinates at (x,y) and using the current font. The text is specified in C. Options are: =over 4 =item align => "alignment" alignment can be 'left', 'centre' or 'right'. The default is 'left'. =item rotate => angle "rotate" degrees of rotation, defaults to 0 (i.e. no rotation). The angle to rotate the text, in degrees. Centres about (x,y) and rotates clockwise. (?). Default 0 degrees. =back Example: $p->setfont("Times-Roman", 12); $p->text(40,40, "The frog sat on the leaf in the pond."); $p->text( {align => 'centre'}, 140,40, "This is centered."); $p->text( {rotate => 90}, 140,40, "This is rotated."); $p->text( {rotate => 90, align => 'centre'}, 140,40, "This is both."); =cut sub text# {{{ { my $self = shift; my $rot = ""; my $rot_m = ""; my $align = ""; my %opt = (); if (ref($_[0])) { %opt = %{; shift}; } unless ( @_ == 3 ) { # check required params first $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; } # Escape text to allow parentheses $text =~ s|([\\\(\)])|\\$1|g; $text =~ s/([\x00-\x1f\x7f-\xff])/sprintf('\\%03o',ord($1))/ge; $self->newpath; $self->moveto($x, $y); # rotation 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 "; }; } # alignment $align = " show stroke"; # align left 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; }# }}} =item curve( x1, y1, x2, y2, x3, y3, x4, y4 ) Create a curve from (x1, y1) to (x4, y4). (x2, y2) and (x3, y3) are the control points for the start- and end-points respectively. =cut sub curve# {{{ { my $self = shift; my ($x1, $y1, $x2, $y2, $x3, $y3, $x4, $y4) = @_; # dashed lines? XXXXX unless ( @_ == 8 ) { $self->_error( "bad curve definition, wrong number of args" ); return 0; } if ((!$self->{pspagecount}) and (!$self->{eps})) { # Cannot draw on to non-page when not an eps file XXXXX 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; }# }}} =item curvextend( x1, y1, x2, y2, x3, y3 ) Assuming the previous command was C, C, C or C, extend that path with another curve segment to the co-ordinates (x3, y3). (x1, y1) and (x2, y2) are the control points. Behaviour after any other method is unspecified. =cut 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; } # curveto may follow a lineto etc... $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; }# }}} =item newpath This method is used internally to begin a new drawing path - you should generally NEVER use it. =cut sub newpath# {{{ { my $self = shift; $self->{pspages} .= "newpath\n"; return 1; }# }}} =item moveto( x, y ) This method is used internally to move the cursor to a new point at (x, y) - you will generally NEVER use this method. =cut sub moveto# {{{ { my $self = shift; my ($x, $y) = @_; $self->{pspages} .= "$x ux $y uy moveto\n"; return 1; }# }}} =item C Imports an EPS file and scales/translates its bounding box to fill the area defined by lower left co-ordinates (x1,y1) and upper right co-ordinates (x2,y2). By default, if the co-ordinates have a different aspect ratio from the bounding box, the scaling is constrained on the greater dimension to keep the EPS fully inside the area. Options are: =over 4 =item overlap => 1 If C is 1 then the scaling is calculated on the lesser dimension and the EPS can overlap the area. =item stretch => 1 If C is 1 then fill the entire area, ignoring the aspect ratio. This option overrides C if both are given. =back Example: # Assume smiley.eps is a round smiley face in a square bounding box # Scale it to a (10,10)(20,20) box $p->importepsfile("smiley.eps", 10,10, 20,20); # Keeps aspect ratio, constrained to smallest fit $p->importepsfile("smiley.eps", 10,10, 30,20); # Keeps aspect ratio, allowed to overlap for largest fit $p->importepsfile( {overlap => 1}, "smiley.eps", 10,10, 30,20); # Aspect ratio is changed to give exact fit $p->importepsfile( {stretch => 1}, "smiley.eps", 10,10, 30,20); =cut 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; }# }}} =item C Imports a PostScript::Simple::EPS object into the current document at position C<(x,y)>. Example: use PostScript::Simple; # create a new PostScript object $p = new PostScript::Simple(papersize => "A4", colour => 1, units => "in"); # create a new page $p->newpage; # create an eps object $e = new PostScript::Simple::EPS(file => "test.eps"); $e->rotate(90); $e->scale(0.5); # add eps to the current page $p->importeps($e, 10,50); =cut 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})) { # Cannot draw on to non-page when not an eps file $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; }# }}} ### PRIVATE sub _error {# {{{ my $self = shift; my $msg = shift; $self->{pspages} .= "(error: $msg\n) print flush\n"; }# }}} # Display method for debugging internal variables # #sub display { # my $self = shift; # my $i; # # foreach $i (keys(%{$self})) # { # print "$i = $self->{$i}\n"; # } #} =back =head1 BUGS Some current functionality may not be as expected, and/or may not work correctly. That's the fun with using code in development! =head1 AUTHOR The PostScript::Simple module was created by Matthew Newton, with ideas and suggestions from Mark Withall and many other people from around the world. Thanks! Please see the README file in the distribution for more information about contributors. Copyright (C) 2002-2003 Matthew C. Newton / Newton Computing 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 2. 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, available at http://www.gnu.org/licenses/gpl.html. =head1 SEE ALSO L =cut 1; # vim:foldmethod=marker: PostScript-Simple-0.07/Changes0000644000175000017500000000522310362031004015637 0ustar mcnmcn00000000000000Revision history for Perl extension PostScript::Simple. 0.07 - 13 January 2006 mcnewton@cpan.org: - fix lack of newpath in arc 0.06 - 24 June 2004 mcnewton@cpan.org: - minor documentation changes 0.06p4 - 1 April 2004 mcnewton@cpan.org: - added /ll languagelevel check - added setpagedevice for languagelevel >= 2 0.06p3 - 29 March 2004 mcnewton@cpan.org: - added geteps method - added source argument to PostScript::Simple::EPS constructor - added width() and height() to PostScript::Simple::EPS - corrected some minor documentation errors 0.06p2 - 16 March 2004 mcnewton@cpan.org: - added get method 0.06p1 - 8 November 2003 ewilhelm@azahner.com: - arc function mcnewton@cpan.org: - update/add some pod documentation - added PostScript::Simple::EPS module - tidy Changes file astfgl@iamnota.org: - circletext function - useful code for eps addition 0.05 - 22 January 2003 mcnewton@cpan.org: - fold all functions in the code to make it easier to read - tidy up options to many functions (and probably break lots of stuff---sorry) m.s.withall2@lboro.ac.uk - fix error with number of pages in eps files cade@cpan.org - add text rotation - modify interface to text alignment marty@ancient-scotland.co.uk - curvextend typos - lots of other stuff that will hopefully make it into a different module michael.tomuschat@planet-interkom.de - page origin - co-ordinate direction 0.04 - 19 February 2002 mcnewton@cpan.org: - correct the definitions for dd and cc (I hope - still untested) - tidy up the code a bit - update the test suite dion@swamp.dk: - font encoding - text alignment - getlogin bugfix 0.03 - 17 January 2002 mcnewton@cpan.org: - Moved example.pl to a subdirectory so it doesn't get installed - PostScript header now includes version of PostScript::Simple - added dd and cc to the list of measurements, but they might not be correct pkent@cpan.org: - Generate many tests in t/ - Simple.pm moved to lib/PostScript/Simple.pm to make life easier - moveto and newpath given new methods - curve and curvextend created for generating Bezier curves - all functions now return 1 for OK or 0 for fail - errors are written as () print flush in the PS output - many paper sizes added - other small tweaks 0.02 - 12 January 2002 mcnewton@cpan.org: - Fixed module to now use MakeMaker, i.e. perl Makefile.PL; make; make install now works. - Updated some documentation errors 0.01 - 11 January 2002 - original version; created by h2xs 1.21 with options -X -n PostScript::Simple