diff options
author | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 16:52:23 +0000 |
---|---|---|
committer | Siep Kroonenberg <siepo@cybercomm.nl> | 2011-02-17 16:52:23 +0000 |
commit | 8da2d23733595367fad869e5fbc6c9a87041879b (patch) | |
tree | 0f3719f4eea97f872b6347c6d9ff5aa2ccd38299 /Master/tlpkg/tlperl/lib/assert.pl | |
parent | 9d55a4cf517a832c74e85179eac4239f9be8d2e7 (diff) |
New tlperl part VIII
git-svn-id: svn://tug.org/texlive/trunk@21430 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/tlpkg/tlperl/lib/assert.pl')
-rw-r--r-- | Master/tlpkg/tlperl/lib/assert.pl | 61 |
1 files changed, 61 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/assert.pl b/Master/tlpkg/tlperl/lib/assert.pl new file mode 100644 index 00000000000..2c2073c7eaa --- /dev/null +++ b/Master/tlpkg/tlperl/lib/assert.pl @@ -0,0 +1,61 @@ +# +# This library is no longer being maintained, and is included for backward +# compatibility with Perl 4 programs which may require it. +# This legacy library is deprecated and will be removed in a future +# release of perl. +# +# assert.pl +# tchrist@convex.com (Tom Christiansen) +# +# Usage: +# +# &assert('@x > @y'); +# &assert('$var > 10', $var, $othervar, @various_info); +# +# That is, if the first expression evals false, we blow up. The +# rest of the args, if any, are nice to know because they will +# be printed out by &panic, which is just the stack-backtrace +# routine shamelessly borrowed from the perl debugger. + +sub assert { + &panic("ASSERTION BOTCHED: $_[$[]",$@) unless eval $_[$[]; +} + +sub panic { + package DB; + + select(STDERR); + + print "\npanic: @_\n"; + + exit 1 if $] <= 4.003; # caller broken + + # stack traceback gratefully borrowed from perl debugger + + local $_; + my $i; + my ($p,$f,$l,$s,$h,$a,@a,@frames); + for ($i = 0; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) { + @a = @args; + for (@a) { + if (/^StB\000/ && length($_) == length($_main{'_main'})) { + $_ = sprintf("%s",$_); + } + else { + s/'/\\'/g; + s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + } + $w = $w ? '@ = ' : '$ = '; + $a = $h ? '(' . join(', ', @a) . ')' : ''; + push(@frames, "$w&$s$a from file $f line $l\n"); + } + for ($i=0; $i <= $#frames; $i++) { + print $frames[$i]; + } + exit 1; +} + +1; |