| Changes | 1829 |
| MANIFEST | 42 |
| META.yml | 921 |
| Makefile.PL | 13 |
| README | 1415 |
| TODO | 20 |
| examples/demo.ps | 268476 |
| examples/example.pl | 082 |
| lib/PostScript/Simple/EPS.pm | 89126 |
| lib/PostScript/Simple.pm | 462490 |
| t/02text.t | 1111 |
| t/03funcs.t | 3733 |
| t/04units.t | 062 |
| t/10file.t | 33 |
| t/11file.t | 166164 |
| t/12file.t | 1512 |
| t/lib/Test/More.pm | 9270 |
| t/lib/Test/Simple.pm | 4950 |
| t/lib/Test/Utils.pm | 260 |
| 19 files changed (This is a version diff) | 25471529 |
@@ -1,80 +1,91 @@
Revision history for Perl extension PostScript::Simple.
+0.08 - 20 June 2014
+ Satoshi Azuma:
+ - remove Test::More module and make it a build dependency
+
+ Matthew Newton:
+ - fix test result failures on -Duselongdouble
+ - allow units to be specified for any distance
+ - add X-Windows colours, supplied by Steve Baldwin
+ - change all space-separated lists to arrays
+ - fix Begin/EndDocument handling in EPS file insertion
+
0.07 - 13 January 2006
- mcnewton@cpan.org:
+ Matthew Newton:
- fix lack of newpath in arc
0.06 - 24 June 2004
- mcnewton@cpan.org:
+ Matthew Newton:
- minor documentation changes
0.06p4 - 1 April 2004
- mcnewton@cpan.org:
+ Matthew Newton:
- added /ll languagelevel check
- added setpagedevice for languagelevel >= 2
0.06p3 - 29 March 2004
- mcnewton@cpan.org:
+ Matthew Newton:
- 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:
+ Matthew Newton:
- added get method
0.06p1 - 8 November 2003
- ewilhelm@azahner.com:
+ Eric Wilhelm:
- arc function
- mcnewton@cpan.org:
+ Matthew Newton:
- update/add some pod documentation
- added PostScript::Simple::EPS module
- tidy Changes file
- astfgl@iamnota.org:
+ Glen Harris:
- circletext function
- useful code for eps addition
0.05 - 22 January 2003
- mcnewton@cpan.org:
+ Matthew Newton:
- 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
+ Mark Withall
- fix error with number of pages in eps files
- cade@cpan.org
+ Vladi Belperchinov-Shabanski
- add text rotation
- modify interface to text alignment
- marty@ancient-scotland.co.uk
+ Martin McCarthy
- curvextend typos
- lots of other stuff that will hopefully make it into a different module
- michael.tomuschat@planet-interkom.de
+ Michael Tomuschat
- page origin
- co-ordinate direction
0.04 - 19 February 2002
- mcnewton@cpan.org:
+ Matthew Newton:
- correct the definitions for dd and cc (I hope - still untested)
- tidy up the code a bit
- update the test suite
- dion@swamp.dk:
+ Flemming Frandsen:
- font encoding
- text alignment
- getlogin bugfix
0.03 - 17 January 2002
- mcnewton@cpan.org:
+ Matthew Newton:
- 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:
+ P Kent:
- Generate many tests in t/
- Simple.pm moved to lib/PostScript/Simple.pm to make life easier
- moveto and newpath given new methods
@@ -85,7 +96,7 @@ Revision history for Perl extension PostScript::Simple.
- other small tweaks
0.02 - 12 January 2002
- mcnewton@cpan.org:
+ Matthew Newton:
- Fixed module to now use MakeMaker, i.e. perl Makefile.PL;
make; make install now works.
- Updated some documentation errors
@@ -11,11 +11,9 @@ lib/PostScript/Simple/EPS.pm
t/01base.t
t/02text.t
t/03funcs.t
+t/04units.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)
+META.yml
@@ -1,10 +1,22 @@
-# 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
+--- #YAML:1.0
+name: PostScript-Simple
+version: 0.08
+abstract: Produce PostScript files from Perl
+author:
+ - Matthew Newton <mcnewton@cpan.org>
+license: unknown
+distribution_type: module
+configure_requires:
+ ExtUtils::MakeMaker: 0
+build_requires:
+ ExtUtils::MakeMaker: 0
requires:
-
-distribution_type: module
-generated_by: ExtUtils::MakeMaker version 6.17
+ Test::More: 0.18
+no_index:
+ directory:
+ - t
+ - inc
+generated_by: ExtUtils::MakeMaker version 6.57_05
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
@@ -4,7 +4,9 @@ use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => 'PostScript::Simple',
'VERSION_FROM' => 'lib/PostScript/Simple.pm', # finds $VERSION
- 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+ 'PREREQ_PM' => {
+ 'Test::More' => 0.18, ### Requires Test::More by tests.(Test::Simple and Test::Utils is not used.)
+ },
($] >= 5.005 ? ## Add these new keywords supported since 5.005
(ABSTRACT_FROM => 'lib/PostScript/Simple.pm', # retrieve abstract from module
AUTHOR => 'Matthew Newton <mcnewton@cpan.org>') : ()),
@@ -1,11 +1,18 @@
-PostScript/Simple version 0.06
-==============================
+PostScript::Simple
+==================
+
+INTRODUCTION
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.
+It is named PostScript::Simple because it is intended to be simple
+to use to generate PostScript pages from Perl, not because it is a
+simplified interface for some other module, or can't do advanced
+things.
+
Features include:
Generation of multi-page PostScript files
@@ -20,19 +27,12 @@ Features include:
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:
+SOURCE
- svn co http://svn.newtoncomputing.co.uk/pss/branches/nextgen
+The module source is now hosted on GitHub; see:
-Which will create the directory "nextgen" for the files to go in.
+ https://github.com/mcnewton/postscript-simple
INSTALLATION
@@ -47,7 +47,7 @@ To install this module type the following:
COPYRIGHT AND LICENCE
-Copyright (C) 2002-2003 Matthew C. Newton / Newton Computing
+Copyright (C) 2002-2014 Matthew C. Newton
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
@@ -66,7 +66,8 @@ 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
+ McCarthy, Eric Wilhelm, Glen Harris, Peter Kuehn, Tomas Karlsson,
+ Satoshi Azuma
I apologise if you should be here and I have missed you, please let me know.
@@ -1,12 +1,10 @@
TO-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?
@@ -1,20 +1,17 @@
%!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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%DocumentMedia: A4 595.27559 841.88976 0 ( ) ( )
%%Orientation: Portrait
-%%Pages: 2
+%%Pages: 3
%%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
@@ -28,6 +25,64 @@
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
+/circle {newpath 0 360 arc closepath} bind def
+/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
+/ubp {} def
+/udd {72 mul 67.567 div} def
+/uin {72 mul} def
+/umm {72 mul 25.4 div} def
+/upt {72 mul 72.27 div} def
%%EndResource
%%EndProlog
%%BeginSetup
@@ -37,32 +92,32 @@ ll 2 ge { << /PageSize [ 595.27559 841.88976 ] /ImagingBBox null >> setpagedevic
%%BeginPageSetup
/pagelevel save def
%%EndPageSetup
-10 ux 10 uy 200 ux 287 uy box stroke
+10 umm 10 umm 200 umm 287 umm box stroke
newpath
-10 ux 277 uy moveto
-200 ux 277 uy lineto stroke
+10 umm 277 umm moveto
+200 umm 277 umm lineto stroke
/Times-Roman findfont 14 scalefont setfont
newpath
-15 ux 280 uy moveto
+15 umm 280 umm 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
+20 umm 210 umm 45 umm 260 umm box stroke
BeginEPSF
-20 ux 210 uy translate
-1 ux 1 uy scale
+20 umm 210 umm translate
+1 umm 1 umm 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
+0 100 lineto closepath clip newpath
+%%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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -70,62 +125,60 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
%%EndDocument
EndEPSF
-0.5 0 0 setrgbcolor
+0.49804 0 0 setrgbcolor
newpath
-14 ux 270 uy moveto
+14 umm 270 umm 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
+80 umm 210 umm 105 umm 260 umm box stroke
BeginEPSF
-80 ux 210 uy translate
-1 ux 1 uy scale
+80 umm 210 umm translate
+1 umm 1 umm 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
+0 100 lineto closepath clip newpath
+%%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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -133,62 +186,60 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
%%EndDocument
EndEPSF
-0 0.5 0 setrgbcolor
+0 0.49804 0 setrgbcolor
newpath
-74 ux 270 uy moveto
+74 umm 270 umm 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
+140 umm 210 umm 165 umm 260 umm box stroke
BeginEPSF
-140 ux 210 uy translate
-1 ux 1 uy scale
+140 umm 210 umm translate
+1 umm 1 umm 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
+0 100 lineto closepath clip newpath
+%%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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -196,64 +247,62 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
%%EndDocument
EndEPSF
-0 0 0.5 setrgbcolor
+0 0 0.49804 setrgbcolor
newpath
-134 ux 270 uy moveto
+134 umm 270 umm 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
+0.78431 0 0.78431 setrgbcolor
+30 umm 30 umm 90 umm 90 umm box stroke
BeginEPSF
-30 ux 30 uy translate
-1 ux 1 uy scale
+30 umm 30 umm translate
+1 umm 1 umm 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
+0 100 lineto closepath clip newpath
+%%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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -261,62 +310,60 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
%%EndDocument
EndEPSF
/Courier findfont 10 scalefont setfont
newpath
-100 ux 85 uy moveto
+100 umm 85 umm moveto
($eps = new PostScript::Simple::EPS) show stroke
newpath
-110 ux 80 uy moveto
+110 umm 80 umm moveto
(\(file => "demo-square.eps"\);) show stroke
newpath
-100 ux 75 uy moveto
+100 umm 75 umm moveto
($eps->scale\(60/100\);) show stroke
newpath
-100 ux 70 uy moveto
+100 umm 70 umm moveto
($eps->translate\(50, 50\);) show stroke
newpath
-100 ux 65 uy moveto
+100 umm 65 umm moveto
($eps->rotate\(20\);) show stroke
newpath
-100 ux 60 uy moveto
+100 umm 60 umm moveto
($eps->translate\(-50, -50\);) show stroke
newpath
-100 ux 55 uy moveto
+100 umm 55 umm moveto
($ps->importeps\($eps, 30, 30\);) show stroke
%%PageTrailer
pagelevel restore
@@ -325,30 +372,31 @@ showpage
%%BeginPageSetup
/pagelevel save def
%%EndPageSetup
-10 ux 10 uy 200 ux 287 uy box stroke
+10 umm 10 umm 200 umm 287 umm box stroke
newpath
-10 ux 277 uy moveto
-200 ux 277 uy lineto stroke
+10 umm 277 umm moveto
+200 umm 277 umm lineto stroke
/Times-Roman findfont 14 scalefont setfont
newpath
-15 ux 280 uy moveto
+15 umm 280 umm 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
+20 umm 210 umm 45 umm 260 umm box stroke
BeginEPSF
-20 ux 210 uy translate
-1 ux 1 uy scale
+20 umm 210 umm translate
+1 umm 1 umm scale
0.25 0.25 scale
newpath 0 0 moveto
100 0 lineto 100 100 lineto
-0 100 lineto closepath clip
+0 100 lineto closepath clip newpath
+%%BeginDocument: (undef)
%!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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -356,65 +404,65 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
+%%EndDocument
EndEPSF
-0.5 0 0 setrgbcolor
+0.49804 0 0 setrgbcolor
newpath
-30 ux 205 uy moveto
+30 umm 205 umm moveto
($directeps->reset\(\);) -60 rotate show stroke 60 rotate
newpath
-25 ux 205 uy moveto
+25 umm 205 umm moveto
($directeps->scale\(25/$directeps->width\(\)\);) -60 rotate show stroke 60 rotate
newpath
-20 ux 205 uy moveto
+20 umm 205 umm 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
+80 umm 210 umm 105 umm 260 umm box stroke
BeginEPSF
-80 ux 210 uy translate
-1 ux 1 uy scale
+80 umm 210 umm translate
+1 umm 1 umm scale
0.25 0.5 scale
newpath 0 0 moveto
100 0 lineto 100 100 lineto
-0 100 lineto closepath clip
+0 100 lineto closepath clip newpath
+%%BeginDocument: (undef)
%!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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -422,65 +470,65 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
+%%EndDocument
EndEPSF
-0 0.5 0 setrgbcolor
+0 0.49804 0 setrgbcolor
newpath
-90 ux 205 uy moveto
+90 umm 205 umm moveto
($directeps->reset\(\);) -60 rotate show stroke 60 rotate
newpath
-85 ux 205 uy moveto
+85 umm 205 umm moveto
($directeps->scale\(25/$directeps->width\(\), 50/$directeps->height\(\)\);) -60 rotate show stroke 60 rotate
newpath
-80 ux 205 uy moveto
+80 umm 205 umm 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
+140 umm 210 umm 165 umm 260 umm box stroke
BeginEPSF
-140 ux 210 uy translate
-1 ux 1 uy scale
+140 umm 210 umm translate
+1 umm 1 umm scale
0.5 0.5 scale
newpath 0 0 moveto
100 0 lineto 100 100 lineto
-0 100 lineto closepath clip
+0 100 lineto closepath clip newpath
+%%BeginDocument: (undef)
%!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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -488,65 +536,65 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
+%%EndDocument
EndEPSF
-0 0 0.5 setrgbcolor
+0 0 0.49804 setrgbcolor
newpath
-150 ux 205 uy moveto
+150 umm 205 umm moveto
($directeps->reset\(\);) -60 rotate show stroke 60 rotate
newpath
-145 ux 205 uy moveto
+145 umm 205 umm moveto
($directeps->scale\(50/$directeps->height\(\)\);) -60 rotate show stroke 60 rotate
newpath
-140 ux 205 uy moveto
+140 umm 205 umm 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
+0.78431 0 0.78431 setrgbcolor
+30 umm 30 umm 90 umm 90 umm box stroke
BeginEPSF
-30 ux 30 uy translate
-1 ux 1 uy scale
+30 umm 30 umm translate
+1 umm 1 umm scale
0.6 0.6 scale
newpath 0 0 moveto
100 0 lineto 100 100 lineto
-0 100 lineto closepath clip
+0 100 lineto closepath clip newpath
+%%BeginDocument: (undef)
%!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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -554,16 +602,13 @@ newpath 0 0 moveto
/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
{
@@ -585,7 +630,7 @@ newpath 0 0 moveto
/EncodePointer exch def
} ifelse
} ifelse
- } loop
+ } loop
TempEncode def
} bind def
@@ -666,23 +711,25 @@ newpath 0 0 moveto
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
+/ubp {} def
%%EndResource
%%EndProlog
BeginEPSF
-0 ux 0 uy translate
-1 ux 1 uy scale
+0 ubp 0 ubp translate
+1 ubp 1 ubp scale
50 50 translate
20 rotate
-50 -50 translate
newpath 0 0 moveto
100 0 lineto 100 100 lineto
-0 100 lineto closepath clip
+0 100 lineto closepath clip newpath
+%%BeginDocument: (undef)
%!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
+%%Creator: PostScript::Simple perl module version 0.08
+%%CreationDate: Sat Jun 21 01:43:12 2014
+%%For: mcn
%%Orientation: Portrait
%%BoundingBox: 0 0 100 100
%%EndComments
@@ -690,77 +737,238 @@ newpath 0 0 moveto
/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
+/ubp {} def
%%EndResource
%%EndProlog
-5 u setlinewidth
-10 ux 10 uy 90 ux 90 uy box stroke
-0.4 setlinewidth
+5 ubp setlinewidth
+10 ubp 10 ubp 90 ubp 90 ubp box stroke
+0.4 ubp setlinewidth
newpath
-0 ux 50 uy moveto
-100 ux 50 uy lineto stroke
+0 ubp 50 ubp moveto
+100 ubp 50 ubp lineto stroke
newpath
-50 ux 0 uy moveto
-50 ux 100 uy lineto stroke
+50 ubp 0 ubp moveto
+50 ubp 100 ubp lineto stroke
newpath
-0 ux 40 uy moveto
-0 ux 60 uy lineto stroke
+0 ubp 40 ubp moveto
+0 ubp 60 ubp lineto stroke
newpath
-100 ux 40 uy moveto
-100 ux 60 uy lineto stroke
+100 ubp 40 ubp moveto
+100 ubp 60 ubp lineto stroke
newpath
-40 ux 0 uy moveto
-60 ux 0 uy lineto stroke
+40 ubp 0 ubp moveto
+60 ubp 0 ubp lineto stroke
newpath
-40 ux 100 uy moveto
-60 ux 100 uy lineto stroke
+40 ubp 100 ubp moveto
+60 ubp 100 ubp lineto stroke
%%EOF
+%%EndDocument
EndEPSF
%%EOF
+%%EndDocument
EndEPSF
/Courier findfont 10 scalefont setfont
newpath
-100 ux 75 uy moveto
+100 umm 75 umm moveto
($directeps->reset\(\);) show stroke
newpath
-100 ux 70 uy moveto
+100 umm 70 umm moveto
($directeps->translate\(50, 50\);) show stroke
newpath
-100 ux 65 uy moveto
+100 umm 65 umm moveto
($directeps->rotate\(20\);) show stroke
newpath
-100 ux 60 uy moveto
+100 umm 60 umm moveto
($directeps->translate\(-50, -50\);) show stroke
newpath
-100 ux 55 uy moveto
+100 umm 55 umm moveto
(# round-about way to set clipping path) show stroke
newpath
-100 ux 50 uy moveto
+100 umm 50 umm moveto
($eps = new PostScript::Simple\(eps => 1,) show stroke
newpath
-110 ux 45 uy moveto
+110 umm 45 umm moveto
(xsize => 100, ysize => 100\);) show stroke
newpath
-100 ux 40 uy moveto
+100 umm 40 umm moveto
($eps->importeps\($directeps, 0, 0\);) show stroke
newpath
-100 ux 35 uy moveto
+100 umm 35 umm moveto
($directeps = $eps->geteps\(\);) show stroke
newpath
-100 ux 30 uy moveto
+100 umm 30 umm moveto
($directeps->scale\(60/100\);) show stroke
newpath
-100 ux 25 uy moveto
+100 umm 25 umm moveto
($ps->importeps\($directeps, 30, 30\);) show stroke
%%PageTrailer
pagelevel restore
showpage
+%%Page: 3 3
+%%BeginPageSetup
+/pagelevel save def
+%%EndPageSetup
+10 umm 10 umm 200 umm 287 umm box stroke
+newpath
+10 umm 277 umm moveto
+200 umm 277 umm lineto stroke
+/Times-Roman findfont 14 scalefont setfont
+newpath
+15 umm 280 umm moveto
+(PostScript::Simple example file: Using different units) show stroke
+/Courier findfont 10 scalefont setfont
+0.8 0 0 setrgbcolor
+newpath
+20 umm 268 umm moveto
+($ps->line\(20,265, 190,265\); # default units is mm) show stroke
+newpath
+20 umm 265 umm moveto
+190 umm 265 umm lineto stroke
+0 0 0.8 setrgbcolor
+newpath
+20 umm 258 umm moveto
+($ps->setlinewidth\("5 pt"\);) show stroke
+newpath
+20 umm 253 umm moveto
+($ps->line\(20,255, 190,255\);) show stroke
+5 upt setlinewidth
+newpath
+20 umm 250 umm moveto
+190 umm 250 umm lineto stroke
+0 0.8 0 setrgbcolor
+newpath
+20 umm 243 umm moveto
+($ps->setlinewidth\([0.25, "in"\);) show stroke
+newpath
+20 umm 238 umm moveto
+($ps->line\(20,232, 190,232\);) show stroke
+0.25 uin setlinewidth
+newpath
+20 umm 232 umm moveto
+190 umm 232 umm lineto stroke
+0.50196 0 0.50196 setrgbcolor
+newpath
+20 umm 224 umm moveto
+($ps->setlinewidth\("thin"\); # thin is 0.4 pt) show stroke
+newpath
+20 umm 219 umm moveto
+($ps->line\(20,216, 190,216\);) show stroke
+0.4 ubp setlinewidth
+newpath
+20 umm 216 umm moveto
+190 umm 216 umm lineto stroke
+8 udd setlinewidth
+1 0.50196 0.50196 setrgbcolor
+newpath
+1 uin 210 umm moveto
+2 uin 210 umm lineto stroke
+0.4 ubp setlinewidth
+0 0 0 setrgbcolor
+newpath
+1 uin 212 umm moveto
+1 uin 198 umm lineto stroke
+8 udd setlinewidth
+0.5 0.50196 0.50196 setrgbcolor
+newpath
+2 uin 208 umm moveto
+3 uin 208 umm lineto stroke
+0.4 ubp setlinewidth
+0 0 0 setrgbcolor
+newpath
+2 uin 212 umm moveto
+2 uin 198 umm lineto stroke
+8 udd setlinewidth
+0.33333 0.50196 0.50196 setrgbcolor
+newpath
+3 uin 206 umm moveto
+4 uin 206 umm lineto stroke
+0.4 ubp setlinewidth
+0 0 0 setrgbcolor
+newpath
+3 uin 212 umm moveto
+3 uin 198 umm lineto stroke
+8 udd setlinewidth
+0.25 0.50196 0.50196 setrgbcolor
+newpath
+4 uin 204 umm moveto
+5 uin 204 umm lineto stroke
+0.4 ubp setlinewidth
+0 0 0 setrgbcolor
+newpath
+4 uin 212 umm moveto
+4 uin 198 umm lineto stroke
+8 udd setlinewidth
+0.2 0.50196 0.50196 setrgbcolor
+newpath
+5 uin 202 umm moveto
+6 uin 202 umm lineto stroke
+0.4 ubp setlinewidth
+0 0 0 setrgbcolor
+newpath
+5 uin 212 umm moveto
+5 uin 198 umm lineto stroke
+8 udd setlinewidth
+0.16667 0.50196 0.50196 setrgbcolor
+newpath
+6 uin 200 umm moveto
+7 uin 200 umm lineto stroke
+0.4 ubp setlinewidth
+0 0 0 setrgbcolor
+newpath
+6 uin 212 umm moveto
+6 uin 198 umm lineto stroke
+0 0 0 setrgbcolor
+newpath
+7 uin 212 umm moveto
+7 uin 198 umm lineto stroke
+newpath
+20 umm 193 umm moveto
+($y = 210;) show stroke
+newpath
+20 umm 188 umm moveto
+(for \(my $x = 1; $x < 7; $x++\) {) show stroke
+newpath
+20 umm 183 umm moveto
+( $ps->setlinewidth\([8, "dd"]\);) show stroke
+newpath
+20 umm 178 umm moveto
+( $ps->line\([$x, "in"],$y, [$x+1, "in"],$y, 255/$x, 128, 128\); # also set colour) show stroke
+newpath
+20 umm 173 umm moveto
+( $ps->setlinewidth\("thin"\);) show stroke
+newpath
+20 umm 168 umm moveto
+( $ps->line\([$x, "in"],212, [$x, "in"],198, 0,0,0\); # set black) show stroke
+newpath
+20 umm 163 umm moveto
+( $y -= 2;) show stroke
+newpath
+20 umm 158 umm moveto
+(}) show stroke
+newpath
+20 umm 153 umm moveto
+($ps->line\([7, "in"],212, [7, "in"],198, 0,0,0\);) show stroke
+15 upt setlinewidth
+50 umm 4.5 uin 1 uin circle stroke
+/Courier-Bold findfont 10 scalefont setfont
+1 1 0 setrgbcolor
+gsave
+ 50 umm 4.5 uin translate
+ ($ps->setlinewidth("10 pt"); $ps->circle(50, "4.5in", "2in");) 10 90 0.96 uin outsidecircletext
+grestore
+0.49804 0 0 setrgbcolor
+/Courier findfont 8 scalefont setfont
+gsave
+ 50 umm 4.5 uin translate
+ ($ps->circletext({align => "outside"}, 50, "4.5in", "0.96in", 90, "...");) 8 90 0.78 uin outsidecircletext
+grestore
+%%PageTrailer
+pagelevel restore
+showpage
%%EOF
@@ -46,28 +46,44 @@ $ps = new PostScript::Simple(papersize => "a4",
eps => 0,
reencode => undef);
+################################################################################
+# PAGE 1
+################################################################################
+
# Create page (EPS import from a file, demo-square.eps)
mynewpage($ps, "EPS import functions (from a file)");
$ps->setfont("Courier", 10);
+#-------------------------------------------------------------------------------
+# Red example (left)
+
$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);');
+#-------------------------------------------------------------------------------
+# Green example (centre)
+
$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);');
+#-------------------------------------------------------------------------------
+# Blue example (right)
+
$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);');
+#-------------------------------------------------------------------------------
+# Purple example (bottom)
+
$ps->setcolour(200, 0, 200);
$ps->box(30, 30, 90, 90);
@@ -87,6 +103,11 @@ $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);');
+
+################################################################################
+# PAGE 2
+################################################################################
+
# Create page (using generated EPS object)
mynewpage($ps, "EPS import functions (using internal EPS object)");
$ps->setfont("Courier", 10);
@@ -150,6 +171,67 @@ $ps->text(100, $y-=5, '$directeps->scale(60/100);');
$ps->text(100, $y-=5, '$ps->importeps($directeps, 30, 30);');
+################################################################################
+# PAGE 3
+################################################################################
+
+# Create page (using generated EPS object)
+mynewpage($ps, "Using different units");
+$ps->setfont("Courier", 10);
+
+$ps->setcolour("red");
+$ps->text(20, 268, '$ps->line(20,265, 190,265); # default units is mm');
+$ps->line(20,265, 190,265);
+
+$ps->setcolour("blue");
+$ps->text(20, 258, '$ps->setlinewidth("5 pt");');
+$ps->text(20, 253, '$ps->line(20,255, 190,255);');
+$ps->setlinewidth("5 pt");
+$ps->line(20,250, 190,250);
+
+$ps->setcolour("green");
+$ps->text(20, 243, '$ps->setlinewidth([0.25, "in");');
+$ps->text(20, 238, '$ps->line(20,232, 190,232);');
+$ps->setlinewidth([0.25, "in"]);
+$ps->line(20,232, 190,232);
+
+$ps->setcolour("purple");
+$ps->text(20, 224, '$ps->setlinewidth("thin"); # thin is 0.4 pt');
+$ps->text(20, 219, '$ps->line(20,216, 190,216);');
+$ps->setlinewidth("thin");
+$ps->line(20,216, 190,216);
+
+$y = 210;
+for (my $x = 1; $x < 7; $x++) {
+ $ps->setlinewidth([8, "dd"]);
+ $ps->line([$x, "in"],$y, [$x+1, "in"],$y, 255/$x, 128, 128);
+ $ps->setlinewidth("thin");
+ $ps->line([$x, "in"],212, [$x, "in"],198, 0,0,0);
+ $y -= 2;
+}
+$ps->line([7, "in"],212, [7, "in"],198, 0,0,0);
+
+$y = 198;
+$ps->text(20, $y-=5, '$y = 210;');
+$ps->text(20, $y-=5, 'for (my $x = 1; $x < 7; $x++) {');
+$ps->text(20, $y-=5, ' $ps->setlinewidth([8, "dd"]);');
+$ps->text(20, $y-=5, ' $ps->line([$x, "in"],$y, [$x+1, "in"],$y, 255/$x, 128, 128); # also set colour');
+$ps->text(20, $y-=5, ' $ps->setlinewidth("thin");');
+$ps->text(20, $y-=5, ' $ps->line([$x, "in"],212, [$x, "in"],198, 0,0,0); # set black');
+$ps->text(20, $y-=5, ' $y -= 2;');
+$ps->text(20, $y-=5, '}');
+$ps->text(20, $y-=5, '$ps->line([7, "in"],212, [7, "in"],198, 0,0,0);');
+
+
+$ps->setlinewidth("15 pt");
+$ps->circle(50, "4.5in", "1in");
+$ps->setfont("Courier-Bold", 10);
+$ps->setcolour("yellow");
+$ps->circletext({align => "outside"}, 50, "4.5in", "0.96in", 90, '$ps->setlinewidth("10 pt"); $ps->circle(50, "4.5in", "2in");');
+$ps->setcolour("darkred");
+$ps->setfont("Courier", 8);
+$ps->circletext({align => "outside"}, 50, "4.5in", "0.78in", 90, '$ps->circletext({align => "outside"}, 50, "4.5in", "0.96in", 90, "...");');
+
# Write out the document.
$ps->output("demo.ps");
@@ -11,7 +11,10 @@ use vars qw($VERSION @ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw();
-$VERSION = "0.01";
+$VERSION = "0.02";
+
+
+#-------------------------------------------------------------------------------
=head1 NAME
@@ -121,8 +124,7 @@ of C<PostScript::Simple>.
=cut
-
-sub new# {{{
+sub new
{
my ($class, %data) = @_;
my $self = {
@@ -158,67 +160,19 @@ sub new# {{{
$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 (<EPS>)
- {
- 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# {{{
+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
- {
+ } else {
croak "EPS file must contain a BoundingBox" if (!_getfilebbox($self));
}
@@ -231,13 +185,15 @@ sub init# {{{
$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
+(e.g. insufficient arguments). Error message text is also drawn on
the page.
=over 4
@@ -253,16 +209,19 @@ Example:
=cut
-sub get_bbox# {{{
+sub get_bbox
{
my $self = shift;
return ($$self{bbx1}, $$self{bby1}, $$self{bbx2}, $$self{bby2});
-}# }}}
+}
+
+
+#-------------------------------------------------------------------------------
=item C<width>
-Returns the EPS width.
+Returns the EPS width, in PostScript points.
Example:
@@ -270,16 +229,19 @@ Example:
=cut
-sub width# {{{
+sub width
{
my $self = shift;
return ($$self{bbx2} - $$self{bbx1});
-}# }}}
+}
+
+
+#-------------------------------------------------------------------------------
=item C<height>
-Returns the EPS height.
+Returns the EPS height, in PostScript points.
Example:
@@ -289,12 +251,15 @@ To scale $eps to 72 points high, do:
=cut
-sub height# {{{
+sub height
{
my $self = shift;
return ($$self{bby2} - $$self{bby1});
-}# }}}
+}
+
+
+#-------------------------------------------------------------------------------
=item C<scale(x, y)>
@@ -309,7 +274,7 @@ Example:
=cut
-sub scale# {{{
+sub scale
{
my $self = shift;
my ($x, $y) = @_;
@@ -320,8 +285,10 @@ sub scale# {{{
push @{$$self{epsprefix}}, "$x $y scale";
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item C<rotate(deg)>
@@ -342,7 +309,7 @@ To rotate 30 degrees about point (50,50):
=cut
-sub rotate# {{{
+sub rotate
{
my $self = shift;
my ($d) = @_;
@@ -352,9 +319,11 @@ sub rotate# {{{
push @{$$self{epsprefix}}, "$d rotate";
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item C<translate(x, y)>
Move the EPS file by C<x>,C<y> PostScript points.
@@ -365,7 +334,7 @@ Example:
=cut
-sub translate# {{{
+sub translate
{
my $self = shift;
my ($x, $y) = @_;
@@ -375,8 +344,10 @@ sub translate# {{{
push @{$$self{epsprefix}}, "$x $y translate";
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item C<reset>
@@ -388,16 +359,18 @@ Example:
=cut
-sub reset# {{{
+sub reset
{
my $self = shift;
@{$$self{"epsprefix"}} = ();
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item C<load>
Reads the EPS file into memory, to save reading it from file each time if
@@ -405,14 +378,15 @@ inserted many times into a document. Can not be used with C<preload>.
=cut
-sub load# {{{
+sub load
{
my $self = shift;
local *EPS;
return 1 if (defined $$self{"epsfile"});
+ return 1 if (defined $$self{"source"});
- $$self{"epsfile"} = "\%\%BeginDocument: $$self{file}\n";
+ $$self{"epsfile"} = "\%\%BeginDocument: ($$self{file})\n";
open EPS, "< $$self{file}" || croak "can't open eps file $$self{file}";
while (<EPS>)
{
@@ -422,9 +396,10 @@ sub load# {{{
$$self{"epsfile"} .= "\%\%EndDocument\n";
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
=item C<preload(object)>
@@ -444,13 +419,14 @@ Example:
=cut
-sub preload# {{{
+sub preload
{
my $self = shift;
my $ps = shift;
my $randcode = "";
croak "already loaded" if (defined $$self{"epsfile"});
+ croak "can't preload when using source" if (defined $$self{"source"});
croak "no PostScript::Simple module provided" if (!defined $ps);
@@ -462,7 +438,7 @@ sub preload# {{{
$$self{"epsfile"} = "eps$randcode\n";
$$ps{"psprolog"} .= "/eps$randcode {\n";
- $$ps{"psprolog"} .= "\%\%BeginDocument: $$self{file}\n";
+ $$ps{"psprolog"} .= "\%\%BeginDocument: ($$self{file})\n";
open EPS, "< $$self{file}" || croak "can't open eps file $$self{file}";
while (<EPS>)
{
@@ -473,12 +449,68 @@ sub preload# {{{
$$ps{"psprolog"} .= "} def\n";
return 1;
-}# }}}
+}
+
+
+################################################################################
+# PRIVATE methods
+
+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 (<EPS>)
+ {
+ 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;
+}
-### PRIVATE
+#-------------------------------------------------------------------------------
-sub _get_include_data# {{{
+sub _getsourcebbox
+{
+ my $self = shift;
+
+ my $ref;
+
+ $ref = \$self->{epsfile} if defined $self->{epsfile};
+ $ref = \$self->{source} if defined $self->{source};
+
+ return 0 unless defined $$ref;
+
+ if ($$ref =~
+ /^\%\%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 _get_include_data
{
my $self = shift;
my ($x, $y) = @_;
@@ -495,10 +527,15 @@ sub _get_include_data# {{{
$$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"};
+ } elsif (defined $$self{"source"}) {
+ $data .= "\%\%BeginDocument: (undef)\n";
+ $data .= $$self{"source"};
+ $data .= "\%\%EndDocument\n";
} else {
- $data .= "\%\%BeginDocument: $$self{file}\n";
+ $data .= "\%\%BeginDocument: ($$self{file})\n";
open EPS, "< $$self{file}" || croak "can't open eps file $$self{file}";
while (<EPS>) {
$data .= $_;
@@ -512,14 +549,14 @@ $$self{bbx1} $$self{bby2} lineto closepath clip newpath\n";
}
return $data;
-}# }}}
+}
-sub _error# {{{
+sub _error
{
- my $self = shift;
- my $msg = shift;
- $self->{pspages} .= "(error: $msg\n) print flush\n";
-}# }}}
+ my $self = shift;
+ my $msg = shift;
+ $self->{pspages} .= "(error: $msg\n) print flush\n";
+}
=back
@@ -536,7 +573,7 @@ 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
+Copyright (C) 2002-2014 Matthew C. Newton
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
@@ -10,7 +10,10 @@ use PostScript::Simple::EPS;
@ISA = qw(Exporter);
@EXPORT = qw();
-$VERSION = '0.07';
+$VERSION = '0.08';
+
+
+#-------------------------------------------------------------------------------
=head1 NAME
@@ -75,110 +78,139 @@ 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 some colour names
+my %pscolours = (
+ # Original colours from PostScript::Simple
+ brightred => [255, 0, 0], brightgreen => [0, 255, 0], brightblue => [0, 0, 1],
+ red => [204, 0, 0], green => [0, 204, 0], blue => [0, 0, 204],
+ darkred => [127, 0, 0], darkgreen => [0, 127, 0], darkblue => [0, 0, 127],
+ grey10 => [25, 25, 25], grey20 => [51, 51, 51], grey30 => [76, 76, 76],
+ grey40 => [102, 102, 102], grey50 => [127, 127, 127], grey60 => [153, 153, 153],
+ grey70 => [178, 178, 178], grey80 => [204, 204, 204], grey90 => [229, 229, 229],
+ black => [0, 0, 0], white => [255, 255, 255],
+
+ # X-Windows colours, unless they clash with the above (only /(dark)?(red|green|blue)/ )
+ aliceblue => [240, 248, 255], antiquewhite => [250, 235, 215], aqua => [0, 255, 255],
+ aquamarine => [127, 255, 212], azure => [240, 255, 255], beige => [245, 245, 220],
+ bisque => [255, 228, 196], blanchedalmond => [255, 255, 205], blueviolet => [138, 43, 226],
+ brown => [165, 42, 42], burlywood => [222, 184, 135], cadetblue => [95, 158, 160],
+ chartreuse => [127, 255, 0], chocolate => [210, 105, 30], coral => [255, 127, 80],
+ cornflowerblue => [100, 149, 237], cornsilk => [255, 248, 220], crimson => [220, 20, 60],
+ cyan => [0, 255, 255], darkcyan => [0, 139, 139], darkgoldenrod => [184, 134, 11],
+ darkgray => [169, 169, 169], darkgrey => [169, 169, 169], darkkhaki => [189, 183, 107],
+ darkmagenta => [139, 0, 139], darkolivegreen => [85, 107, 47], darkorange => [255, 140, 0],
+ darkorchid => [153, 50, 204], darksalmon => [233, 150, 122], darkseagreen => [143, 188, 143],
+ darkslateblue => [72, 61, 139], darkslategray => [47, 79, 79], darkslategrey => [47, 79, 79],
+ darkturquoise => [0, 206, 209], darkviolet => [148, 0, 211], deeppink => [255, 20, 147],
+ deepskyblue => [0, 191, 255], dimgray => [105, 105, 105], dimgrey => [105, 105, 105],
+ dodgerblue => [30, 144, 255], firebrick => [178, 34, 34], floralwhite => [255, 250, 240],
+ forestgreen => [34, 139, 34], fuchsia => [255, 0, 255], gainsboro => [220, 220, 220],
+ ghostwhite => [248, 248, 255], gold => [255, 215, 0], goldenrod => [218, 165, 32],
+ gray => [128, 128, 128], grey => [128, 128, 128], greenyellow => [173, 255, 47],
+ honeydew => [240, 255, 240], hotpink => [255, 105, 180], indianred => [205, 92, 92],
+ indigo => [75, 0, 130], ivory => [255, 240, 240], khaki => [240, 230, 140],
+ lavender => [230, 230, 250], lavenderblush => [255, 240, 245], lawngreen => [124, 252, 0],
+ lemonchiffon => [255, 250, 205], lightblue => [173, 216, 230], lightcoral => [240, 128, 128],
+ lightcyan => [224, 255, 255], lightgoldenrodyellow => [250, 250, 210], lightgray => [211, 211, 211],
+ lightgreen => [144, 238, 144], lightgrey => [211, 211, 211], lightpink => [255, 182, 193],
+ lightsalmon => [255, 160, 122], lightseagreen => [32, 178, 170], lightskyblue => [135, 206, 250],
+ lightslategray => [119, 136, 153], lightslategrey => [119, 136, 153], lightsteelblue => [176, 196, 222],
+ lightyellow => [255, 255, 224], lime => [0, 255, 0], limegreen => [50, 205, 50],
+ linen => [250, 240, 230], magenta => [255, 0, 255], maroon => [128, 0, 0],
+ mediumaquamarine => [102, 205, 170], mediumblue => [0, 0, 205], mediumorchid => [186, 85, 211],
+ mediumpurple => [147, 112, 219], mediumseagreen => [60, 179, 113], mediumslateblue => [123, 104, 238],
+ mediumspringgreen => [0, 250, 154], mediumturquoise => [72, 209, 204], mediumvioletred => [199, 21, 133],
+ midnightblue => [25, 25, 112], mintcream => [245, 255, 250], mistyrose => [255, 228, 225],
+ moccasin => [255, 228, 181], navajowhite => [255, 222, 173], navy => [0, 0, 128],
+ oldlace => [253, 245, 230], olive => [128, 128, 0], olivedrab => [107, 142, 35],
+ orange => [255, 165, 0], orangered => [255, 69, 0], orchid => [218, 112, 214],
+ palegoldenrod => [238, 232, 170], palegreen => [152, 251, 152], paleturquoise => [175, 238, 238],
+ palevioletred => [219, 112, 147], papayawhip => [255, 239, 213], peachpuff => [255, 218, 185],
+ peru => [205, 133, 63], pink => [255, 192, 203], plum => [221, 160, 221],
+ powderblue => [176, 224, 230], purple => [128, 0, 128], rosybrown => [188, 143, 143],
+ royalblue => [65, 105, 225], saddlebrown => [139, 69, 19], salmon => [250, 128, 114],
+ sandybrown => [244, 164, 96], seagreen => [46, 139, 87], seashell => [255, 245, 238],
+ sienna => [160, 82, 45], silver => [192, 192, 192], skyblue => [135, 206, 235],
+ slateblue => [106, 90, 205], slategray => [112, 128, 144], slategrey => [112, 128, 144],
+ snow => [255, 250, 250], springgreen => [0, 255, 127], steelblue => [70, 130, 180],
+ tan => [210, 180, 140], teal => [0, 128, 128], thistle => [216, 191, 216],
+ tomato => [253, 99, 71], turquoise => [64, 224, 208], violet => [238, 130, 238],
+ wheat => [245, 222, 179], whitesmoke => [245, 245, 245], yellow => [255, 255, 0],
+ yellowgreen => [154, 205, 50],
+);
# 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',
-);# }}}
+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');# }}}
+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',
-);# }}}
+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',
-);# }}}
+my %psdirs = (
+ 'RightUp' => [ 1, 1],
+ 'RightDown' => [ 1, -1],
+ 'LeftUp' => [-1, 1],
+ 'LeftDown' => [-1, -1],
+);
# measuring units are two-letter acronyms as used in TeX:
@@ -193,17 +225,19 @@ my %psdirs = (# {{{
# 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",
-);# }}}
+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
@@ -322,8 +356,7 @@ used in Western Europe. The C<newpage> method should not be used.
=cut
-
-sub new# {{{
+sub new
{
my ($class, %data) = @_;
my $self = {
@@ -351,6 +384,7 @@ sub new# {{{
pssetup => "",
pspages => "",
pstrailer => "",
+ usedunits => {}, # units that have been used
lastfontsize => 0,
pspagecount => 0,
@@ -364,8 +398,7 @@ sub new# {{{
direction => 'RightUp',
};
- foreach (keys %data)
- {
+ foreach (keys %data) {
$self->{$_} = $data{$_};
}
@@ -373,94 +406,114 @@ sub new# {{{
$self->init();
return $self;
-}# }}}
+}
+
-sub init# {{{
+#-------------------------------------------------------------------------------
+
+sub _u
+{
+ my ($self, $u, $rev) = @_;
+
+ my $val;
+ my $unit;
+
+ # $u may be...
+ # a simple number, in which case the current units are used
+ # a listref of [number, "unit"], to force the unit
+ # a string "number unit", e.g. "4 mm" or "2.4in"
+
+ if (ref($u) eq "ARRAY") {
+ $val = $$u[0];
+ $unit = $$u[1];
+ confess "Invalid array" if @$u != 2;
+ } else {
+ if ($u =~ /^\s*(\d+(?:\.\d+)?)\s*([a-z][a-z])?\s*$/) {
+ $val = $1;
+ $unit = $2 || $self->{units};
+ }
+ }
+
+ confess "Cannot determine length" unless defined $val;
+ confess "Cannot determine unit (invalid array?)" unless defined $unit;
+
+ croak "Invalid unit '$unit'" unless defined $psunits{$unit};
+
+ unless (defined $self->{usedunits}{$unit}) {
+ my ($m, $d) = @{$psunits{$unit}};
+
+ my $c = "{";
+ $c .= "$m mul " unless $m == 1;
+ $c .= "$d div " unless $d == 1;
+ $c =~ s/ $//;
+ $c .="}";
+ $self->{usedunits}{$unit} = "/u$unit $c def";
+ }
+
+ $val = $rev * $val if defined $rev;
+
+ return "$val u$unit ";
+}
+
+sub _ux
+{
+ my ($self, $d) = @_;
+
+ return $self->_u($d, $psdirs{$self->{direction}}[0]);
+}
+
+sub _uy
+{
+ my ($self, $d) = @_;
+
+ return $self->_u($d, $psdirs{$self->{direction}}[1]);
+}
+
+sub _uxy
+{
+ my ($self, $x, $y) = @_;
+
+ return $self->_ux($x) . $self->_uy($y);
+}
+
+
+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};
- }
+# Units
+ $self->{units} = lc $self->{units};
- if (defined($psunits{$self->{units}}))
- {
- ($m, $d) = split(/\s+/, $psunits{$self->{units}});
- }
- else
- {
+ if (defined($psunits{$self->{units}})) {
+ ($m, $d) = @{$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})
- {
+
+# 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}});
+ if (!defined $self->{xsize} || !defined $self->{ysize}) {
+ if (defined $self->{papersize} && defined $pspaper{$self->{papersize}}) {
+ ($self->{xsize}, $self->{ysize}) = @{$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
- {
+ } else {
($self->{xsize}, $self->{ysize}) = (100,100);
$self->_error( "page size undefined" );
}
- }
- else
- {
+ } 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} " .
@@ -468,9 +521,8 @@ sub init# {{{
" setpagedevice } if\n";
}
-# Landscape# {{{
- if ($self->{landscape})
- {
+# Landscape
+ if ($self->{landscape}) {
my $swap;
$self->{psfunctions} .= "/landscape {
@@ -488,15 +540,12 @@ sub init# {{{
# for EPS files, change to landscape here, as there are no pages
if ($self->{eps}) { $self->{pssetup} .= "landscape\n" }
- }
- else
- {
+ } else {
$self->{pscomments} .= "\%\%Orientation: Portrait\n";
- }# }}}
+ }
-# Clipping# {{{
- if ($self->{clip})
- {
+# Clipping
+ if ($self->{clip}) {
$self->{psfunctions} .= "/pageclip {newpath $self->{bbx1} $self->{bby1} moveto
$self->{bbx1} $self->{bby2} lineto
$self->{bbx2} $self->{bby2} lineto
@@ -505,23 +554,19 @@ $self->{bbx1} $self->{bby1} lineto
closepath clip} bind def
";
if ($self->{eps}) { $self->{pssetup} .= "pageclip\n" }
- }# }}}
+ }
-# Font reencoding# {{{
- if ($self->{reencode})
- {
+# 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')
- {
+ 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
- {
+ } else {
$encoding = $self->{reencode};
$ext = '-iso';
}
@@ -533,7 +578,7 @@ closepath clip} bind def
% /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
{
@@ -555,7 +600,7 @@ closepath clip} bind def
/EncodePointer exch def
} ifelse
} ifelse
- } loop
+ } loop
TempEncode def
} bind def
@@ -618,18 +663,19 @@ closepath clip} bind def
% Reencode the std fonts:
EOP
- for my $font (@fonts)
- {
+ 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.
+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
@@ -653,8 +699,7 @@ will generate five pages, numbered: 1, 2, "hello", -6, -7.
=cut
-
-sub newpage# {{{
+sub newpage
{
my $self = shift;
my $nextpage = shift;
@@ -662,26 +707,21 @@ sub newpage# {{{
if (defined($nextpage)) { $self->{page} = $nextpage; }
- if ($self->{eps})
- {
-# Cannot have multiple pages in an EPS file XXXXX
+ if ($self->{eps}) {
+ # Cannot have multiple pages in an EPS file
$self->_error("Do not use newpage for eps files!");
return 0;
}
- if ($self->{pspagecount} != 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)
- {
+ if ($self->{page} >= 0) {
$self->{page} ++;
- }
- else
- {
+ } else {
$self->{page} --;
}
@@ -689,16 +729,18 @@ sub newpage# {{{
$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, $y) = @{$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<output(filename)>
Writes the current PostScript out to the file named C<filename>. Will destroy
@@ -709,8 +751,7 @@ document in memory is not cleared, and can still be extended.
=cut
-
-sub _builddocument# {{{
+sub _builddocument
{
my $self = shift;
my $title = shift;
@@ -738,12 +779,9 @@ sub _builddocument# {{{
push @$page, "\%\%For: $user\n";
push @$page, \$self->{pscomments};
# push @$page, "\%\%DocumentFonts: \n";
- if ($self->{eps})
- {
+ if ($self->{eps}) {
push @$page, "\%\%BoundingBox: $self->{bbx1} $self->{bby1} $self->{bbx2} $self->{bby2}\n";
- }
- else
- {
+ } else {
push @$page, "\%\%Pages: $self->{pspagecount}\n";
}
push @$page, "\%\%EndComments\n";
@@ -755,15 +793,16 @@ sub _builddocument# {{{
push @$page, \$self->{psprolog};
push @$page, "\%\%BeginResource: PostScript::Simple\n";
push @$page, \$self->{psfunctions};
+ foreach my $un (sort keys %{$self->{usedunits}}) {
+ push @$page, $self->{usedunits}{$un} . "\n";
+ }
push @$page, "\%\%EndResource\n";
push @$page, "\%\%EndProlog\n";
# Setup Section
- if (length($self->{pssetup}) || ($self->{copies} > 1))
- {
+ if (length($self->{pssetup}) || ($self->{copies} > 1)) {
push @$page, "\%\%BeginSetup\n";
- if ($self->{copies} > 1)
- {
+ if ($self->{copies} > 1) {
push @$page, "/#copies " . $self->{copies} . " def\n";
}
push @$page, \$self->{pssetup};
@@ -772,25 +811,26 @@ sub _builddocument# {{{
# Pages
push @$page, \$self->{pspages};
- if ((!$self->{eps}) && ($self->{pspagecount} > 0))
- {
+ 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}))
- {
+ if (length($self->{pstrailer})) {
push @$page, "\%\%Trailer\n";
push @$page, \$self->{pstrailer};
}
push @$page, "\%\%EOF\n";
return $page;
-}# }}}
+}
+
+
+#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-sub output# {{{
+sub output
{
my $self = shift;
my $file = shift || die("Must supply a filename for output");
@@ -800,7 +840,7 @@ sub output# {{{
$page = _builddocument($self, $file);
local *OUT;
- open(OUT, '>'.$file) or die("Cannot write to file $file: $!");
+ open(OUT, '>', $file) or die("Cannot write to file $file: $!");
foreach $i (@$page) {
if (ref($i) eq "SCALAR") {
@@ -813,9 +853,11 @@ sub output# {{{
close OUT;
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item C<get>
Returns the current document.
@@ -825,7 +867,7 @@ document in memory is not cleared, and can still be extended.
=cut
-sub get# {{{
+sub get
{
my $self = shift;
my $page;
@@ -842,8 +884,10 @@ sub get# {{{
}
}
return $doc;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item C<geteps>
@@ -857,7 +901,7 @@ change these, call it yourself as below, rather than using this method.
=cut
-sub geteps# {{{
+sub geteps
{
my $self = shift;
my $page;
@@ -869,16 +913,19 @@ sub geteps# {{{
$eps = new PostScript::Simple::EPS(source => $self->get);
return $eps;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item C<setcolour((red, green, blue)|(name))>
-Sets the new drawing colour to the values specified in C<red>, C<green> and
+Sets the new drawing colour to the RGB values specified in C<red>, C<green> and
C<blue>. 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.
+listed at the top of the PostScript::Simple module in the C<%pscolours> hash
+and include the standard X-Windows colour names.
Example:
@@ -889,49 +936,51 @@ Example:
=cut
-sub setcolour# {{{
+sub setcolour
{
my $self = shift;
my ($r, $g, $b) = @_;
- if ( @_ == 1 )
- {
+ if ( @_ == 1 ) {
$r = lc $r;
-
- if (defined $pscolours{$r})
- {
- ($r, $g, $b) = split(/\s+/, $pscolours{$r});
+ if (defined $pscolours{$r}) {
+ ($r, $g, $b) = @{$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' }
+
+ my $bad = 0;
+ if (not defined $r) { $r = 'undef'; $bad = 1; }
+ if (not defined $g) { $g = 'undef'; $bad = 1; }
+ if (not defined $b) { $b = 'undef'; $bad = 1; }
+
+ if ($bad) {
$self->_error( "setcolour given invalid arguments: $r, $g, $b" );
return 0;
}
- if ($self->{colour})
- {
+ # make sure floats aren't too long, and means the tests pass when
+ # using a system with long doubles enabled by default
+ $r = 0 + sprintf("%0.5f", $r / 255);
+ $g = 0 + sprintf("%0.5f", $g / 255);
+ $b = 0 + sprintf("%0.5f", $b / 255);
+
+ 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
+ # Better colour->grey conversion than just 0.33 of each:
+ $r = 0.3*$r + 0.59*$g + 0.11*$b;
+ $r = 0 + sprintf("%0.5f", $r / 255);
$self->{pspages} .= "$r setgray\n";
}
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item C<setlinewidth(width)>
@@ -946,25 +995,23 @@ Example:
=cut
-
-sub setlinewidth# {{{
+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" }
+ $width = "0.4 bp" if $width eq "thin";
- $self->{pspages} .= "$width setlinewidth\n";
+ $self->{pspages} .= $self->_u($width) . "setlinewidth\n";
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item C<line(x1,y1, x2,y2 [,red, green, blue])>
Draws a line from the co-ordinates (x1,x2) to (x2,y2). If values are specified
@@ -986,38 +1033,33 @@ Example:
=cut
-
-sub line# {{{
+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
+ if ((!$self->{pspagecount}) and (!$self->{eps})) {
+ # Cannot draw on to non-page when not an eps file
return 0;
}
- if ( @_ == 7 )
- {
+ if ( @_ == 7 ) {
$self->setcolour($r, $g, $b);
- }
- elsif ( @_ != 4 )
- {
- $self->_error( "wrong number of args for line" );
- return 0;
+ } 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";
+ $self->{pspages} .= $self->_uxy($x2, $y2) . "lineto stroke\n";
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item C<linextend(x,y)>
Assuming the previous command was C<line>, C<linextend>, C<curve> or
@@ -1037,29 +1079,27 @@ The C<polygon> method may be more appropriate.
=cut
-
-sub linextend# {{{
+sub linextend
{
my $self = shift;
my ($x, $y) = @_;
- unless ( @_ == 2 )
- {
+ unless ( @_ == 2 ) {
$self->_error( "wrong number of args for linextend" );
- return 0;
+ return 0;
}
- $self->{pspages} =~ s/eto stroke\n$/eto\n$x ux $y uy lineto stroke\n/;
+ my $out = $self->_uxy($x, $y) . "lineto stroke\n";
+ $self->{pspages} =~ s/eto stroke\n$/eto\n$out/;
- ##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?
+ # perhaps we need something like $self->{_lastcommand} to know if operations
+ # are valid, rather than using a regexp?
-# $self->{pspages} .= "$x ux $y uy lineto stroke\n";
-# XXXXX fixme
-
return 1;
-}# }}}
+}
+
+
+#-------------------------------------------------------------------------------
=item C<arc([options,] x,y, radius, start_angle, end_angle)>
@@ -1088,7 +1128,7 @@ Example:
=cut
-sub arc# {{{
+sub arc
{
my $self = shift;
my %opt = ();
@@ -1098,7 +1138,7 @@ sub arc# {{{
}
if ((!$self->{pspagecount}) and (!$self->{eps})) {
-# Cannot draw on to non-page when not an eps file XXXXX
+ # Cannot draw on to non-page when not an eps file
return 0;
}
@@ -1110,7 +1150,7 @@ sub arc# {{{
}
$self->newpath;
- $self->{pspages} .= "$x ux $y uy $r u $sa $ea arc ";
+ $self->{pspages} .= $self->_uxy($x, $y) . $self->_u($r) . "$sa $ea arc ";
if ($opt{'filled'}) {
$self->{pspages} .= "fill\n"
} else {
@@ -1118,7 +1158,10 @@ sub arc# {{{
}
return 1;
-}# }}}
+}
+
+
+#-------------------------------------------------------------------------------
=item C<polygon([options,] x1,y1, x2,y2, ..., xn,yn)>
@@ -1165,8 +1208,7 @@ Example:
=cut
-
-sub polygon# {{{
+sub polygon
{
my $self = shift;
@@ -1174,119 +1216,90 @@ sub polygon# {{{
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...
+ if ($#_ < 3) {
+ # cannot have polygon with just one point...
$self->_error( "bad polygon - not enough points" );
return 0;
}
- if (ref($_[0]))
- {
+ if (ref($_[0])) {
%opt = %{; shift};
}
my $x = shift;
my $y = shift;
- if (defined $opt{'rotate'})
- {
- if (ref($opt{'rotate'}))
- {
+ if (defined $opt{'rotate'}) {
+ if (ref($opt{'rotate'})) {
($rotate, $rotatex, $rotatey) = @{$opt{'rotate'}};
- }
- else
- {
+ } else {
($rotate, $rotatex, $rotatey) = ($opt{'rotate'}, $x, $y);
}
}
- if (defined $opt{'offset'})
- {
- if (ref($opt{'offset'}))
- {
+ if (defined $opt{'offset'}) {
+ if (ref($opt{'offset'})) {
($xoffset, $yoffset) = @{$opt{'offset'}};
- }
- else
- {
+ } else {
$self->_error("polygon: bad offset option" );
return 0;
}
}
- if (!defined $opt{'filled'})
- {
+ if (!defined $opt{'filled'}) {
$opt{'filled'} = 0;
}
- unless (defined($x) && defined($y))
- {
+ unless (defined($x) && defined($y)) {
$self->_error("polygon: no start point");
return 0;
}
my $savestate = ($xoffset || $yoffset || $rotate) ? 1 : 0 ;
- if ( $savestate )
- {
+ 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 ($xoffset || $yoffset) {
+ $self->{pspages} .= $self->_uxy($xoffset, $yoffset) . "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";
+ if ($rotate) {
+ if (!$self->{usedrotabout}) {
+ $self->{psfunctions} .= "/rotabout {3 copy pop translate rotate exch ";
+ $self->{psfunctions} .= "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->{pspages} .= $self->_uxy($rotatex, $rotatey) . "$rotate rotabout\n";
}
$self->newpath;
$self->moveto($x, $y);
- while ($#_ > 0)
- {
+ while ($#_ > 0) {
my $x = shift;
my $y = shift;
- $self->{pspages} .= "$x ux $y uy lineto ";
+ $self->{pspages} .= $self->_uxy($x, $y) . "lineto ";
}
- if ($opt{'filled'})
- {
+ if ($opt{'filled'}) {
$self->{pspages} .= "fill\n";
- }
- else
- {
+ } else {
$self->{pspages} .= "stroke\n";
}
- if ( $savestate )
- {
+ if ( $savestate ) {
$self->{pspages} .= "grestore\n";
}
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item C<circle([options,] x,y, r)>
@@ -1310,37 +1323,36 @@ Example:
=cut
-
-sub circle# {{{
+sub circle
{
my $self = shift;
my %opt = ();
- if (ref($_[0]))
- {
+ if (ref($_[0])) {
%opt = %{; shift};
}
my ($x, $y, $r) = @_;
- unless (@_ == 3)
- {
+ unless (@_ == 3) {
$self->_error("circle: wrong number of arguments");
return 0;
}
- if (!$self->{usedcircle})
- {
+ 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 ";
+ $self->{pspages} .= $self->_uxy($x, $y) . $self->_u($r) . "circle ";
if ($opt{'filled'}) { $self->{pspages} .= "fill\n" }
else {$self->{pspages} .= "stroke\n" }
return 1;
-}# }}}
+}
+
+
+#-------------------------------------------------------------------------------
=item C<circletext([options,] x, y, r, a, text)>
@@ -1366,14 +1378,12 @@ Example:
=cut
-
-sub circletext# {{{
+sub circletext
{
my $self = shift;
my %opt = ();
- if (ref($_[0]))
- {
+ if (ref($_[0])) {
%opt = %{; shift};
}
@@ -1448,8 +1458,8 @@ EOCT
}
$self->{pspages} .= "gsave\n";
- $self->{pspages} .= " $x ux $y uy translate\n";
- $self->{pspages} .= " ($text) $self->{lastfontsize} $a $r u ";
+ $self->{pspages} .= " " . $self->_uxy($x, $y) . "translate\n";
+ $self->{pspages} .= " ($text) $self->{lastfontsize} $a " . $self->_u($r);
if ($opt{'align'} && ($opt{'align'} eq "outside")) {
$self->{pspages} .= "outsidecircletext\n";
} else {
@@ -1458,7 +1468,10 @@ EOCT
$self->{pspages} .= "grestore\n";
return 1;
-}# }}}
+}
+
+
+#-------------------------------------------------------------------------------
=item C<box(x1,y1, x2,y2 [, options])>
@@ -1486,32 +1499,28 @@ The C<polygon> method is far more flexible, but this method is quicker!
=cut
-
-sub box# {{{
+sub box
{
my $self = shift;
my %opt = ();
- if (ref($_[0]))
- {
+ if (ref($_[0])) {
%opt = %{; shift};
}
my ($x1, $y1, $x2, $y2) = @_;
unless (@_ == 4) {
- $self->_error("box: wrong number of arguments");
- return 0;
+ $self->_error("box: wrong number of arguments");
+ return 0;
}
- if (!defined($opt{'filled'}))
- {
+ if (!defined($opt{'filled'})) {
$opt{'filled'} = 0;
}
- unless ($self->{usedbox})
- {
+ unless ($self->{usedbox}) {
$self->{psfunctions} .= "/box {
newpath 3 copy pop exch 4 copy pop pop
8 copy pop pop pop pop exch pop exch
@@ -1522,14 +1531,17 @@ sub box# {{{
$self->{usedbox} = 1;
}
- $self->{pspages} .= "$x1 ux $y1 uy $x2 ux $y2 uy box ";
+ $self->{pspages} .= $self->_uxy($x1, $y1);
+ $self->{pspages} .= $self->_uxy($x2, $y2) . "box ";
if ($opt{'filled'}) { $self->{pspages} .= "fill\n" }
else {$self->{pspages} .= "stroke\n" }
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item C<setfont(font, size)>
Set the current font to the PostScript font C<font>. Set the size in PostScript
@@ -1541,15 +1553,14 @@ This method must be called on every page before the C<text> method is used.
=cut
-
-sub setfont# {{{
+sub setfont
{
my $self = shift;
my ($name, $size, $ysize) = @_;
unless (@_ == 2) {
- $self->_error( "wrong number of arguments for setfont" );
- return 0;
+ $self->_error( "wrong number of arguments for setfont" );
+ return 0;
}
# set font y size XXXXX
@@ -1558,8 +1569,10 @@ sub setfont# {{{
$self->{lastfontsize} = $size;
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item C<text([options,] x,y, string)>
@@ -1592,8 +1605,7 @@ Example:
=cut
-
-sub text# {{{
+sub text
{
my $self = shift;
@@ -1602,23 +1614,21 @@ sub text# {{{
my $align = "";
my %opt = ();
- if (ref($_[0]))
- {
+ if (ref($_[0])) {
%opt = %{; shift};
}
unless ( @_ == 3 )
{ # check required params first
- $self->_error("text: wrong number of arguments");
- return 0;
+ $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;
+ unless (defined($x) && defined($y) && defined($text)) {
+ $self->_error("text: wrong number of arguments");
+ return 0;
}
# Escape text to allow parentheses
@@ -1630,11 +1640,9 @@ sub text# {{{
# rotation
- if (defined $opt{'rotate'})
- {
+ if (defined $opt{'rotate'}) {
my $rot_a = $opt{ 'rotate' };
- if( $rot_a != 0 )
- {
+ if( $rot_a != 0 ) {
$rot = " $rot_a rotate ";
$rot_a = -$rot_a;
$rot_m = " $rot_a rotate ";
@@ -1642,10 +1650,9 @@ sub text# {{{
}
# alignment
+
$align = " show stroke";
- # align left
- if (defined $opt{'align'})
- {
+ 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"
@@ -1655,9 +1662,11 @@ sub text# {{{
$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
@@ -1665,33 +1674,33 @@ control points for the start- and end-points respectively.
=cut
-
-sub curve# {{{
+sub curve
{
my $self = shift;
my ($x1, $y1, $x2, $y2, $x3, $y3, $x4, $y4) = @_;
-# dashed lines? XXXXX
- unless ( @_ == 8 )
- {
+ 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
+ if ((!$self->{pspagecount}) and (!$self->{eps})) {
+ # Cannot draw on to non-page when not an eps file
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";
+ $self->{pspages} .= $self->_uxy($x2, $y2);
+ $self->{pspages} .= $self->_uxy($x3, $y3);
+ $self->{pspages} .= $self->_uxy($x4, $y4) . "curveto stroke\n";
return 1;
-}# }}}
+}
+#-------------------------------------------------------------------------------
+
=item curvextend( x1, y1, x2, y2, x3, y3 )
Assuming the previous command was C<line>, C<linextend>, C<curve> or
@@ -1701,55 +1710,67 @@ other method is unspecified.
=cut
-
-sub curvextend# {{{
+sub curvextend
{
my $self = shift;
my ($x1, $y1, $x2, $y2, $x3, $y3) = @_;
- unless ( @_ == 6 )
- {
+
+ unless ( @_ == 6 ) {
$self->_error( "bad curvextend definition, wrong number of args" );
return 0;
}
+ my $out = $self->_uxy($x1, $y1);
+ $out .= $self->_uxy($x2, $y2);
+ $out .= $self->_uxy($x3, $y3) . "curveto stroke\n";
+
# 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/;
+ $self->{pspages} =~ s/eto stroke\n$/eto\n$out/;
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item newpath
-This method is used internally to begin a new drawing path - you should generally NEVER use it.
+This method is used internally to begin a new drawing path - you should
+generally NEVER use it.
=cut
-
-sub newpath# {{{
+sub newpath
{
- my $self = shift;
- $self->{pspages} .= "newpath\n";
- return 1;
-}# }}}
+ 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.
+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# {{{
+sub moveto
{
- my $self = shift;
- my ($x, $y) = @_;
- $self->{pspages} .= "$x ux $y uy moveto\n";
- return 1;
-}# }}}
+ my $self = shift;
+ my ($x, $y) = @_;
+
+ $self->{pspages} .= $self->_uxy($x, $y) . "moveto\n";
+
+ return 1;
+}
+
+#-------------------------------------------------------------------------------
=item C<importepsfile([options,] filename, x1,y1, x2,y2)>
@@ -1793,8 +1814,7 @@ Example:
=cut
-
-sub importepsfile# {{{
+sub importepsfile
{
my $self = shift;
@@ -1865,8 +1885,10 @@ sub importepsfile# {{{
$self->_add_eps($eps, $x1, $y1);
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
=item C<importeps(filename, x,y)>
@@ -1895,8 +1917,7 @@ Example:
=cut
-
-sub importeps# {{{
+sub importeps
{
my $self = shift;
my ($epsobj, $xpos, $ypos) = @_;
@@ -1909,9 +1930,13 @@ sub importeps# {{{
$self->_add_eps($epsobj, $xpos, $ypos);
return 1;
-}# }}}
+}
+
+
+################################################################################
+# PRIVATE methods
-sub _add_eps# {{{
+sub _add_eps
{
my $self = shift;
my $epsobj;
@@ -1929,8 +1954,8 @@ sub _add_eps# {{{
}
if ( @_ != 3 ) {
- croak "internal error: wrong number of arguments for _add_eps";
- return 0;
+ croak "internal error: wrong number of arguments for _add_eps";
+ return 0;
}
unless ($self->{usedimporteps}) {
@@ -1949,23 +1974,26 @@ EOEPS
($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} .= $self->_uxy($xpos, $ypos) . "translate\n";
+ $self->{pspages} .= $self->_uxy(1, 1) . "scale\n";
$self->{pspages} .= $epsobj->_get_include_data($xpos, $ypos);
$self->{pspages} .= "EndEPSF\n";
return 1;
-}# }}}
+}
+
+#-------------------------------------------------------------------------------
+
+sub _error {
+ my $self = shift;
+ my $msg = shift;
-### PRIVATE
+ $self->{pspages} .= "(error: $msg\n) print flush\n";
+}
-sub _error {# {{{
- my $self = shift;
- my $msg = shift;
- $self->{pspages} .= "(error: $msg\n) print flush\n";
-}# }}}
+#-------------------------------------------------------------------------------
# Display method for debugging internal variables
#
@@ -1995,7 +2023,7 @@ Thanks!
Please see the README file in the distribution for more information about
contributors.
-Copyright (C) 2002-2003 Matthew C. Newton / Newton Computing
+Copyright (C) 2002-2014 Matthew C. Newton
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
@@ -30,39 +30,39 @@ ok( $s->{'pspages'} eq CANNED() );
sub CANNED {
return 'newpath
-10 ux 10 uy moveto
+10 ubp 10 ubp moveto
(Hello World) show stroke
newpath
-10 ux 10 uy moveto
+10 ubp 10 ubp moveto
(Hello World) dup stringwidth pop neg 0 rmoveto show
newpath
-10 ux 20 uy moveto
+10 ubp 20 ubp moveto
() show stroke
newpath
-10 ux 30 uy moveto
+10 ubp 30 ubp moveto
(\000) show stroke
(error: text: wrong number of arguments
) print flush
newpath
-10 ux 50 uy moveto
+10 ubp 50 ubp moveto
(ONE TWO THREE~~~~) show stroke
newpath
-40 ux 80 uy moveto
+40 ubp 80 ubp moveto
(ONE TWO THREE~~~~) 49 rotate dup stringwidth pop 2 div neg 0 rmoveto show -49 rotate
newpath
-10 ux 60 uy moveto
+10 ubp 60 ubp 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
+10 ubp 70 ubp moveto
(\024\025\026\027\030\031\032\033\034\035\036\037 !"#$%&\') show stroke
newpath
-10 ux 80 uy moveto
+10 ubp 80 ubp moveto
(xyz{|}~\177\200\201\202\203\204\205\206\207\210\211\212\213) show stroke
newpath
-10 ux 90 uy moveto
+10 ubp 90 ubp 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
+10 ubp 100 ubp moveto
(\(\(\(\)\)\)\(\)\(\)\(\)}{}{}][[]]}\)\(\)}\)\(]) show stroke
';
}
@@ -88,16 +88,13 @@ unlink 'x03.eps';
###
sub FUNCS {
-return '/ux {} def
-/uy {} def
-/u {} def
-/STARTDIFFENC { mark } bind def
+return '/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
{
@@ -119,7 +116,7 @@ return '/ux {} def
/EncodePointer exch def
} ifelse
} ifelse
- } loop
+ } loop
TempEncode def
} bind def
@@ -193,8 +190,7 @@ return '/ux {} def
/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
+/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
@@ -214,65 +210,65 @@ return '(error: Do not use newpage for eps files!
) print flush
(error: setcolour given invalid arguments: 120, 240, undef
) print flush
-0.470588235294118 0.941176470588235 0 setrgbcolor
-1 u setlinewidth
+0.47059 0.94118 0 setrgbcolor
+1 ubp setlinewidth
(error: setlinewidth not given a width
) print flush
newpath
-10 ux 10 uy moveto
-10 ux 20 uy lineto stroke
+10 ubp 10 ubp moveto
+10 ubp 20 ubp 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
+0.19608 0.19608 0.19608 setrgbcolor
newpath
-10 ux 10 uy moveto
-10 ux 20 uy lineto
-100 ux 100 uy lineto stroke
+10 ubp 10 ubp moveto
+10 ubp 20 ubp lineto
+100 ubp 100 ubp 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
+10 ubp 10 ubp moveto
+10 ubp 20 ubp lineto 110 ubp 10 ubp lineto 110 ubp 20 ubp lineto stroke
+gsave 10 ubp 10 ubp 45 rotabout
newpath
-10 ux 10 uy moveto
-10 ux 20 uy lineto 110 ux 10 uy lineto 110 ux 20 uy lineto fill
+10 ubp 10 ubp moveto
+10 ubp 20 ubp lineto 110 ubp 10 ubp lineto 110 ubp 20 ubp lineto fill
grestore
-gsave 20 ux 20 uy 45 rotabout
+gsave 20 ubp 20 ubp 45 rotabout
newpath
-10 ux 10 uy moveto
-10 ux 20 uy lineto 110 ux 10 uy lineto 110 ux 20 uy lineto stroke
+10 ubp 10 ubp moveto
+10 ubp 20 ubp lineto 110 ubp 10 ubp lineto 110 ubp 20 ubp lineto stroke
grestore
-gsave 10 ux 10 uy translate
+gsave 10 ubp 10 ubp translate
newpath
-10 ux 10 uy moveto
-10 ux 20 uy lineto 110 ux 10 uy lineto 110 ux 20 uy lineto stroke
+10 ubp 10 ubp moveto
+10 ubp 20 ubp lineto 110 ubp 10 ubp lineto 110 ubp 20 ubp 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
+120 ubp 120 ubp 30 ubp circle stroke
+120 ubp 120 ubp 30 ubp 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
+210 ubp 210 ubp 220 ubp 230 ubp box stroke
+215 ubp 215 ubp 225 ubp 235 ubp 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
+10 ubp 10 ubp moveto
(Hello World) show stroke
newpath
-10 ux 10 uy moveto
+10 ubp 10 ubp moveto
(Hello World) show stroke
newpath
-10 ux 10 uy moveto
+10 ubp 10 ubp moveto
(Hello World) 56 rotate show stroke -56 rotate
(error: text: wrong number of arguments
) print flush
@@ -281,9 +277,9 @@ newpath
(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
+10 ubp 310 ubp moveto
+10 ubp 320 ubp 110 ubp 310 ubp 110 ubp 320 ubp curveto
+110 ubp 330 ubp 210 ubp 330 ubp 210 ubp 320 ubp curveto stroke
(error: bad curvextend definition, wrong number of args
) print flush
';
@@ -0,0 +1,62 @@
+#!/usr/bin/perl
+use strict;
+use lib qw(./lib ../lib t/lib);
+use Test::Simple tests => 26;
+use PostScript::Simple;
+
+# test for units
+
+my $s = new PostScript::Simple();
+my $t = new PostScript::Simple(units => "in", direction => "LeftUp");
+my $u = new PostScript::Simple(units => "in", direction => "RightDown");
+
+ok( $s );
+ok( $t );
+
+ok( ! keys(%{$s->{usedunits}}) );
+
+ok( $s->_u("4") eq "4 ubp " );
+ok( $t->_u("4") eq "4 uin " );
+
+ok( keys(%{$s->{usedunits}}) );
+
+ok( $s->_u("4 bp") eq "4 ubp " );
+ok( $s->_u("4.5 in") eq "4.5 uin " );
+
+ok( $s->{usedunits}{bp} eq "/ubp {} def" );
+ok( $s->{usedunits}{in} eq "/uin {72 mul} def" );
+ok( ! defined($t->{usedunits}{bp}) );
+ok( $t->{usedunits}{in} eq "/uin {72 mul} def" );
+
+ok( $s->_u([9.9, "pt"]) eq "9.9 upt ");
+
+
+# check invalid args
+
+eval { $s->_u([2]) };
+ok( $@ );
+
+eval { $s->_u([2, 5]) };
+ok( $@ );
+
+eval { $s->_u([2.78, "mm", 6]) };
+ok( $@ );
+
+eval { $s->_u("mm") };
+ok( $@ );
+
+eval { $s->_u("6 6") };
+ok( $@ );
+
+ok( $s->_ux("5 pc") eq "5 upc " );
+ok( $t->_ux("5 pc") eq "-5 upc " );
+ok( $t->_uy("5 pc") eq "5 upc " );
+
+ok( $u->_uxy("5.394857 pc", "0.0010") eq "5.394857 upc -0.001 uin " );
+ok( $u->_uxy([1010105.394857, "dd"], "0.0010") eq "1010105.394857 udd -0.001 uin " );
+
+ok( keys(%{$s->{usedunits}}) == 4 );
+ok( keys(%{$t->{usedunits}}) == 2 );
+ok( keys(%{$u->{usedunits}}) == 3 );
+
+
@@ -16,8 +16,8 @@ $s->output( $f );
# 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 );
+ok( $s->{psfunctions} =~ m|/START| );
+ok( index( $s->{pspages}, q[10 ubp 10 ubp 40 ubp 190 ubp box stroke]) > -1 );
# check output
ok( -e $f );
@@ -28,4 +28,4 @@ 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 );
+ok( index( $file, '10 ubp 10 ubp 40 ubp 190 ubp box stroke' ) > 0 );
@@ -88,21 +88,18 @@ my ( $body ) = ( $lines =~ m/%%EndProlog\n(.*)%%EOF/s );
ok( $body );
ok( $body eq BODY());
-#print ">>>$body<<<<<<\n";
+#print STDERR ">>>$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
+ return q[/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
{
@@ -124,7 +121,7 @@ sub PROLOG {
/EncodePointer exch def
} ifelse
} ifelse
- } loop
+ } loop
TempEncode def
} bind def
@@ -199,14 +196,15 @@ sub PROLOG {
/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
+/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
+/ubp {} def
+/umm {72 mul 25.4 div} def
];
}
@@ -219,114 +217,114 @@ ll 2 ge { << /PageSize [ 595.27559 841.88976 ] /ImagingBBox null >> setpagedevic
/pagelevel save def
%%EndPageSetup
newpath
-10 ux 10 uy moveto
-10 ux 50 uy lineto stroke
-8 u setlinewidth
+10 umm 10 umm moveto
+10 umm 50 umm lineto stroke
+8 umm setlinewidth
newpath
-90 ux 10 uy moveto
-90 ux 50 uy lineto
-40 ux 90 uy lineto stroke
+90 umm 10 umm moveto
+90 umm 50 umm lineto
+40 umm 90 umm lineto stroke
1 0 0 setrgbcolor
-40 ux 90 uy 30 u circle fill
-0 0.5 0 setrgbcolor
-0.1 u setlinewidth
+40 umm 90 umm 30 umm circle fill
+0 0.49804 0 setrgbcolor
+0.1 umm 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
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
+gsave 70 umm 90 umm 20 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 40 rotabout
+gsave 70 umm 90 umm 40 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 60 rotabout
+gsave 70 umm 90 umm 60 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 80 rotabout
+gsave 70 umm 90 umm 80 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 100 rotabout
+gsave 70 umm 90 umm 100 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 120 rotabout
+gsave 70 umm 90 umm 120 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 140 rotabout
+gsave 70 umm 90 umm 140 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 160 rotabout
+gsave 70 umm 90 umm 160 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 180 rotabout
+gsave 70 umm 90 umm 180 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 200 rotabout
+gsave 70 umm 90 umm 200 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 220 rotabout
+gsave 70 umm 90 umm 220 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 240 rotabout
+gsave 70 umm 90 umm 240 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 260 rotabout
+gsave 70 umm 90 umm 260 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 280 rotabout
+gsave 70 umm 90 umm 280 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 300 rotabout
+gsave 70 umm 90 umm 300 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 320 rotabout
+gsave 70 umm 90 umm 320 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm lineto stroke
grestore
-gsave 70 ux 90 uy 340 rotabout
+gsave 70 umm 90 umm 340 rotabout
newpath
-40 ux 90 uy moveto
-69 ux 92 uy lineto 75 ux 84 uy lineto stroke
+40 umm 90 umm moveto
+69 umm 92 umm lineto 75 umm 84 umm 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
+0.4 ubp setlinewidth
+0 0.49804 0 setrgbcolor
+20 umm 10 umm 80 umm 20 umm box stroke
+0.29804 0.29804 0.29804 setrgbcolor
+20 umm 30 umm 80 umm 40 umm box fill
+0.09804 0.09804 0.09804 setrgbcolor
/Bookman findfont 12 scalefont setfont
newpath
-5 ux 5 uy moveto
+5 umm 5 umm moveto
(Matthew) show stroke
%%PageTrailer
pagelevel restore
@@ -336,32 +334,32 @@ showpage
/pagelevel save def
%%EndPageSetup
newpath
-10 ux 20 uy moveto
-30 ux 40 uy lineto
-60 ux 50 uy lineto stroke
+10 umm 20 umm moveto
+30 umm 40 umm lineto
+60 umm 50 umm lineto stroke
newpath
-10 ux 12 uy moveto
-20 ux 12 uy lineto stroke
+10 umm 12 umm moveto
+20 umm 12 umm 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
+10 umm 10 umm moveto
+20 umm 10 umm lineto stroke
+0.89804 0.89804 0.89804 setrgbcolor
+gsave 5 umm 5 umm 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
+10 umm 10 umm moveto
+15 umm 20 umm lineto 25 umm 20 umm lineto 30 umm 10 umm lineto 15 umm 15 umm lineto 10 umm 10 umm lineto fill
grestore
0 0 0 setrgbcolor
-gsave 10 ux 10 uy translate
-20 ux 20 uy 45 rotabout
+gsave 10 umm 10 umm translate
+20 umm 20 umm 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
+10 umm 10 umm moveto
+15 umm 20 umm lineto 25 umm 20 umm lineto 30 umm 10 umm lineto 15 umm 15 umm lineto 10 umm 10 umm lineto stroke
grestore
1 0 0 setrgbcolor
newpath
-0 ux 100 uy moveto
-100 ux 0 uy lineto stroke
+0 umm 100 umm moveto
+100 umm 0 umm lineto stroke
%%PageTrailer
pagelevel restore
showpage
@@ -369,82 +367,82 @@ showpage
%%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.14118 0 0 setrgbcolor
+10 umm 10 umm 12 umm 40 umm box fill
+0.16471 0 0 setrgbcolor
+12 umm 10 umm 14 umm 40 umm box fill
+0.18824 0 0 setrgbcolor
+14 umm 10 umm 16 umm 40 umm box fill
+0.21176 0 0 setrgbcolor
+16 umm 10 umm 18 umm 40 umm box fill
+0.23529 0 0 setrgbcolor
+18 umm 10 umm 20 umm 40 umm box fill
+0.25882 0 0 setrgbcolor
+20 umm 10 umm 22 umm 40 umm box fill
+0.28235 0 0 setrgbcolor
+22 umm 10 umm 24 umm 40 umm box fill
+0.30588 0 0 setrgbcolor
+24 umm 10 umm 26 umm 40 umm box fill
+0.32941 0 0 setrgbcolor
+26 umm 10 umm 28 umm 40 umm box fill
+0.35294 0 0 setrgbcolor
+28 umm 10 umm 30 umm 40 umm box fill
+0.37647 0 0 setrgbcolor
+30 umm 10 umm 32 umm 40 umm 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
+32 umm 10 umm 34 umm 40 umm box fill
+0.42353 0 0 setrgbcolor
+34 umm 10 umm 36 umm 40 umm box fill
+0.44706 0 0 setrgbcolor
+36 umm 10 umm 38 umm 40 umm box fill
+0.47059 0 0 setrgbcolor
+38 umm 10 umm 40 umm 40 umm box fill
+0.49412 0 0 setrgbcolor
+40 umm 10 umm 42 umm 40 umm box fill
+0.51765 0 0 setrgbcolor
+42 umm 10 umm 44 umm 40 umm box fill
+0.54118 0 0 setrgbcolor
+44 umm 10 umm 46 umm 40 umm box fill
+0.56471 0 0 setrgbcolor
+46 umm 10 umm 48 umm 40 umm box fill
+0.58824 0 0 setrgbcolor
+48 umm 10 umm 50 umm 40 umm box fill
+0.61176 0 0 setrgbcolor
+50 umm 10 umm 52 umm 40 umm box fill
+0.63529 0 0 setrgbcolor
+52 umm 10 umm 54 umm 40 umm box fill
+0.65882 0 0 setrgbcolor
+54 umm 10 umm 56 umm 40 umm box fill
+0.68235 0 0 setrgbcolor
+56 umm 10 umm 58 umm 40 umm box fill
+0.70588 0 0 setrgbcolor
+58 umm 10 umm 60 umm 40 umm box fill
+0.72941 0 0 setrgbcolor
+60 umm 10 umm 62 umm 40 umm box fill
+0.75294 0 0 setrgbcolor
+62 umm 10 umm 64 umm 40 umm box fill
+0.77647 0 0 setrgbcolor
+64 umm 10 umm 66 umm 40 umm 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
+66 umm 10 umm 68 umm 40 umm box fill
+0.82353 0 0 setrgbcolor
+68 umm 10 umm 70 umm 40 umm box fill
+0.84706 0 0 setrgbcolor
+70 umm 10 umm 72 umm 40 umm box fill
+0.87059 0 0 setrgbcolor
+72 umm 10 umm 74 umm 40 umm box fill
+0.89412 0 0 setrgbcolor
+74 umm 10 umm 76 umm 40 umm box fill
+0.91765 0 0 setrgbcolor
+76 umm 10 umm 78 umm 40 umm box fill
newpath
-40 ux 30 uy moveto
-30 ux 10 uy lineto
-60 ux 0 uy lineto stroke
+40 umm 30 umm moveto
+30 umm 10 umm lineto
+60 umm 0 umm lineto stroke
0 1 0 setrgbcolor
newpath
-0 ux 100 uy moveto
-100 ux 0 uy lineto stroke
+0 umm 100 umm moveto
+100 umm 0 umm lineto stroke
%%PageTrailer
pagelevel restore
showpage
@@ -55,9 +55,6 @@ 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
@@ -65,28 +62,28 @@ return q[%!PS-Adobe-3.0
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
+/rotabout {3 copy pop translate rotate exch 0 exch sub exch 0 exch sub translate} def
+/uin {72 mul} 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
+1 uin 1 uin moveto
+1 uin 4 uin lineto
+2 uin 4 uin lineto stroke
+1.5 uin 1 uin 2 uin 3.5 uin box stroke
+2 uin 2 uin 1 uin circle stroke
+0 0.39216 0.78431 setrgbcolor
+gsave 1 uin 1 uin 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
+1 uin 1 uin moveto
+1 uin 2 uin lineto 2 uin 2 uin lineto 2 uin 1 uin lineto 1 uin 1 uin 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
+1 uin 1 uin moveto
(Hello) -37.5 rotate show stroke 37.5 rotate
pagelevel restore
showpage
@@ -1,927 +0,0 @@
-package 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>.
-
- 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<Test::Harness> 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>
-
- 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<very> 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<is>
-
-=item B<isnt>
-
- is ( $this, $that, $test_name );
- isnt( $this, $that, $test_name );
-
-Similar to ok(), is() and isnt() compare their two arguments
-with C<eq> and C<ne> 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<isn't()>
-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 <<DIAGNOSTIC, $this, $that;
-# got: %s
-# expected: %s
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-sub isnt ($$;$) {
- my($this, $that, $name) = @_;
-
- my $test;
- {
- local $^W = 0; # so isnt(undef, undef) works quietly.
- $test = $this ne $that;
- }
-
- my $ok = @_ == 3 ? ok($test, $name)
- : ok($test);
-
- unless( $ok ) {
- $that = defined $that ? "'$that'" : 'undef';
-
- my_print *TESTERR, sprintf <<DIAGNOSTIC, $that;
-# it should not be %s
-# but it is.
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-*isn't = \&isnt;
-
-
-=item B<like>
-
- like( $this, qr/that/, $test_name );
-
-Similar to ok(), like() matches $this against the regex C<qr/that/>.
-
-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<qr//>) 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, <<ERR;
-# '$regex' doesn't look much like a regex to me. Failing the test.
-ERR
-
- return $ok;
- }
-
- unless( $ok ) {
- $this = defined $this ? "'$this'" : 'undef';
- my_print *TESTERR, sprintf <<DIAGNOSTIC, $this;
-# %s
-# doesn't match '$regex'
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-=item B<can_ok>
-
- 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>
-
- 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<pass>
-
-=item B<fail>
-
- 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<use_ok> and C<require_ok>.
-
-=over 4
-
-=item B<use_ok>
-
- 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 <<USE;
-package $pack;
-require $module;
-$module->import(\@imports);
-USE
-
- my $ok = ok( !$@, "use $module;" );
-
- unless( $ok ) {
- my_print *TESTERR, <<DIAGNOSTIC;
-# Tried to use '$module'.
-# Error: $@
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-=item B<require_ok>
-
- require_ok($module);
-
-Like use_ok(), except it requires the $module.
-
-=cut
-
-sub require_ok ($) {
- my($module) = shift;
-
- my $pack = caller;
-
- eval <<REQUIRE;
-package $pack;
-require $module;
-REQUIRE
-
- my $ok = ok( !$@, "require $module;" );
-
- unless( $ok ) {
- my_print *TESTERR, <<DIAGNOSTIC;
-# Tried to require '$module'.
-# Error: $@
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-=back
-
-=head2 Conditional tests
-
-B<WARNING!> The following describes an I<experimental> interface that
-is subject to change B<WITHOUT NOTICE>! 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<Test::Harness>.
-
-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: BLOCK>
-
- 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<no_plan>).
-
-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</Why are skip and todo so weird?>
-
-=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: BLOCK>
-
- 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<NOTE> These are NOT well-tested on circular references. Nor am I
-quite sure what will happen with filehandles.
-
-=over 4
-
-=item B<eq_array>
-
- 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>
-
- 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>
-
- eq_set(\@this, \@that);
-
-Similar to eq_array(), except the order of the elements is B<not>
-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<explicitly> 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 E<lt>schwern@pobox.comE<gt> 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<Test::Simple> if all this confuses you and you just want to write
-some tests. You can upgrade to Test::More later (its forward
-compatible).
-
-L<Test> for a similar testing module.
-
-L<Test::Harness> for details on how your test results are interpreted
-by Perl.
-
-L<Test::Unit> describes a very featureful unit testing interface.
-
-L<Pod::Tests> shows the idea of embedded testing.
-
-L<SelfTest> is another approach to embedded testing.
-
-=cut
-
-1;
@@ -1,495 +0,0 @@
-package 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<read Test::Tutorial> 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>
-
- 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, <<ERR if defined $name and $name =~ /^[\d\s]+$/;
-You named your test '$name'. You shouldn't use numbers for your test names.
-Very confusing.
-ERR
-
-
- my($pack, $file, $line) = caller;
- if( $pack eq 'Test::More' ) { # special case for Test::More's calls
- ($pack, $file, $line) = caller(1);
- }
-
- my($is_todo) = ${$pack.'::TODO'} ? 1 : 0;
-
- # We must print this all in one shot or else it will break on VMS
- my $msg;
- unless( $test ) {
- $msg .= "not ";
- $Test_Results[$Num_Tests-1] = $is_todo ? 1 : 0;
- }
- else {
- $Test_Results[$Num_Tests-1] = 1;
- }
- $msg .= "ok $Num_Tests";
-
- if( defined $name ) {
- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
- $msg .= " - $name";
- }
- if( $is_todo ) {
- my $what_todo = ${$pack.'::TODO'};
- $msg .= " # TODO $what_todo";
- }
- $msg .= "\n";
-
- my_print *TESTOUT, $msg;
-
- #'#
- unless( $test or $is_todo ) {
- my_print *TESTERR, "# Failed test ($file at line $line)\n";
- }
-
- return $test ? 1 : 0;
-}
-
-
-sub _skipped {
- my($why) = shift;
-
- 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++;
-
- # 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 <<WHOA;
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
-}
-
-=item B<_my_exit>
-
- _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<Test::More>.
-
-
-=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<explicitly> 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<at all>. 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
-E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
-
-
-=head1 SEE ALSO
-
-=over 4
-
-=item L<Test::More>
-
-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<Test>
-
-The original Perl testing module.
-
-=item L<Test::Unit>
-
-Elaborate unit testing.
-
-=item L<Pod::Tests>, L<SelfTest>
-
-Embed tests in your code!
-
-=item L<Test::Harness>
-
-Interprets the output of your test program.
-
-=back
-
-=cut
-
-1;
@@ -1,26 +0,0 @@
-package 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;