From 85b7bc695629926641c7cb752fd478adfdf374f3 Mon Sep 17 00:00:00 2001 From: Marius Date: Sun, 4 Jul 2010 15:32:09 +0300 Subject: stable 2010-05-24 13:10 --- scripts/context/perl/makempy.pl | 361 +++++++++ scripts/context/perl/mptopdf.pl | 160 ++++ scripts/context/perl/path_tre.pm | 36 + scripts/context/perl/pdftrimwhite.pl | 525 +++++++++++++ scripts/context/perl/texfind.pl | 270 +++++++ scripts/context/perl/texfont.pl | 1373 ++++++++++++++++++++++++++++++++++ 6 files changed, 2725 insertions(+) create mode 100644 scripts/context/perl/makempy.pl create mode 100644 scripts/context/perl/mptopdf.pl create mode 100644 scripts/context/perl/path_tre.pm create mode 100644 scripts/context/perl/pdftrimwhite.pl create mode 100644 scripts/context/perl/texfind.pl create mode 100644 scripts/context/perl/texfont.pl (limited to 'scripts/context/perl') diff --git a/scripts/context/perl/makempy.pl b/scripts/context/perl/makempy.pl new file mode 100644 index 000000000..7cba2e1a6 --- /dev/null +++ b/scripts/context/perl/makempy.pl @@ -0,0 +1,361 @@ +eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q' + if 0; + +#D \module +#D [ file=makempy.pl, +#D version=2000.12.14, +#D title=\METAFUN, +#D subtitle=\METAPOST\ Text Graphics, +#D author=Hans Hagen, +#D date=\currentdate, +#D copyright={PRAGMA / Hans Hagen \& Ton Otten}] +#C +#C This module is part of the \CONTEXT\ macro||package and is +#C therefore copyrighted by \PRAGMA. See licen-en.pdf for +#C details. + +# Tobias Burnus provided the code needed to proper testing +# of binaries on UNIX as well as did some usefull suggestions +# to improve the functionality. + +# This script uses GhostScript and PStoEdit as well as +# pdfTeX, and if requested TeXEdit and ConTeXt. + +# todo: we can nowadays do without the intermediate step, because GS +# can now handle PDF quite good + +use Getopt::Long ; +use Config ; +use strict ; + +$Getopt::Long::passthrough = 1 ; # no error message +$Getopt::Long::autoabbrev = 1 ; # partial switch accepted + +my $help = 0 ; +my $silent = 0 ; +my $force = 0 ; +my $noclean = 0 ; + +my $amethod = my $pmethod = my $gmethod = 0 ; + +my $format = "plain" ; # can be "context" for plain users too + +&GetOptions + ( "help" => \$help , + "silent" => \$silent , + "force" => \$force , + "pdftops" => \$pmethod , + "xpdf" => \$pmethod , + "gs" => \$gmethod , + "ghostscript" => \$gmethod , + "noclean" => \$noclean ) ; + +my $mpochecksum = 0 ; + +my %tex ; my %start ; my %stop ; + +$tex{plain} = "pdftex" ; +$tex{latex} = "pdflatex" ; +$tex{context} = "texexec --batch --once --interface=en --pdf" ; + +$start{plain} = '' ; +$stop{plain} = '\end' ; + +$start{latex} = '\begin{document}' ; +$stop{latex} = '\end{document}' ; + +$start{context} = '\starttext' ; +$stop{context} = '\stoptext' ; + +my $ghostscript = "" ; +my $pstoedit = "" ; +my $pdftops = "" ; +my $acroread = "" ; + +my $wereondos = ($Config{'osname'} =~ /dos|mswin/io) ; + +# Unix only: assume that "gs" in the path. We could also +# use $ghostscipt = system "which gs" but this would require +# that which is installedd on the system. + +sub checkenv + { my ($var, $env) = @_ ; + if ($var) + { return $var } + elsif ($ENV{$env}) + { return $ENV{$env} } + else + { return $var } } + +$ghostscript = checkenv ($ghostscript, "GS_PROG" ) ; +$ghostscript = checkenv ($ghostscript, "GS" ) ; +$pstoedit = checkenv ($pstoedit , "PSTOEDIT") ; +$pdftops = checkenv ($pdftops , "PDFTOPS" ) ; +$acroread = checkenv ($acroread , "ACROREAD") ; + +sub setenv + { my ($var, $unix, $win) = @_ ; + if ($var) + { return $var } + elsif ($wereondos) + { return $win } + else + { return $unix } } + +$ghostscript = setenv($ghostscript, "gs" , "gswin32c") ; +$pstoedit = setenv($pstoedit , "pstoedit", "pstoedit") ; +$pdftops = setenv($pdftops , "pdftops" , "pdftops" ) ; +$acroread = setenv($acroread , "acroread", "" ) ; + +# Force a method if unknown. + +unless ($pmethod||$amethod||$gmethod) + { if ($wereondos) { $pmethod = 1 } else { $amethod = 1 } } + +# Set the error redirection used under Unix: +# stderr -> stdout + +my $logredirection = '>>' ; + +# This unfortunally doesn't work with the ksh and simple sh +# +# if (!$wereondos) +# { $logredirection = '2>&1 >>' ; # Bash +# $logredirection = '>>&' ; # tcsh, Bash +# default $logredirection. } + +# Some TeX Code Snippets. + +my $macros = ' + +% auxiliary macros + +\input supp-mis.tex + +\def\startTEXpage[scale=#1]% + {\output{} + \batchmode + \pdfoutput=1 + \pdfcompresslevel=9 + \hoffset=-1in + \voffset=\hoffset + \scratchcounter=#1 + \divide\scratchcounter1000 + \edef\TEXscale{\the\scratchcounter\space} + \forgetall + \setbox0=\vbox\bgroup} + +\def\stopTEXpage + {\egroup + \dimen0=\ht0 \advance\dimen0 \dp0 + \setbox2=\vbox to 10\dimen0 + {\pdfliteral{\TEXscale 0 0 \TEXscale 0 0 cm} + \copy0 + \pdfliteral{1 0 0 1 0 0 cm} + \vfill} + \wd2=10\wd0 + \pdfpageheight=\ht2 + \pdfpagewidth=\wd2 + \ScaledPointsToBigPoints{\number\pdfpageheight}\pdfcropheight + \ScaledPointsToBigPoints{\number\pdfpagewidth }\pdfcropwidth + \expanded{\pdfpageattr{/CropBox [0 0 \pdfcropwidth \space \pdfcropheight]}} + \shipout\hbox{\box2}} + +% end of auxiliary macros' ; + +sub report + { return if $silent ; + my $str = shift ; + if ($str =~ /(.*?)\s+([\:\/])\s+(.*)/o) + { if ($1 eq "") { $str = " " } else { $str = $2 } + print sprintf("%22s $str %s\n",$1,$3) } } + +sub error + { report("processing aborted : " . shift) ; + exit } + +sub process + { report("generating : " . shift) } + +sub banner + { return if $silent ; + print "\n" ; + report ("MakeMPY 1.1 - MetaFun / PRAGMA ADE 2000-2004") ; + print "\n" } + +my $metfile = "" ; # main metapost file +my $mpofile = "" ; # metapost text specifiation file (provided) +my $mpyfile = "" ; # metapost text picture file (generated) +my $texfile = "" ; # temporary tex file +my $pdffile = "" ; # temporary pdf file +my $tmpfile = "" ; # temporary metapost file +my $posfile = "" ; # temporary postscript file +my $logfile = "" ; # temporary log file +my $errfile = "" ; # final log file (with suffix log) + +sub show_help_info + { banner ; + report ("--help : this message" ) ; + report ("--noclean : don't remove temporary files" ) ; + report ("--force : force processing (ignore checksum)" ) ; + report ("--silent : don't show messages" ) ; + print "\n" ; + report ("--pdftops : use pdftops (xpdf) pdf->ps") ; + report ("--ghostscript : use ghostscript (gs) for pdf->ps") ; + print "\n" ; + report ("input file : metapost file with graphics") ; + report ("programs needed : texexec and english context") ; + report (" : pdftops from the xpdf suite, or") ; # page size buggy + report (" : pdf2ps and ghostscript, and") ; + report (" : pstoedit and ghostscript") ; + report ("output file : metapost file with pictures") ; + exit } + +sub check_input_file + { my $file = $ARGV[0] ; + if ((!defined($file))||($file eq "")) + { banner ; error("no filename given") } + else + { $file =~ s/\.mp.*$//o ; + $metfile = "$file.mp" ; + $mpofile = "$file.mpo" ; + $mpyfile = "$file.mpy" ; + $logfile = "$file.log" ; + $texfile = "mpy-$file.tex" ; + $pdffile = "mpy-$file.pdf" ; + $posfile = "mpy-$file.pos" ; + $tmpfile = "mpy-$file.tmp" ; + $errfile = "mpy-$file.log" ; + if (! -f $metfile) + { banner ; error("$metfile is empty") } + elsif (-s $mpofile < 32) + { unlink $mpofile ; # may exist with zero length + unlink $mpyfile ; # get rid of left overs + exit } + else + { banner ; report("processing file : $mpofile") } } } + +sub verify_check_sum # checksum calculation from perl documentation + { return unless (open (MPO,"$mpofile")) ; + $mpochecksum = do { local $/ ; unpack("%32C*",) % 65535 } ; + close (MPO) ; + return unless open (MPY,"$mpyfile") ; + my $str = ; chomp $str ; + close (MPY) ; + if ($str =~ /^\%\s*mpochecksum\s*\:\s*(\d+)/o) + { if ($mpochecksum eq $1) + { report("mpo checksum : $mpochecksum / unchanged") ; + exit unless $force } + else + { report("mpo checksum : $mpochecksum / changed") } } } + +sub cleanup_files + { my @files = ; + foreach (@files) { unless (/\.log/o) { unlink $_ } } } + +sub construct_tex_file + { my $n = 0 ; + unless (open (MPO, "<$mpofile")) + { error("unable to open $mpofile") } + unless (open (TEX, ">$texfile")) + { error("unable to open $texfile") } + my $textext = "" ; + while () + { s/\s*$//mois ; + if (/\%\s*format=(\w+)/) + { $format = $1 } + else # if (!/^\%/) + { if (/startTEXpage/o) + { ++$n ; + $textext .= "$start{$format}\n" ; + $start{$format} = "" } + $textext .= "$_\n" } } + unless (defined($tex{$format})) { $format = "plain" } + if ($format eq "context") { $macros = "" } + # print TEX "$start{$format}\n$macros\n$textext\n$stop{$format}\n" ; + print TEX "$start{$format}\n\n" if $start{$format} ; + print TEX "$macros\n" if $macros ; + print TEX "$textext\n" if $textext ; + print TEX "$stop{$format}\n" if $stop{$format} ; + close (MPO) ; + close (TEX) ; + report("tex format : $format") ; + report("requested texts : $n") } + +sub construct_mpy_file + { unless (open (TMP, "<$tmpfile")) + { error("unable to open $tmpfile file") } + unless (open (MPY, ">$mpyfile")) + { error("unable to open $mpyfile file") } + print MPY "% mpochecksum : $mpochecksum\n" ; + my $copying = my $n = 0 ; + while () # a simple sub is faster + { if (s/beginfig/begingraphictextfig/o) + { print MPY $_ ; $copying = 1 ; ++$n } + elsif (s/endfig/endgraphictextfig/o) + { print MPY $_ ; $copying = 0 } + elsif ($copying) + { print MPY $_ } } + close (TMP) ; + close (MPY) ; + report("processed texts : $n") ; + report("produced file : $mpyfile") } + +sub run + { my ($resultfile, $program,$arguments) = @_ ; + my $result = system("$program $arguments $logredirection $logfile") ; + unless (-f $resultfile) { error("invalid `$program' run") } } + +sub make_pdf_pages + { process ("pdf file") ; + run ($pdffile, "$tex{$format}", "$texfile") } + +sub make_mp_figures + { process ("postscript file") ; + if ($pmethod) { run($posfile, "$pdftops", + "-paper match $pdffile $posfile") } + if ($gmethod) { run($posfile, "$ghostscript", + "-q -sOutputFile=$posfile -dNOPAUSE -dBATCH -dSAFER -sDEVICE=pswrite $pdffile") } + if ($amethod) { run($posfile, "$acroread", + "-toPostScript -pairs $pdffile $posfile") } } + +sub make_mp_pictures_ps + { process ("metapost file") ; + run ($tmpfile, "$pstoedit", "-ssp -dt -f mpost $posfile $tmpfile") } + +sub make_mp_pictures_pdf + { process ("metapost file") ; + run ($tmpfile, "$pstoedit", "-ssp -dt -f mpost $pdffile $tmpfile") } + +if ($help) { show_help_info } + +check_input_file ; +verify_check_sum ; +cleanup_files ; +construct_tex_file ; +make_pdf_pages ; +if (1) + { make_mp_pictures_pdf ; } +else + { make_mp_figures ; + make_mp_pictures_ps ; } +construct_mpy_file ; # less save : rename $tmpfile, $mpyfile ; +unless ($noclean) { cleanup_files } + +# a simple test file (needs context) +# +# % output=pdftex +# +# \starttext +# +# \startMPpage +# graphictext +# "\bf MAKE" +# scaled 8 +# zscaled (1,2) +# withdrawcolor \MPcolor{blue} +# withfillcolor \MPcolor{gray} +# withpen pencircle scaled 5pt ; +# \stopMPpage +# +# \stoptext diff --git a/scripts/context/perl/mptopdf.pl b/scripts/context/perl/mptopdf.pl new file mode 100644 index 000000000..41d1ae1f7 --- /dev/null +++ b/scripts/context/perl/mptopdf.pl @@ -0,0 +1,160 @@ +eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q' + if 0; + +# MikTeX users can set environment variable TEXSYSTEM to "miktex". + +#D \module +#D [ file=mptopdf.pl, +#D version=2000.05.29, +#D title=converting MP to PDF, +#D subtitle=\MPTOPDF, +#D author=Hans Hagen, +#D date=\currentdate, +#D url=www.pragma-ade.nl, +#D copyright={PRAGMA ADE / Hans Hagen \& Ton Otten}] +#C +#C This module is part of the \CONTEXT\ macro||package and is +#C therefore copyrighted by \PRAGMA. See licen-en.pdf for +#C details. + +# use File::Copy ; # not in every perl + +use Config ; +use Getopt::Long ; +use strict ; +use File::Basename ; + +$Getopt::Long::passthrough = 1 ; # no error message +$Getopt::Long::autoabbrev = 1 ; # partial switch accepted + +my $Help = my $Latex = my $RawMP = my $MetaFun = 0 ; +my $PassOn = '' ; + +&GetOptions + ( "help" => \$Help , + "rawmp" => \$RawMP, + "metafun" => \$MetaFun, + "passon" => \$PassOn, + "latex" => \$Latex ) ; + +my $program = "MPtoPDF 1.3.3" ; +my $pattern = "@ARGV" ; # was $ARGV[0] +my $miktex = 0 ; +my $done = 0 ; +my $report = '' ; +my $mplatexswitch = " --tex=latex " ; + +my $dosish = ($Config{'osname'} =~/^(ms)?dos|^os\/2|^mswin/i) ; +my $escapeshell = (($ENV{'SHELL'}) && ($ENV{'SHELL'} =~ m/sh/i )); + +if ($ENV{"TEXSYSTEM"}) { + $miktex = ($ENV{"TEXSYSTEM"} =~ /miktex/io) ; +} + +my @files ; +my $command = my $mpbin = '' ; + +# agressive copy, works for open files like in gs + +sub CopyFile { + my ($From,$To) = @_ ; + return unless open(INP,"<$From") ; + return unless open(OUT,">$To") ; + binmode INP ; + binmode OUT ; + while () { + print OUT $_ ; + } + close (INP) ; + close (OUT) ; +} + +if (($pattern eq '')||($Help)) { + print "\n$program : provide MP output file (or pattern)\n" ; + exit ; +} elsif ($pattern =~ /\.mp$/io) { + shift @ARGV ; my $rest = join(" ", @ARGV) ; + if (open(INP,$pattern)) { + while () { + if (/(documentstyle|documentclass|begin\{document\})/io) { + $Latex = 1 ; last ; + } + } + close (INP) ; + } + if ($RawMP) { + if ($Latex) { + $rest .= " $mplatexswitch" ; + } + if ($MetaFun) { + $mpbin = "mpost --progname=mpost --mem=metafun" ; + } else { + $mpbin = "mpost --mem=mpost" ; + } + } else { + if ($Latex) { + $rest .= " $mplatexswitch" ; + $mpbin = "mpost --mem=mpost" ; + } else { + $mpbin = "texexec --mptex $PassOn " ; + } + } + my $runner = "$mpbin $rest $pattern" ; + print "\n$program : running '$runner'\n" ; + my $error = system ($runner) ; + if ($error) { + print "\n$program : error while processing mp file\n" ; + exit 1 ; + } else { + $pattern =~ s/\.mp$//io ; + @files = glob "$pattern.*" ; + } +} elsif (-e $pattern) { + @files = ($pattern) ; +} elsif ($pattern =~ /.\../o) { + @files = glob "$pattern" ; +} else { + $pattern .= '.*' ; + @files = glob "$pattern" ; +} + +foreach my $file (@files) { + $_ = $file ; + if (s/\.(\d+|mps)$// && -e $file) { + if ($miktex) { + $command = "pdftex -undump=mptopdf" ; + } else { + $command = "pdftex -fmt=mptopdf -progname=context" ; + } + if ($dosish) { + $command = "$command \\relax $file" ; + } else { + $command = "$command \\\\relax $file" ; + } + my $error = system($command) ; + if ($error) { + print "\n$program : error while processing tex file\n" ; + exit 1 ; + } + my $pdfsrc = basename($_).".pdf"; + rename ($pdfsrc, "$_-$1.pdf") ; + if (-e $pdfsrc) { + CopyFile ($pdfsrc, "$_-$1.pdf") ; + } + if ($done) { + $report .= " +" ; + } + $report .= " $_-$1.pdf" ; + ++$done ; + } +} + +if ($report eq '') { + $report = '*' ; +} + +if ($done) { + print "\n$program : $pattern is converted to$report\n" ; +} else { + print "\n$program : no filename matches $pattern\n" ; +} diff --git a/scripts/context/perl/path_tre.pm b/scripts/context/perl/path_tre.pm new file mode 100644 index 000000000..546afcd27 --- /dev/null +++ b/scripts/context/perl/path_tre.pm @@ -0,0 +1,36 @@ +#D \module +#D [ file=path\_tre.pm, +#D version=1999.05.05, +#D title=Path modules, +#D subtitle=selecting a path, +#D author=Hans Hagen, +#D date=\currentdate, +#D copyright={PRAGMA / Hans Hagen \& Ton Otten}] +#C +#C This module is part of the \CONTEXT\ macro||package and is +#C therefore copyrighted by \PRAGMA. See licen-en.pdf for +#C details. + +#D Not yet documented, source will be cleaned up. + +package Tk::path_tre ; + +use Tk; +require Tk::DirTree ; + +use base qw(Tk::DirTree); +use strict; + +Construct Tk::Widget 'PathTree'; + +sub ClassInit + { my ($class,$mw) = @_ ; + return $class -> SUPER::ClassInit ($mw) } + +sub dirnames + { my ( $w, $dir ) = @_ ; + unless ($dir=~/\//) { $dir .= '/' } + my @names = $w->Callback("-dircmd", $dir, $w->cget("-showhidden")); + return( @names ) } + +__END__ diff --git a/scripts/context/perl/pdftrimwhite.pl b/scripts/context/perl/pdftrimwhite.pl new file mode 100644 index 000000000..6ac4f70c5 --- /dev/null +++ b/scripts/context/perl/pdftrimwhite.pl @@ -0,0 +1,525 @@ +eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q' + if 0; + +#D \module +#D [ file=pdftrimwhite.pl, +#D version=2000.07.13, +#D title=PDF postprocessing, +#D subtitle=cropping whitespace from pdf files, +#D author=Hans Hagen, +#D date=\currentdate, +#D copyright=PRAGMA ADE] + +#C This module is part of the \CONTEXT\ macro||package and is +#C therefore copyrighted by \PRAGMA. See readme.pdf for +#C details. + +#D This script can be used to crop margins that contain +#D useless information from a \PDF\ image. It does so by: +#D +#D \startitemize[packed,n] +#D \som cropping the image into an alternative file +#D \som determining the boundingbox of the alternative +#D \som cropping the image into a resulting file +#D \stoppacked +#D +#D In the process, some checks are carried out. Step~1 is +#D taken care of by \PDFTEX, step~2 by \GHOSTSCRIPT, using a +#D file generated by \PDFTOPS, and \PDFTEX\ is responsible +#D for step~3. +#D +#D \startuseMPgraphic{original} +#D numeric n ; n = 1cm ; +#D path p ; p := fullsquare xyscaled (8n,12n) ; +#D path q ; q := fullsquare xyscaled (2n,3n) shifted (n,n) ; +#D path r ; r := ((0,0)--(3n,0)) shifted (0, 5.5n) ; +#D path s ; s := ((0,0)--(3n,0)) shifted (0,-5.5n) ; +#D path t ; t := (-2n,-4n) ; +#D path u ; u := p enlarged -.75n ; +#D path v ; v := p enlarged (-1.75n,-2n) shifted (n,1.25n) ; +#D path w ; w := q enlarged .25n ; +#D fill p withcolor .7white ; +#D fill q withcolor .7green ; +#D draw r withpen pencircle scaled .25n withcolor .7green ; +#D draw s withpen pencircle scaled .25n withcolor .7green ; +#D draw t withpen pencircle scaled .50n withcolor .7green ; +#D draw u withpen pencircle scaled .10n withcolor white ; +#D draw v withpen pencircle scaled .10n withcolor .7red ; +#D draw w withpen pencircle scaled .10n ; +#D verbatimtex \tttf \setupframed[frame=off,align=left] etex ; +#D label (btex \framed{crap} etex, center r) ; +#D label (btex \framed{crap} etex, center s) ; +#D label (btex \framed{crap} etex, center t) ; +#D label (btex \framed{graphic} etex, center q) ; +#D label.urt(btex \framed{page} etex, llcorner p) ; +#D label.urt(btex \framed{crop} etex, llcorner u) ; +#D label.lft(btex \framed{leftcrop\\ +#D rightcrop\\ +#D topcrop\\ +#D bottomcrop} etex, .5[ulcorner v,llcorner v]) ; +#D label.bot(btex \framed{offset} etex, .5[llcorner w,lrcorner w]) ; +#D \stopuseMPgraphic +#D +#D \placefigure +#D [here][fig:pdftrimwhite] +#D {Crops and offsets.} +#D {\useMPgraphic{original}} +#D +#D The \TEX\ part has two alternatives, one using \CONTEXT, and +#D another using plain \TEX. The \CONTEXT\ method is slower but +#D can be extended more easily. +#D +#D The script is executed as follows: +#D +#D \starttyping +#D pdftrimwhite [] [] +#D \stoptyping +#D +#D The next call crops \type {test.pdf} to its natural +#D boundingbox. +#D +#D \starttyping +#D pdftrimwhite test +#D \stoptyping +#D +#D If the file has some crap at the bottom, you can say: +#D +#D \starttyping +#D pdftrimwhite test --bottomcrop=2cm +#D \stoptyping +#D +#D This clips 2cm from the bottom. You can clip on all sides +#D individually, in combination or at once, like in: +#D +#D \starttyping +#D pdftrimwhite test --bottomcrop=2cm --crop=1cm +#D \stoptyping +#D +#D The final result is a tightly cropped image. In order to get +#D a 5mm margin around this image, you can say: +#D +#D \starttyping +#D pdftrimwhite test --bottomcrop=2cm --offset=5mm +#D \stoptyping +#D +#D By default, the script intercepts logging messages and +#D writes them to a logfile with the same name as the +#D resulting image and the prefix \type {log}. If no name is +#D given, the name \type {pdftrimwhite} is used for all resulting +#D files. +#D +#D By default, \CONTEXT\ is used. When installed properly, you +#D can also use plain \TEX, by adding a switch \type +#D {--plain}. Partial switched are accepted, so the next call +#D is valid: +#D +#D \starttyping +#D pdftrimwhite test result --bot=2cm --off=5mm --plain +#D \stoptyping +#D +#D The current implementation uses an intermediate \POSTSCRIPT\ +#D file. This may change as \GHOSTSCRIPT\ gets more clever with +#D \PDF\ files. +#D +#D In \in {figure} [fig:pdftrimwhite] the green rectangle is the +#D picture we want to keep. Around this picture, we want a +#D margin, represented by the black rectangle, and specified by +#D \type {--offset}. The white rectangle is the cropbox +#D defined by \type {--crop}. That way we get rid of header +#D and footerlines. The red rectangle results from an +#D additional \type {--leftcrop} and \type {-bottomcrop} and +#D takes care of some content, as represented by the green +#D dot. +#D +#D The \type {--verbose} switch can be used to disable the +#D interception of log messages. + +#D We load a few \PERL\ modules \unknown\ + +use Config ; +use Getopt::Long ; + +use strict ; + +#D \unknown\ and initialize them. + +Getopt::Long::Configure + ("auto_abbrev", + "ignore_case", + "pass_through") ; + +#D Before fetching the switches, we initialize the +#D variables. + +my $Crop = "0cm" ; + +my $LeftCrop = "0cm" ; +my $RightCrop = "0cm" ; +my $TopCrop = "0cm" ; +my $BottomCrop = "0cm" ; + +my $Offset = "0cm" ; + +my $GSbin = "" ; +my $Verbose = 0 ; +my $Help = 0 ; +my $UsePlain = 0 ; + +my $Page = 1 ; + +#D On \MSWINDOWS\ and \UNIX\ the following defaults, combined +#D with the check later, should work out okay. + +my $pdfps = "pdftops" ; +my $gs = "gs" ; + +my $thisisunix = $Config{'osname'} !~ /dos|mswin/i ; + +#D When no resulting file is given, we use \type {pdftrimwhite} +#D as name (checked later). + +my $figurefile = "" ; +my $resultfile = "" ; +my $tempfile = "" ; + +my $programname = "pdftrimwhite" ; + +#D Messages are temporarily saved and written to a log file +#D afterwards. + +my $results = "" ; +my $pipe = "" ; +my $result = "" ; + +#D Unfortunately we need this information, first since +#D \PDFTOPS\ does not honor the cropbox, and second because +#D the vertical coordinated are swapped. + +my $pwidth = 597 ; +my $pheight = 847 ; +my $hoffset = 0 ; +my $voffset = 0 ; + +#D A few more variables. + +my $width = my $height = my $llx = my $lly = my $urx = my $ury = 0 ; + +#D Here are the switches we accept. The \type {--gsbin} switch +#D is a bonus one, and the \type {--help} switch comes +#D naturally. + +&GetOptions + ( "leftcrop=s" => \$LeftCrop , + "rightcrop=s" => \$RightCrop , + "topcrop=s" => \$TopCrop , + "bottomcrop=s" => \$BottomCrop, + "crop=s" => \$Crop , + "offset=s" => \$Offset , + "verbose" => \$Verbose , + "gsbin=s" => \$GSbin , + "plain" => \$UsePlain , + "page=i" => \$Page , + "help" => \$Help ) ; + +#D If asked for, or if no file is given, we provide some +#D help information. + +sub PrintHelp + { print "This is PdfTrimWhite\n\n" . + "usage:\n\n" . + "pdftrimwhite [switches] filename result\n\n" . + "switches:\n\n" . + "--crop=\n" . + "--offset=\n" . + "--leftcrop=\n" . + "--rightcrop=\n" . + "--topcrop=\n" . + "--bottomcrop=\n" . + "--gsbin=\n" . + "--page=\n" . + "--plain\n" . + "--verbose\n" } + +#D The preparations: + +sub GetItRight + { if ($Help) + { PrintHelp() ; exit } + $figurefile = $ARGV[0] ; $figurefile =~ s/\.pdf$//oi ; + $resultfile = $ARGV[1] ; $resultfile =~ s/\.pdf$//oi ; + $tempfile = "pdftrimwhite-$resultfile" ; + if ($figurefile eq '') + { PrintHelp() ; exit } + unless ($thisisunix) + { $gs = "gswin32c" } + if ($GSbin ne '') + { $gs = $GSbin } + unless (-e "$figurefile.pdf") + { print "Something is terribly wrong: no file found\n" ; + exit } + if (($resultfile eq '')||($resultfile=~/(^\-|\.)/io)) + { $resultfile = $programname } + $pipe = "2>&1" ; + if ($thisisunix) + { $pipe = "2>&1" } } + +#D Something common. + +sub SavePageData + { return "% saving page data +\\immediate\\openout\\scratchwrite=$figurefile.tmp +\\immediate\\write\\scratchwrite + {\\HOffsetBP\\space\\VOffsetBP\\space + \\FigureWidthBP\\space\\FigureHeightBP} +\\immediate\\closeout\\scratchwrite\n" } + +sub MakePageConTeXt + { return "% the real work +\\definepapersize + [Crap] + [width=\\FigureWidth, + height=\\FigureHeight] +\\setuppapersize + [Crap][Crap] +\\setuplayout + [topspace=0cm,backspace=0pt, + height=middle,width=middle, + header=0pt,footer=0pt] +\\starttext + \\startstandardmakeup + \\clip + [voffset=\\VOffset, + hoffset=\\HOffset, + width=\\FigureWidth, + height=\\FigureHeight] + {\\externalfigure[$figurefile.pdf][page=$Page]\\hss} + \\stopstandardmakeup +\\stoptext\n" } + +sub MakePagePlainTeX + { return "% the real work +\\output{} +\\hoffset=-1in +\\voffset=\\hoffset +\\pdfpageheight=\\FigureHeight +\\pdfpagewidth=\\FigureWidth +\\vbox to \\pdfpageheight + {\\offinterlineskip + \\vskip-\\VOffset + \\hbox to \\pdfpagewidth{\\hskip-\\HOffset\\box0\\hss} + \\vss} +\\end\n" } + +sub CalculateClip + { return "% some calculations +\\dimen0=\\figurewidth +\\dimen2=\\figureheight +\\dimen4=$Crop +\\dimen6=$Crop +\\advance\\dimen4 by $LeftCrop +\\advance\\dimen6 by $TopCrop +\\advance\\dimen0 by -\\dimen4 +\\advance\\dimen0 by -$Crop +\\advance\\dimen0 by -$RightCrop +\\advance\\dimen2 by -\\dimen6 +\\advance\\dimen2 by -$Crop +\\advance\\dimen2 by -$BottomCrop +\\edef\\FigureWidth {\\the\\dimen0} +\\edef\\FigureHeight{\\the\\dimen2} +\\edef\\HOffset {\\the\\dimen4} +\\edef\\VOffset {\\the\\dimen6} +\\ScaledPointsToWholeBigPoints{\\number\\dimen0}\\FigureWidthBP +\\ScaledPointsToWholeBigPoints{\\number\\dimen2}\\FigureHeightBP +\\ScaledPointsToWholeBigPoints{\\number\\dimen4}\\HOffsetBP +\\ScaledPointsToWholeBigPoints{\\number\\dimen6}\\VOffsetBP\n" } + +sub RecalculateClip + { return "% some calculations +\\dimen0=${width}bp +\\dimen2=${height}bp +\\dimen4=${hoffset}bp +\\dimen6=${pheight}bp +\\advance\\dimen0 by $Offset +\\advance\\dimen0 by $Offset +\\advance\\dimen2 by $Offset +\\advance\\dimen2 by $Offset +\\advance\\dimen4 by ${llx}bp +\\advance\\dimen4 by -$Offset +\\advance\\dimen6 by -${lly}bp +\\advance\\dimen6 by $Offset +\\advance\\dimen6 by -\\dimen2 +\\advance\\dimen6 by $TopCrop +\\edef\\FigureWidth {\\the\\dimen0} +\\edef\\FigureHeight{\\the\\dimen2} +\\edef\\HOffset {\\the\\dimen4} +\\edef\\VOffset {\\the\\dimen6}\n" } + +#D The previous scripts could be more sparse, but for the +#D moment we prefer readability. Both scripts save some +#D information in temporary file. We choose between them with +#D the following sub routine. + +#D The first pass: + +sub PrepareConTeXt + { return "% interface=en +\\setupoutput[pdftex] +\\getfiguredimensions[$figurefile.pdf][page=$Page]\n" } + +sub PreparePlainTeX + { return "% plain tex alternative, needs recent supp-mis +\\input supp-mis +\\pdfoutput=1 +\\newdimen\\figurewidth +\\newdimen\\figureheight +\\setbox0=\\hbox + {\\immediate\\pdfximage page $Page {$figurefile.pdf}\\pdfrefximage\\pdflastximage} +\\figurewidth=\\wd0 +\\figureheight=\\ht0\n" } + +sub PrepareFirstPass + { open (TEX, ">$tempfile.tex") ; + if ($UsePlain) + { print TEX + PreparePlainTeX . + CalculateClip . + SavePageData . + MakePagePlainTeX } + else + { print TEX + PrepareConTeXt . + CalculateClip . + SavePageData . + MakePageConTeXt } + close TEX } + +#D The second pass looks much like the first one, but this +#D time we don't save information, use the natural +#D boundingbox, and provide the offset. + +sub SetupConTeXt + { return "% interface=en +\\setupoutput[pdftex]\n" } + +sub SetupPlainTeX + { return "% plain tex alternative +\\pdfoutput=1 +\\setbox0=\\hbox + {\\immediate\\pdfximage page $Page {$figurefile.pdf}\\pdfrefximage\\pdflastximage}\n" } + +sub PrepareSecondPass + { open (TEX, ">$tempfile.tex") ; + if ($UsePlain) + { print TEX + SetupPlainTeX . + RecalculateClip . + MakePagePlainTeX } + else + { print TEX + SetupConTeXt . + RecalculateClip . + MakePageConTeXt } + close TEX } + +#D The information we save in the first pass, is loaded here. + +sub FetchPaperSize + { open (TMP,"$figurefile.tmp") ; + while () + { chomp ; + if (/^(\d+) (\d+) (\d+) (\d+) *$/oi) + { $hoffset = $1 ; + $voffset = $2 ; + $pwidth = $3 ; + $pheight = $4 ; + last } } + close (TMP) } + +#D Here we try to find the natural boundingbox. We need to +#D pick up the page dimensions here. + +sub RunTeX + { if ($UsePlain) + { $result = `pdftex -prog=pdftex -fmt=plain -int=batchmode $tempfile` } + else + { $result = `texexec --batch --once --purge $tempfile` } + print $result if $Verbose ; $results .= "$result\n" } + +sub FindBoundingBox + { $result = `$gs -sDEVICE=bbox -dNOPAUSE -dBATCH $tempfile.pdf $pipe` ; + print $result if $Verbose ; $results .= "$result\n" } + +sub IdentifyCropBox + { RunTeX() ; + FetchPaperSize () ; + FindBoundingBox() } + +#D Just to be sure, we check if there is some image data, so +#D that we can retry if something went wrong. Unfortunately we cannot +#D safely check on a high res boundingbox. + +my $digits = '([\-\d\.]+)' ; + +sub ValidatedCropBox + { if ($result =~ /BoundingBox:\s*$digits\s+$digits\s+$digits\s+$digits\s*/mois) + { $llx = $1 ; $lly = $2 ; $urx = $3 ; $ury = $4 } + else + { print "Something is terribly wrong: no boundingbox:\n$result\n" ; exit } + $width = abs($urx - $llx) ; + $height = abs($ury - $lly) ; + if ($width&&$height) + { return 1 } + else + { unless ($width) + { print "Something seems wrong: no width\n" ; + $LeftCrop = "0cm" ; $RightCrop = "0cm" ; $Crop = "0cm" } + unless ($height) + { print "Something seems wrong: no height\n" ; + $TopCrop = "0cm" ; $BottomCrop = "0cm" ; $Crop = "0cm" } + return 0 } } + +#D This is the main cropping routine. + +sub FixCropBox + { RunTeX() } + +#D For error tracing we save the log information in a file. + +sub RenameResult + { unlink "$resultfile.pdf" ; + rename "$tempfile.pdf", "$resultfile.pdf" } + +sub SaveLogInfo + { open (LOG, ">$resultfile.log") ; + print LOG $results ; + close (LOG) } + +#D We remove all temporary files. + +sub CleanUp + { unless ($Verbose) + { unlink "$tempfile.tex" ; + unlink "$tempfile.tuo" ; + unlink "$tempfile.tui" ; + unlink "$figurefile.tmp" } } + +#D Here it all comes together. + +GetItRight() ; + +PrepareFirstPass() ; + +IdentifyCropBox () ; + +unless (ValidatedCropBox()) + { PrepareFirstPass() ; + IdentifyCropBox () } + +if (ValidatedCropBox()) + { PrepareSecondPass() ; + FixCropBox() } + +RenameResult() ; +SaveLogInfo() ; + +CleanUp () ; diff --git a/scripts/context/perl/texfind.pl b/scripts/context/perl/texfind.pl new file mode 100644 index 000000000..53a560c79 --- /dev/null +++ b/scripts/context/perl/texfind.pl @@ -0,0 +1,270 @@ +eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q' + if 0; + +#D \module +#D [ file=texfind.pl, +#D version=1998.05.10, +#D title=\TEXFIND, +#D subtitle=searching files, +#D author=Hans Hagen, +#D date=\currentdate, +#D copyright={PRAGMA / Hans Hagen \& Ton Otten}] +#C +#C This module is part of the \CONTEXT\ macro||package and is +#C therefore copyrighted by \PRAGMA. See licen-en.pdf for +#C details. + +# test with "doif(un|)defined" + +use strict ; +use Getopt::Long ; +use File::Find ; +use Cwd ; +use Tk ; +use Tk::widgets ; +use Tk::ROText ; + +use FindBin ; +use lib $FindBin::Bin ; +use path_tre ; + +my $FileSuffix = 'tex' ; +my $SearchString = '' ; +my $Recurse = 0 ; +my $NumberOfHits = 0 ; +my $QuitSearch = 0 ; +my $Location = '' ; +my $currentpath = '.' ; + +my @FileList ; + +my ($dw, $mw, $log, $sea, $fil, $num, $but, $dir, $loc) ; + +$mw = MainWindow -> new () ; +$dw = MainWindow -> new () ; + +$mw -> protocol( 'WM_DELETE_WINDOW' => sub { exit } ) ; +$dw -> protocol( 'WM_DELETE_WINDOW' => sub { exit } ) ; + +$log = $mw -> Scrolled ( 'ROText' , + -scrollbars => 'se' , + -font => 'courier' , + -wrap => 'none' , + -width => 65 , + -height => 22 ) + -> pack ( -side => 'bottom' , + -padx => 2 , + -pady => 2 , + -expand => 1 , + -fill => 'both' ) ; + +$sea = $mw -> Entry ( -textvariable => \$SearchString , + -font => 'courier' , + -width => 20 ) + -> pack ( -side => 'left' , + -padx => 2 , + -pady => 2 ) ; + +$fil = $mw -> Entry ( -textvariable => \$FileSuffix , + -font => 'courier' , + -width => 5 ) + -> pack ( -side => 'left' , + -padx => 2 , + -pady => 2 ) ; + +$but = $mw -> Checkbutton ( -variable => \$Recurse , + -text => 'recurse' ) + -> pack ( -side => 'left' ) ; + +$num = $mw -> Entry ( -textvariable => \$NumberOfHits , + -font => 'courier' , + -justify => 'right' , + -width => 5 ) + -> pack ( -side => 'right' , + -padx => 2 , + -pady => 2 ) ; + +$loc = $mw -> Entry ( -textvariable => \$Location , + -font => 'courier' , + -width => 8 ) + -> pack ( -side => 'right' , + -padx => 2 , + -pady => 2 ) ; + +sub BuildDir + { if (Exists($dir)) { $dir -> destroy } ; + $dir = $dw -> Scrolled ( 'PathTree' , + -scrollbars => 'se' ) + -> pack ( -expand => 1 , + -fill => 'both' , + -padx => 2 , + -pady => 2 ) ; + $dir -> configure ( -font => 'courier' , + -height => 24 , + -width => 65 , + -selectbackground => 'blue3' , + -browsecmd => \&ChangePath ) ; + $dir -> bind ('' , \&ShowFile ) ; + $dir -> bind ('' , \&ShowFile ) } + +BuildDir ; + +sub ShowFile { $mw -> raise ; $sea -> focusForce } +sub ShowPath { $dw -> raise ; $dir -> focusForce } + +$log -> tagConfigure ( 'found', -foreground => 'green3' ) ; +$log -> tagConfigure ( 'title', -foreground => 'blue3' ) ; + +$sea -> bind ('' , \&LocateStrings ) ; +$fil -> bind ('' , \&LocateStrings ) ; +$loc -> bind ('' , \&ChangeLocation ) ; +$log -> bind ('' , \&ShowPath ) ; + +$sea -> bind ('' , \&QuitSearch ) ; +$fil -> bind ('' , \&QuitSearch ) ; +$loc -> bind ('' , \&QuitSearch ) ; + +$sea -> bind ('' , \&QuitSearch ) ; +$fil -> bind ('' , \&QuitSearch ) ; +$loc -> bind ('' , \&QuitSearch ) ; +$log -> bind ('' , \&QuitSearch ) ; + +$sea -> bind ('' , \&LocateStrings ) ; +$fil -> bind ('' , \&LocateStrings ) ; +$loc -> bind ('' , \&ChangeLocation ) ; +$log -> bind ('' , \&ShowPath ) ; + +sub ChangePath + { my $currentpath = shift ; +chdir($currentpath) ; + $QuitSearch = 1 ; + $log -> delete ('1.0', 'end') ; + $log -> insert ('end', "$currentpath\n\n", 'title') } + +sub ChangeLocation + { $QuitSearch = 1 ; + $log -> delete ('1.0', 'end') ; + $Location =~ s/^\s*//o ; + $Location =~ s/\s*$//o ; + $Location =~ s/(\\|\/\/)/\//go ; + unless (-d $Location) + { unless ($Location =~ /\//) { $Location .= '/' } } + if (-d $Location) + { $log -> insert ('end', "changed to location '$Location'\n\n", 'title') ; + $currentpath = $Location ; + chdir ($currentpath) ; + $dir -> destroy ; + BuildDir ; + $dw -> raise ; + $dw -> focusForce } + else + { $log -> insert ('end', "unknown location '$Location'\n\n", 'title') ; + $Location = '' } } + +sub QuitSearch + { $QuitSearch = 1 } + +sub SearchFile + { my ($FileName, $SearchString) = @_ ; + my $Ok = 0 ; my $len ; + open (TEX, $FileName) ; + my $LineNumber = 0 ; + while () + { ++$LineNumber ; + if ($QuitSearch) + { if ($Ok) { $log -> see ('end') } + last } + if (/$SearchString/i) + { ++$NumberOfHits ; $num -> update ; + unless ($Ok) + { $Ok = 1 ; + $log -> insert ('end', "$FileName\n\n",'title') } + $log -> insert ('end', sprintf("%5i : ",$LineNumber), 'title') ; + s/^\s*//o ; +# + $len = 0 ; + while (/(.*?)($SearchString)/gi) + { $len += length($1) + length($2) ; + $log -> insert ('end', "$1") ; + $log -> insert ('end', "$2", 'found' ) } + $_ = substr($_,$len) ; + $log -> insert ('end', "$_") ; +# + $log -> update ; + $log -> see ('end') } } + if ($Ok) { $log -> insert ('end', "\n") } + close (TEX) } + +sub DoLocateFiles + { @FileList = () ; + $NumberOfHits = 0 ; + if ($FileSuffix ne "") + { $log -> delete ('1.0', 'end') ; + if ($Recurse) + { $log -> insert ('end', "recursively identifying files\n", 'title') ; + $log -> see ('end') ; + find (\&wanted, $currentpath) ; + sub wanted + { if ($QuitSearch) { last ; return } + if (/.*\.$FileSuffix/i) + { ++$NumberOfHits ; $num -> update ; + push @FileList, $File::Find::name } } } + else + { $log -> insert ('end', "identifying files\n", 'title') ; + $log -> see ('end') ; + opendir(DIR, $currentpath) ; my @TEMPLIST = readdir(DIR) ; closedir(DIR) ; + foreach my $FileName (@TEMPLIST) + { if ($FileName =~ /.*\.$FileSuffix/i) + { ++$NumberOfHits ; $num -> update ; + if ($QuitSearch) + { last } + push @FileList, $FileName } } } + @FileList = sort @FileList } } + +sub DoLocateStrings + { $log -> delete ('1.0', 'end') ; + $log -> update ; + $log -> see ('end') ; + $NumberOfHits = 0 ; + if ($SearchString ne "") + { foreach my $FileName (@FileList) + { if ($QuitSearch) + { $log -> insert ('end', "search aborted\n", 'title') ; + $log -> see ('end') ; + last } + SearchFile($FileName,$SearchString) } } + unless ($QuitSearch) + { $log -> insert ('end', "done\n", 'title') ; + $log -> see ('end') } } + +sub LocateStrings + { $QuitSearch = 0 ; + DoLocateFiles() ; + DoLocateStrings() } + +$log -> insert ('end', + + "data fields\n\n" , '' , + + + "string :", 'title', " regular expression to search for\n" , '' , + "suffix :", 'title', " type of file to search in\n" , '' , + "recurse :", 'title', " enable searching subpaths\n" , '' , + "location :", 'title', " drive of root path\n" , '' , + "counter :", 'title', " file/hit counter\n\n" , '' , + + "key bindings\n\n" , '' , + + "double 1 :", 'title', " directory window <-> search window\n" , '' , + "enter :", 'title', " start searching\n" , '' , + "escape :", 'title', " quit searching\n\n" , '' , + + "current path\n\n" , '' , + + cwd(), 'title', "\n\n" , 'title' ) ; + +$log -> update ; + +ShowPath ; + +MainLoop() ; diff --git a/scripts/context/perl/texfont.pl b/scripts/context/perl/texfont.pl new file mode 100644 index 000000000..5b3c1f1d7 --- /dev/null +++ b/scripts/context/perl/texfont.pl @@ -0,0 +1,1373 @@ +eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q' + if 0; + +# This is an example of a crappy unstructured file but once +# I know what should happen exactly, I will clean it up. + +# once it works all right, afmpl will be default + +# todo : ttf (partially doen already) + +# added: $pattern in order to avoid fuzzy shelle expansion of +# filenames (not consistent over perl and shells); i hate that +# kind of out of control features. + +#D \module +#D [ file=texfont.pl, +#D version=2004.02.06, % 2000.12.14 +#D title=Font Handling, +#D subtitle=installing and generating, +#D author=Hans Hagen ++, +#D date=\currentdate, +#D copyright={PRAGMA / Hans Hagen \& Ton Otten}] +#C +#C This module is part of the \CONTEXT\ macro||package and is +#C therefore copyrighted by \PRAGMA. See licen-en.pdf for +#C details. + +#D For usage information, see \type {mfonts.pdf}. + +#D Todo : copy afm/pfb from main to local files to ensure metrics +#D Todo : Wybo's help system +#D Todo : list of encodings [texnansi, ec, textext] + +#D Thanks to George N. White III for solving a couple of bugs. +#D Thanks to Adam T. Lindsay for adding Open Type support (and more). + +use strict ; + +my $savedoptions = join (" ",@ARGV) ; + +use Config ; +use FindBin ; +use File::Copy ; +use Getopt::Long ; +use Data::Dumper; + +$Getopt::Long::passthrough = 1 ; # no error message +$Getopt::Long::autoabbrev = 1 ; # partial switch accepted + +# Unless a user has specified an installation path, we take +# the dedicated font path or the local path. + +## $dosish = ($Config{'osname'} =~ /dos|mswin/i) ; +my $dosish = ($Config{'osname'} =~ /^(ms)?dos|^os\/2|^(ms|cyg)win/i) ; + +my $IsWin32 = ($^O =~ /MSWin32/i); +my $SpacyPath = 0 ; + +# great, the win32api is not present in all perls + +BEGIN { + $IsWin32 = ($^O =~ /MSWin32/i) ; + $SpacyPath = 0 ; + if ($IsWin32) { + my $str = `kpsewhich -expand-path=\$TEXMF` ; + $SpacyPath = ($str =~ / /) ; + if ($SpacyPath) { + require Win32::API; import Win32::API; + } + } +} + +# great, glob changed to bsd glob in an incompatible way ... sigh, we now +# have to catch a failed glob returning the pattern +# +# to stupid either: +# +# sub validglob { +# my @globbed = glob(shift) ; +# if ((@globbed) && (! -e $globbed[0])) { +# return () ; +# } else { +# return @globbed ; +# } +# } +# +# so now we have: + +sub validglob { + my @globbed = glob(shift) ; + my @globout = () ; + foreach my $file (@globbed) { + push (@globout,$file) if (-e $file) ; + } + return @globout ; +} + +sub GetShortPathName { + my ($filename) = @_ ; + return $filename unless (($IsWin32)&&($SpacyPath)) ; + my $GetShortPathName = new Win32::API('kernel32', 'GetShortPathName', 'PPN', 'N') ; + if(not defined $GetShortPathName) { + die "Can't import API GetShortPathName: $!\n" ; + } + my $buffer = " " x 260; + my $len = $GetShortPathName->Call($filename, $buffer, 260) ; + return substr($buffer, 0, $len) ; +} + +my $installpath = "" ; + +if (defined($ENV{TEXMFLOCAL})) { + $installpath = "TEXMFLOCAL" ; +} + +if (defined($ENV{TEXMFFONTS})) { + $installpath = "TEXMFFONTS" ; +} + +if ($installpath eq "") { + $installpath = "TEXMFLOCAL" ; # redundant +} + +my $encoding = "texnansi" ; +my $vendor = "" ; +my $collection = "" ; +my $fontroot = "" ; #/usr/people/gwhite/texmf-fonts" ; +my $help = 0 ; +my $makepath = 0 ; +my $show = 0 ; +my $install = 0 ; +my $sourcepath = "." ; +my $passon = "" ; +my $extend = "" ; +my $narrow = "" ; +my $slant = "" ; +my $spaced = "" ; +my $caps = "" ; +my $noligs = 0 ; +my $nofligs = 0 ; +my $test = 0 ; +my $virtual = 0 ; +my $novirtual = 0 ; +my $listing = 0 ; +my $remove = 0 ; +my $expert = 0 ; +my $trace = 0 ; +my $afmpl = 0 ; +my $trees = 'TEXMFFONTS,TEXMFLOCAL,TEXMFEXTRA,TEXMFMAIN,TEXMFDIST' ; +my $pattern = '' ; +my $uselmencodings = 0 ; + +my $fontsuffix = "" ; +my $namesuffix = "" ; + +my $batch = "" ; + +my $weight = "" ; +my $width = "" ; + +my $preproc = 0 ; # atl: formerly OpenType switch +my $variant = "" ; # atl: encoding variant +my $extension = "pfb" ; # atl: default font extension +my $lcdf = "" ; # atl: trigger for lcdf otftotfm + +my @cleanup = () ; # atl: build list of generated files to delete + +# todo: parse name for style, take face from command line +# +# @Faces = ("Serif","Sans","Mono") ; +# @Styles = ("Slanted","Spaced", "Italic","Bold","BoldSlanted","BoldItalic") ; +# +# for $fac (@Faces) { for $sty (@Styles) { $FacSty{"$fac$sty"} = "" } } + +&GetOptions + ( "help" => \$help, + "makepath" => \$makepath, + "noligs" => \$noligs, + "nofligs" => \$nofligs, + "show" => \$show, + "install" => \$install, + "encoding=s" => \$encoding, + "variant=s" => \$variant, # atl: used as a suffix to $encfile only + "vendor=s" => \$vendor, + "collection=s" => \$collection, + "fontroot=s" => \$fontroot, + "sourcepath=s" => \$sourcepath, + "passon=s" => \$passon, + "slant=s" => \$slant, + "spaced=s" => \$spaced, + "extend=s" => \$extend, + "narrow=s" => \$narrow, + "listing" => \$listing, + "remove" => \$remove, + "test" => \$test, + "virtual" => \$virtual, + "novirtual" => \$novirtual, + "caps=s" => \$caps, + "batch" => \$batch, + "weight=s" => \$weight, + "width=s" => \$width, + "expert" => \$expert, + "afmpl" => \$afmpl, + "afm2pl" => \$afmpl, + "lm" => \$uselmencodings, + "rootlist=s" => \$trees, + "pattern=s" => \$pattern, + "trace" => \$trace, # --verbose conflicts with --ve + "preproc" => \$preproc, # atl: trigger conversion to pfb + "lcdf" => \$lcdf ) ; # atl: trigger use of lcdf fonttoools + +# for/from Fabrice: + +my $own_path = "$FindBin::Bin/" ; + +$FindBin::RealScript =~ m/([^\.]*)(\.pl|\.bat|\.exe|)/io ; + +my $own_name = $1 ; +my $own_type = $2 ; +my $own_stub = "" ; + +if ($own_type =~ /pl/oi) { + $own_stub = "perl " +} + +if ($caps) { $afmpl = 0 } # for the moment + +# so we can use both combined + +if ($lcdf) { + $novirtual = 1 ; +} + +if (!$novirtual) { + $virtual = 1 ; +} + +# A couple of routines. + +sub report { + my $str = shift ; + $str =~ s/ / /goi ; + if ($str =~ /(.*?)\s+([\:\/])\s+(.*)/o) { + if ($1 eq "") { + $str = " " ; + } else { + $str = $2 ; + } + print sprintf("%22s $str %s\n",$1,$3) ; + } +} + +sub error { + report("processing aborted : " . shift) ; + print "\n" ; + report "--help : show some more info" ; + exit ; +} + +# The banner. + +print "\n" ; +report ("TeXFont 2.2.1 - ConTeXt / PRAGMA ADE 2000-2004") ; +print "\n" ; + +# Handy for scripts: one can provide a preferred path, if it +# does not exist, the current path is taken. + +if (!(-d $sourcepath)&&($sourcepath ne 'auto')) { $sourcepath = "." } + +# Let's make multiple masters if requested. + +sub create_mm_font + { my ($name,$weight,$width) = @_ ; my $flag = my $args = my $tags = "" ; + my $ok ; + if ($name ne "") + { report ("mm source file : $name") } + else + { error ("missing mm source file") } + if ($weight ne "") + { report ("weight : $weight") ; + $flag .= " --weight=$weight " ; + $tags .= "-weight-$weight" } + if ($width ne "") + { report ("width : $width") ; + $flag .= " --width=$width " ; + $tags .= "-width-$width" } + error ("no specification given") if ($tags eq "") ; + error ("no amfm file found") unless (-f "$sourcepath/$name.amfm") ; + error ("no pfb file found") unless (-f "$sourcepath/$name.pfb") ; + $args = "$flag --precision=5 --kern-precision=0 --output=$sourcepath/$name$tags.afm" ; + my $command = "mmafm $args $sourcepath/$name.amfm" ; + print "$command\n" if $trace ; + $ok = `$command` ; chomp $ok ; + if ($ok ne "") { report ("warning $ok") } + $args = "$flag --precision=5 --output=$sourcepath/$name$tags.pfb" ; + $command = "mmpfb $args $sourcepath/$name.pfb" ; + print "$command\n" if $trace ; + $ok = `$command` ; chomp $ok ; + if ($ok ne "") { report ("warning $ok") } + report ("mm result file : $name$tags") } + +if (($weight ne "")||($width ne "")) + { create_mm_font($ARGV[0],$weight,$width) ; + exit } + +# go on + +if (($listing||$remove)&&($sourcepath eq ".")) + { $sourcepath = "auto" } + +if ($fontroot eq "") + { if ($dosish) + { $fontroot = `kpsewhich -expand-path=\$$installpath` } + else + { $fontroot = `kpsewhich -expand-path=\\\$$installpath` } + chomp $fontroot } + + +if ($fontroot =~ /\s+/) # needed for windows, spaces in name + { $fontroot = &GetShortPathName($fontroot) } # but ugly when not needed + +if ($test) + { $vendor = $collection = "test" ; + $install = 1 } + +if (($spaced ne "") && ($spaced !~ /\d/)) { $spaced = "50" } +if (($slant ne "") && ($slant !~ /\d/)) { $slant = "0.167" } +if (($extend ne "") && ($extend !~ /\d/)) { $extend = "1.200" } +if (($narrow ne "") && ($narrow !~ /\d/)) { $narrow = "0.800" } +if (($caps ne "") && ($caps !~ /\d/)) { $caps = "0.800" } + +$encoding = lc $encoding ; +$vendor = lc $vendor ; +$collection = lc $collection ; + +if ($encoding =~ /default/oi) { $encoding = "texnansi" } + +my $lcfontroot = lc $fontroot ; + +# Auto search paths + +my @trees = split(/\,/,$trees) ; + +# Test for help asked. + +if ($help) + { report "--fontroot=path : texmf destination font root (default: $lcfontroot)" ; + report "--rootlist=paths : texmf source roots (default: $trees)" ; + report "--sourcepath=path : when installing, copy from this path (default: $sourcepath)" ; + report "--sourcepath=auto : locate and use vendor/collection" ; + print "\n" ; + report "--vendor=name : vendor name/directory" ; + report "--collection=name : font collection" ; + report "--encoding=name : encoding vector (default: $encoding)" ; + report "--variant=name : encoding variant (.enc file or otftotfm features)" ; + print "\n" ; + report "--spaced=s : space glyphs in font by promille of em (0 - 1000)" ; + report "--slant=s : slant glyphs in font by factor (0.0 - 1.5)" ; + report "--extend=s : extend glyphs in font by factor (0.0 - 1.5)" ; + report "--caps=s : capitalize lowercase chars by factor (0.5 - 1.0)" ; + report "--noligs --nofligs : remove ligatures" ; + print "\n" ; + report "--install : copy files from source to font tree" ; + report "--listing : list files on auto sourcepath" ; + report "--remove : remove files on auto sourcepath" ; + report "--makepath : when needed, create the paths" ; + print "\n" ; + report "--test : use test paths for vendor/collection" ; + report "--show : run tex on texfont.tex" ; + print "\n" ; + report "--batch : process given batch file" ; + print "\n" ; + report "--weight : multiple master weight" ; + report "--width : multiple master width" ; + print "\n" ; + report "--expert : also handle expert fonts" ; + print "\n" ; + report "--afmpl : use afm2pl instead of afm2tfm" ; + report "--preproc : pre-process ttf/otf, converting them to pfb" ; + report "--lcdf : use lcdf fonttools to create virtual encoding" ; + exit } + +if (($batch)||(($ARGV[0]) && ($ARGV[0] =~ /.+\.dat$/io))) + { my $batchfile = $ARGV[0] ; + unless (-f $batchfile) + { if ($batchfile !~ /\.dat$/io) { $batchfile .= ".dat" } } + unless (-f $batchfile) + { report ("trying to locate : $batchfile") ; + $batchfile = `kpsewhich -format="other text files" -progname=context $batchfile` ; + chomp $batchfile } + error ("unknown batch file $batchfile") unless -e $batchfile ; + report ("processing batch file : $batchfile") ; + my $select = (($vendor ne "")||($collection ne "")) ; + my $selecting = 0 ; + if (open(BAT, $batchfile)) + { while () + { chomp ; + s/(.+)\#.*/$1/o ; + next if (/^\s*$/io) ; + if ($select) + { if ($selecting) + { if (/^\s*[\#\%]/io) { if (!/\-\-/o) { last } else { next } } } + elsif ((/^\s*[\#\%]/io)&&(/$vendor/i)&&(/$collection/i)) + { $selecting = 1 ; next } + else + { next } } + else + { next if (/^\s*[\#\%]/io) ; + next unless (/\-\-/oi) } + s/\s+/ /gio ; + s/(--en.*\=)\?/$1$encoding/io ; + report ("batch line : $_") ; + # system ("perl $0 --fontroot=$fontroot $_") } + my $own_quote = ( $own_path =~ m/^[^\"].* / ? "\"" : "" ); + my $switches = '' ; + $switches .= "--afmpl " if $afmpl ; + system ("$own_stub$own_quote$own_path$own_name$own_type$own_quote $switches --fontroot=$fontroot $_") } + close (BAT) } + exit } + +error ("unknown vendor $vendor") unless $vendor ; +error ("unknown collection $collection") unless $collection ; +error ("unknown tex root $lcfontroot") unless -d $fontroot ; + +my $varlabel = $variant ; + +if ($lcdf) + { $varlabel =~ s/,/-/goi ; + $varlabel =~ tr/a-z/A-Z/ } + +if ($varlabel ne "") + { $varlabel = "-$varlabel" } + +my $identifier = "$encoding$varlabel-$vendor-$collection" ; + +my $outlinepath = $sourcepath ; my $path = "" ; + +my $shape = "" ; + +if ($noligs||$nofligs) + { report ("ligatures : removed") ; + $fontsuffix .= "-unligatured" ; + $namesuffix .= "-NoLigs" } + +if ($caps ne "") + { if ($caps <0.5) { $caps = 0.5 } + elsif ($caps >1.0) { $caps = 1.0 } + $shape .= " -c $caps " ; + report ("caps factor : $caps") ; + $fontsuffix .= "-capitalized-" . int(1000*$caps) ; + $namesuffix .= "-Caps" } + +if ($extend ne "") + { if ($extend<0.0) { $extend = 0.0 } + elsif ($extend>1.5) { $extend = 1.5 } + report ("extend factor : $extend") ; + if ($lcdf) + { $shape .= " -E $extend " } + else + { $shape .= " -e $extend " } + $fontsuffix .= "-extended-" . int(1000*$extend) ; + $namesuffix .= "-Extended" } + +if ($narrow ne "") # goodie + { $extend = $narrow ; + if ($extend<0.0) { $extend = 0.0 } + elsif ($extend>1.5) { $extend = 1.5 } + report ("narrow factor : $extend") ; + if ($lcdf) + { $shape .= " -E $extend " } + else + { $shape .= " -e $extend " } + $fontsuffix .= "-narrowed-" . int(1000*$extend) ; + $namesuffix .= "-Narrowed" } + +if ($slant ne "") + { if ($slant <0.0) { $slant = 0.0 } + elsif ($slant >1.5) { $slant = 1.5 } + report ("slant factor : $slant") ; + if ($lcdf) + { $shape .= " -S $slant " } + else + { $shape .= " -s $slant " } + $fontsuffix .= "-slanted-" . int(1000*$slant) ; + $namesuffix .= "-Slanted" } + +if ($spaced ne "") + { if ($spaced < 0) { $spaced = 0 } + elsif ($spaced >1000) { $spaced = 1000 } + report ("space factor : $spaced") ; + if ($lcdf) + { $shape .= " -L $spaced " } + else + { $shape .= " -m $spaced " } + $fontsuffix .= "-spaced-" . $spaced ; + $namesuffix .= "-Spaced" } + +if ($sourcepath eq "auto") # todo uppercase root + { foreach my $root (@trees) + { if ($dosish) + { $path = `kpsewhich -expand-path=\$$root` } + else + { $path = `kpsewhich -expand-path=\\\$$root` } + chomp $path ; + $path = $ENV{$root} if (($path eq '') && defined($ENV{$root})) ; + report ("checking root : $root") ; + if ($preproc) + { $sourcepath = "$path/fonts/truetype/$vendor/$collection" } + else + { $sourcepath = "$path/fonts/afm/$vendor/$collection" } + unless (-d $sourcepath) + { my $ven = $vendor ; $ven =~ s/(........).*/$1/ ; + my $col = $collection ; $col =~ s/(........).*/$1/ ; + $sourcepath = "$path/fonts/afm/$ven/$col" ; + if (-d $sourcepath) + { $vendor = $ven ; $collection = $col } } + $outlinepath = "$path/fonts/type1/$vendor/$collection" ; + if (-d $sourcepath) + { # $install = 0 ; # no copy needed + $makepath = 1 ; # make on local if needed + my @files = validglob("$sourcepath/*.afm") ; + if ($preproc) + { @files = validglob("$sourcepath/*.otf") ; + report("locating : otf files") } + unless (@files) + { @files = validglob("$sourcepath/*.ttf") ; + report("locating : ttf files") } + if (@files) + { if ($listing) + { report ("fontpath : $sourcepath" ) ; + print "\n" ; + foreach my $file (@files) + { if (open(AFM,$file)) + { my $name = "unknown name" ; + while () + { chomp ; + if (/^fontname\s+(.*?)$/oi) + { $name = $1 ; last } } + close (AFM) ; + if ($preproc) + { $file =~ s/.*\/(.*)\..tf/$1/io } + else + { $file =~ s/.*\/(.*)\.afm/$1/io } + report ("$file : $name") } } + exit } + elsif ($remove) + { error ("no removal from : $root") if ($root eq 'TEXMFMAIN') ; + foreach my $file (@files) + { if ($preproc) + { $file =~ s/.*\/(.*)\..tf/$1/io } + else + { $file =~ s/.*\/(.*)\.afm/$1/io } + foreach my $sub ("tfm","vf") + { foreach my $typ ("","-raw") + { my $nam = "$path/fonts/$sub/$vendor/$collection/$encoding$varlabel$typ-$file.$sub" ; + if (-s $nam) + { report ("removing : $encoding$varlabel$typ-$file.$sub") ; + unlink $nam } } } } + my $nam = "$encoding$varlabel-$vendor-$collection.tex" ; + if (-e $nam) + { report ("removing : $nam") ; + unlink "$nam" } + my $mapfile = "$encoding$varlabel-$vendor-$collection" ; + foreach my $map ("pdftex","dvips", "dvipdfm") + { my $maproot = "$fontroot/fonts/map/$map/context/"; + if (-e "$maproot$mapfile.map") + { report ("renaming : $mapfile.map -> $mapfile.bak") ; + unlink "$maproot$mapfile.bak" ; + rename "$maproot$mapfile.map", "$maproot$mapfile.bak" } } + exit } + else + { last } } } } + error ("unknown subpath ../fonts/afm/$vendor/$collection") unless -d $sourcepath } + +error ("unknown source path $sourcepath") unless -d $sourcepath ; +error ("unknown option $ARGV[0]") if (($ARGV[0]||'') =~ /\-\-/) ; + +my $afmpath = "$fontroot/fonts/afm/$vendor/$collection" ; +my $tfmpath = "$fontroot/fonts/tfm/$vendor/$collection" ; +my $vfpath = "$fontroot/fonts/vf/$vendor/$collection" ; +my $pfbpath = "$fontroot/fonts/type1/$vendor/$collection" ; +my $ttfpath = "$fontroot/fonts/truetype/$vendor/$collection" ; +my $otfpath = "$fontroot/fonts/opentype/$vendor/$collection" ; +my $encpath = "$fontroot/fonts/enc/dvips/context" ; + +sub mappath + { my $str = shift ; + return "$fontroot/fonts/map/$str/context" } + +# are not on local path ! ! ! ! + +foreach my $path ($afmpath, $pfbpath) + { my @gzipped = <$path/*.gz> ; + foreach my $file (@gzipped) + { print "file = $file\n"; + system ("gzip -d $file") } } + +# For gerben, we only generate a new database when an lsr file is present but for +# myself we force this when texmf-fonts is used (else I get compatibility problems). + +if (($fontroot =~ /texmf\-fonts/o) || (-e "$fontroot/ls-R") || (-e "$fontroot/ls-r") || (-e "$fontroot/LS-R")) { + system ("mktexlsr $fontroot") ; +} + +sub do_make_path + { my $str = shift ; + if ($str =~ /^(.*)\/.*?$/) + { do_make_path($1); } + mkdir $str, 0755 unless -d $str } + +sub make_path + { my $str = shift ; + do_make_path("$fontroot/fonts/$str/$vendor/$collection") } + +if ($makepath&&$install) + { make_path ("afm") ; make_path ("type1") } + +do_make_path(mappath("pdftex")) ; +do_make_path(mappath("dvips")) ; +do_make_path(mappath("dvipdfm")) ; +do_make_path($encpath) ; + +# now fonts/map and fonts/enc + +make_path ("vf") ; +make_path ("tfm") ; + +if ($install) + { error ("unknown afm path $afmpath") unless -d $afmpath ; + error ("unknown pfb path $pfbpath") unless -d $pfbpath } + +error ("unknown tfm path $tfmpath") unless -d $tfmpath ; +error ("unknown vf path $vfpath" ) unless -d $vfpath ; +error ("unknown map path " . mappath("pdftex")) unless -d mappath("pdftex"); +error ("unknown map path " . mappath("dvips")) unless -d mappath("dvips"); +error ("unknown map path " . mappath("dvipdfm")) unless -d mappath("dvipdfm"); + +my $mapfile = "$identifier.map" ; +my $bakfile = "$identifier.bak" ; +my $texfile = "$identifier.tex" ; + + report "encoding vector : $encoding" ; +if ($variant) { report "encoding variant : $variant" } + report "vendor name : $vendor" ; + report " source path : $sourcepath" ; + report "font collection : $collection" ; + report "texmf font root : $lcfontroot" ; + report " map file name : $mapfile" ; + +if ($install) { report "source path : $sourcepath" } + +my $fntlist = "" ; + +my $runpath = $sourcepath ; + +my @files ; + +sub UnLink + { foreach my $f (@_) + { if (unlink $f) + { report "deleted : $f" if $trace } } } + +sub globafmfiles + { my ($runpath, $pattern) = @_ ; + my @files = validglob("$runpath/$pattern.afm") ; + report("locating afm files : using pattern $runpath/$pattern.afm"); + if ($preproc && !$lcdf) + { @files = validglob("$runpath/$pattern.*tf") ; + report("locating otf files : using pattern $runpath/$pattern.*tf"); + unless (@files) + { @files = validglob("$sourcepath/$pattern.ttf") ; + report("locating ttf files : using pattern $sourcepath/$pattern.ttf") } + } + if (@files) # also elsewhere + { report("locating afm files : using pattern $pattern") } + else + { @files = validglob("$runpath/$pattern.ttf") ; + if (@files) + { report("locating afm files : using ttf files") ; + $extension = "ttf" ; + foreach my $file (@files) + { $file =~ s/\.ttf$//io ; + report ("generating afm file : $file.afm") ; + my $command = "ttf2afm \"$file.ttf\" -o \"$file.afm\"" ; + system($command) ; + print "$command\n" if $trace ; + push(@cleanup, "$file.afm") } + @files = validglob("$runpath/$pattern.afm") } + else # try doing the pre-processing earlier + { report("locating afm files : using otf files") ; + $extension = "otf" ; + @files = validglob("$runpath/$pattern.otf") ; + foreach my $file (@files) + { $file =~ s/\.otf$//io ; + if (!$lcdf) + { report ("generating afm file : $file.afm") ; + preprocess_font("$file.otf", "$file.bdf") ; + push(@cleanup,"$file.afm") } + if ($preproc) + { my $command = "cfftot1 --output=$file.pfb $file.otf" ; + print "$command\n" if $trace ; + report("converting : $file.otf to $file.pfb") ; + system($command) ; + push(@cleanup, "$file.pfb") ; + } + } + if ($lcdf) + { @files = validglob("$runpath/$pattern.otf") } + else + { @files = validglob("$runpath/$pattern.afm") } + } + } + return @files } + +if ($pattern eq '') { if ($ARGV[0]) { $pattern = $ARGV[0] } } + +if ($pattern ne '') + { report ("processing files : all in pattern $pattern") ; + @files = globafmfiles($runpath,$pattern) } +elsif ("$extend$narrow$slant$spaced$caps" ne "") + { error ("transformation needs file spec") } +else + { $pattern = "*" ; + report ("processing files : all on afm path") ; + @files = globafmfiles($runpath,$pattern) } + +sub copy_files + { my ($suffix,$sourcepath,$topath) = @_ ; + my @files = validglob("$sourcepath/$pattern.$suffix") ; + return if ($topath eq $sourcepath) ; + report ("copying files : $suffix") ; + foreach my $file (@files) + { my $ok = $file =~ /(.*)\/(.+?)\.(.*)/ ; + my ($path,$name,$suffix) = ($1,$2,$3) ; + UnLink "$topath/$name.$suffix" ; + report ("copying : $name.$suffix") ; + copy ($file,"$topath/$name.$suffix") } } + +if ($install) + { copy_files("afm",$sourcepath,$afmpath) ; +# copy_files("tfm",$sourcepath,$tfmpath) ; # raw supplied names + copy_files("pfb",$outlinepath,$pfbpath) ; + if ($extension eq "ttf") + { make_path("truetype") ; + copy_files("ttf",$sourcepath,$ttfpath) } + if ($extension eq "otf") + { make_path("truetype") ; + copy_files("otf",$sourcepath,$ttfpath) } } + +error ("no afm files found") unless @files ; + +sub open_mapfile + { my $type = shift; + my $mappath = mappath($type); + my $mapdata = ""; + my $mapptr = undef; + my $fullmapfile = $mapfile; + $fullmapfile = "$type-$fullmapfile" unless $type eq "pdftex"; + if ($install) + { copy ("$mappath/$mapfile","$mappath/$bakfile") ; } + if (open ($mapptr,"<$mappath/$mapfile")) + { report ("extending map file : $mappath/$mapfile") ; + while (<$mapptr>) { unless (/^\%/o) { $mapdata .= $_ } } + close ($mapptr) } + else + { report ("no map file at : $mappath/$mapfile") } + #~ unless (open ($mapptr,">$fullmapfile") ) +do_make_path($mappath) ; + unless (open ($mapptr,">$mappath/$fullmapfile") ) + { report "warning : can't open $fullmapfile" } + else + { if ($type eq "pdftex") + { print $mapptr "% This file is generated by the TeXFont Perl script.\n"; + print $mapptr "%\n" ; + print $mapptr "% You need to add the following line to your file:\n" ; + print $mapptr "%\n" ; + print $mapptr "% \\pdfmapfile{+$mapfile}\n" ; + print $mapptr "%\n" ; + print $mapptr "% In ConTeXt you can best use:\n" ; + print $mapptr "%\n" ; + print $mapptr "% \\loadmapfile\[$mapfile\]\n\n" } } + return ($mapptr,$mapdata) ; } + +sub finish_mapfile + { my ($type, $mapptr, $mapdata ) = @_; + my $fullmapfile = $mapfile; + $fullmapfile = "$type-$fullmapfile" unless $type eq "pdftex"; + if (defined $mapptr) + { report ("updating map file : $mapfile (for $type)") ; + while ($mapdata =~ s/\n\n+/\n/mois) {} ; + $mapdata =~ s/^\s*//gmois ; + print $mapptr $mapdata ; + close ($mapptr) ; + if ($install) + { copy ("$fullmapfile", mappath($type) . "/$mapfile") ; } } } + + +my ($PDFTEXMAP,$pdftexmapdata) = open_mapfile("pdftex"); +my ($DVIPSMAP,$dvipsmapdata) = open_mapfile("dvips"); +my ($DVIPDFMMAP,$dvipdfmmapdata) = open_mapfile("dvipdfm"); + +my $tex = 0 ; +my $texdata = "" ; + +if (open (TEX,"<$texfile")) + { while () { unless (/stoptext/o) { $texdata .= $_ } } + close (TEX) } + +$tex = open (TEX,">$texfile") ; + +unless ($tex) { report "warning : can't open $texfile" } + +if ($tex) + { if ($texdata eq "") + { print TEX "% interface=en\n" ; + print TEX "\n" ; + print TEX "\\usemodule[fnt-01]\n" ; + print TEX "\n" ; + print TEX "\\loadmapfile[$mapfile]\n" ; + print TEX "\n" ; + print TEX "\\starttext\n\n" } + else + { print TEX "$texdata" ; + print TEX "\n\%appended section\n\n\\page\n\n" } } + +sub removeligatures + { my $filename = shift ; my $skip = 0 ; + copy ("$filename.vpl","$filename.tmp") ; + if ((open(TMP,"<$filename.tmp"))&&(open(VPL,">$filename.vpl"))) + { report "removing ligatures : $filename" ; + while () + { chomp ; + if ($skip) + { if (/^\s*\)\s*$/o) { $skip = 0 ; print VPL "$_\n" } } + elsif (/\(LIGTABLE/o) + { $skip = 1 ; print VPL "$_\n" } + else + { print VPL "$_\n" } } + close(TMP) ; close(VPL) } + UnLink ("$filename.tmp") } + +my $raw = my $use = my $maplist = my $texlist = my $report = "" ; + +$use = "$encoding$varlabel-" ; $raw = $use . "raw-" ; + +my $encfil = "" ; + +if ($encoding ne "") # evt -progname=context + { $encfil = `kpsewhich -progname=pdftex $encoding$varlabel.enc` ; + chomp $encfil ; if ($encfil eq "") { $encfil = "$encoding$varlabel.enc" } } + +sub build_pdftex_mapline + { my ($option, $usename, $fontname, $rawname, $cleanfont, $encoding, $varlabel, $strange) = @_; + my $cleanname = $fontname; + $cleanname =~ s/\_//gio ; + $option =~ s/^\s+(.*)/$1/o ; + $option =~ s/(.*)\s+$/$1/o ; + $option =~ s/ / /g ; + if ($option ne "") + { $option = "\"$option\" 4" } + else + { $option = "4" } + # adding cleanfont is kind of dangerous + my $thename = ""; + my $str = ""; + my $theencoding = "" ; + if ($strange ne "") + { $thename = $cleanname ; $theencoding = "" ; } + elsif ($lcdf) + { $thename = $usename ; $theencoding = " $encoding$varlabel-$cleanname.enc" } + elsif ($afmpl) + { $thename = $usename ; $theencoding = " $encoding$varlabel.enc" } + elsif ($virtual) + { $thename = $rawname ; $theencoding = " $encoding$varlabel.enc" } + else + { $thename = $usename ; $theencoding = " $encoding$varlabel.enc" } +if ($uselmencodings) { + $theencoding =~ s/^(ec)\.enc/lm\-$1.enc/ ; +} + # quit rest if no type 1 file + my $pfb_sourcepath = $sourcepath ; + $pfb_sourcepath =~ s@/afm/@/type1/@ ; + unless ((-e "$pfbpath/$fontname.$extension")|| + (-e "$pfb_sourcepath/$fontname.$extension")|| + (-e "$sourcepath/$fontname.$extension")|| + (-e "$ttfpath/$fontname.$extension")) + { if ($tex) { $report .= "missing file: \\type \{$fontname.pfb\}\n" } + report ("missing pfb file : $fontname.pfb") } + # now add entry to map + if ($strange eq "") { + if ($extension eq "otf") { + if ($lcdf) { + my $mapline = "" ; + if (open(ALTMAP,"texfont.map")) { + while () { + chomp ; + # atl: we assume this b/c we always force otftotfm --no-type1 + if (/<<(.*)\.otf$/oi) { + $mapline = $_ ; last ; + } + } + close(ALTMAP) ; + } else { + report("no mapfile from otftotfm : texfont.map") ; + } + if ($preproc) { + $mapline =~ s/<\[/) + { if (/^\/([^ ]+)\s*\[/) + { $encname = $1; + last; } } + close ENC; } } + if ($strange ne "") + { $thename = $cleanname ; + $optionencoding = "\"$option\"" if length($option)>1; } + elsif ($lcdf) + { $thename = $usename ; + $optionencoding = "\"$option $encname ReEncodeFont\" <$encoding$varlabel-$cleanname.enc" } + elsif ($afmpl) + { $thename = $usename ; + $optionencoding = "\"$option $encname ReEncodeFont\" <$encoding$varlabel.enc" } + elsif ($virtual) + { $thename = $rawname ; + $optionencoding = "\"$option $encname ReEncodeFont\" <$encoding$varlabel.enc" } + else + { $thename = $usename ; + $optionencoding = "\"$option $encname ReEncodeFont\" <$encoding$varlabel.enc" } +if ($uselmencodings) { + $theencoding =~ s/^(ec)\.enc/lm\-$1.enc/ ; +} + # quit rest if no type 1 file + my $pfb_sourcepath = $sourcepath ; + $pfb_sourcepath =~ s@/afm/@/type1/@ ; + unless ((-e "$pfbpath/$fontname.$extension")|| + (-e "$pfb_sourcepath/$fontname.$extension")|| + (-e "$sourcepath/$fontname.$extension")|| + (-e "$ttfpath/$fontname.$extension")) + { if ($tex) { $report .= "missing file: \\type \{$fontname.pfb\}\n" } + report ("missing pfb file : $fontname.pfb") } + # now add entry to map + if ($strange eq "") { + if ($extension eq "otf") { + if ($lcdf) { + my $mapline = "" ; + if (open(ALTMAP,"texfont.map")) { + while () { + chomp ; + # atl: we assume this b/c we always force otftotfm --no-type1 + if (/<<(.*)\.otf$/oi) { + $mapline = $_ ; last ; + } + } + close(ALTMAP) ; + } else { + report("no mapfile from otftotfm : texfont.map") ; + } + if ($preproc) { + $mapline =~ s/<\[/ $strange -> tfm") } + elsif ($strange ne "") + { report ("font identifier : $cleanfont$namesuffix -> $strange -> skipping") } + elsif ($afmpl) + { report ("font identifier : $cleanfont$namesuffix -> text -> tfm") } + elsif ($virtual) + { report ("font identifier : $cleanfont$namesuffix -> text -> tfm + vf") } + else + { report ("font identifier : $cleanfont$namesuffix -> text -> tfm") } + # don't handle strange fonts + if ($strange eq "") + { # atl: support for lcdf otftotfm + if ($lcdf && $extension eq "otf") + { # no vf, bypass afm, use otftotfm to get encoding and tfm + my $varstr = my $encout = my $tfmout = "" ; + report "processing files : otf -> tfm + enc" ; + if ($encoding ne "") + { $encfil = `kpsewhich -progname=pdftex $encoding.enc` ; + chomp $encfil ; if ($encfil eq "") { $encfil = "$encoding.enc" } + $encstr = " -e $encfil " } + if ($variant ne "") + { ( $varstr = $variant ) =~ s/,/ -f /goi ; + $varstr = " -f $varstr" } + $encout = "$encpath/$use$cleanfont.enc" ; + if (-e $encout) + { report ("renaming : $encout -> $use$cleanfont.bak") ; + UnLink "$encpath/$use$cleanfont.bak" ; + rename $encout, "$encpath/$use$cleanfont.bak" } + UnLink "texfont.map" ; + $tfmout = "$use$cleanfont$fontsuffix" ; + my $otfcommand = "otftotfm -a $varstr $encstr $passon $shape --name=\"$tfmout\" --encoding-dir=\"$encpath/\" --tfm-dir=\"$tfmpath/\" --vf-dir=\"$vfpath/\" --no-type1 --map-file=./texfont.map \"$file\"" ; + print "$otfcommand\n" if $trace ; + system("$otfcommand") ; + $encfil = $encout } + else + { # generate tfm and vpl, $file is on afm path + my $font = '' ; + if ($afmpl) + { report " generating pl : $cleanname$fontsuffix (from $cleanname)" ; + $encstr = " -p $encfil" ; + if ($uselmencodings) { + $encstr =~ s/(ec)\.enc$/lm\-$1\.enc/ ; + } + my $command = "afm2pl -f afm2tfm $shape $passon $encstr $file $cleanname$fontsuffix.vpl" ; + print "$command\n" if $trace ; + my $ok = `$command` ; + if (open (TMP,"$cleanname$fontsuffix.map")) + { $font = ; + close(TMP) ; + UnLink "$cleanname$fontsuffix.map" } } + else + { report "generating raw tfm/vpl : $raw$cleanname$fontsuffix (from $cleanname)" ; + my $command = "afm2tfm $file $shape $passon $encstr $vfstr $raw$cleanname$fontsuffix" ; + print "$command\n" if $trace ; + $font = `$command` } + # generate vf file if needed + chomp $font ; + if ($font =~ /.*?([\d\.]+)\s*ExtendFont/io) { $extend = $1 } + if ($font =~ /.*?([\d\.]+)\s*SlantFont/io) { $slant = $1 } + if ($extend ne "") { $option .= " $extend ExtendFont " } + if ($slant ne "") { $option .= " $slant SlantFont " } + if ($afmpl) + { if ($noligs||$nofligs) { removeligatures("$cleanname$fontsuffix") } + report "generating new tfm : $use$cleanname$fontsuffix" ; + my $command = "pltotf $cleanname$fontsuffix.vpl $use$cleanname$fontsuffix.tfm" ; + print "$command\n" if $trace ; + my $ok = `$command` } + elsif ($virtual) + { if ($noligs||$nofligs) { removeligatures("$use$cleanname$fontsuffix") } + report "generating new vf : $use$cleanname$fontsuffix (from $use$cleanname)" ; + my $command = "vptovf $use$cleanname$fontsuffix.vpl $use$cleanname$fontsuffix.vf $use$cleanname$fontsuffix.tfm" ; + print "$command\n" if $trace ; + my $ok = `$command` } + else + { if ($noligs||$nofligs) { removeligatures("$raw$cleanname$fontsuffix") } + report "generating new tfm : $use$cleanname$fontsuffix (from $raw$cleanname)" ; + my $command = "pltotf $raw$cleanname$fontsuffix.vpl $use$cleanname$fontsuffix.tfm" ; + print "$command\n" if $trace ; + my $ok = `$command` } } } + elsif (-e "$sourcepath/$cleanname.tfm" ) + { report "using existing tfm : $cleanname.tfm" } + elsif (($strange eq "expert")&&($expert)) + { report "creating tfm file : $cleanname.tfm" ; + my $command = "afm2tfm $file $cleanname.tfm" ; + print "$command\n" if $trace ; + my $font = `$command` } + else + { report "use supplied tfm : $cleanname" } + # report results + if (!$lcdf) + { ($rawfont,$cleanfont,$restfont) = split(/\s/,$font) } + $cleanfont =~ s/\_/\-/goi ; + $cleanfont =~ s/\-+$//goi ; + # copy files + my $usename = "$use$cleanname$fontsuffix" ; + my $rawname = "$raw$cleanname$fontsuffix" ; + + if ($lcdf eq "") + { if ($strange ne "") + { UnLink ("$vfpath/$cleanname.vf", "$tfmpath/$cleanname.tfm") ; + copy ("$cleanname.tfm","$tfmpath/$cleanname.tfm") ; + copy ("$usename.tfm","$tfmpath/$usename.tfm") ; + # or when available, use vendor one : + copy ("$sourcepath/$cleanname.tfm","$tfmpath/$cleanname.tfm") } + elsif ($virtual) + { UnLink ("$vfpath/$rawname.vf", "$vfpath/$usename.vf") ; + UnLink ("$tfmpath/$rawname.tfm", "$tfmpath/$usename.tfm") ; + copy ("$usename.vf" ,"$vfpath/$usename.vf") ; + copy ("$rawname.tfm","$tfmpath/$rawname.tfm") ; + copy ("$usename.tfm","$tfmpath/$usename.tfm") } + elsif ($afmpl) + { UnLink ("$vfpath/$rawname.vf", "$vfpath/$usename.vf", "$vfpath/$cleanname.vf") ; + UnLink ("$tfmpath/$rawname.tfm", "$tfmpath/$usename.tfm", "$tfmpath/$cleanname.tfm") ; + copy ("$usename.tfm","$tfmpath/$usename.tfm") } + else + { UnLink ("$vfpath/$usename.vf", "$tfmpath/$usename.tfm") ; + # slow but prevents conflicting vf's + my $rubish = `kpsewhich $usename.vf` ; chomp $rubish ; + if ($rubish ne "") { UnLink $rubish } + # + copy ("$usename.tfm","$tfmpath/$usename.tfm") } } + # cleanup + foreach my $suf ("tfm", "vf", "vpl") + { UnLink ("$rawname.$suf", "$usename.$suf") ; + UnLink ("$cleanname.$suf", "$fontname.$suf") ; + UnLink ("$cleanname$fontsuffix.$suf", "$fontname$fontsuffix.$suf") } + # add line to map files + my $str = my $thename = ""; + ($str, $thename) = build_pdftex_mapline($option, $usename, $fontname, $rawname, $cleanfont, $encoding, $varlabel, $strange); + # check for redundant entries + if (defined $PDFTEXMAP) { + $pdftexmapdata =~ s/^$thename\s.*?$//gmis ; + if ($afmpl) { + if ($pdftexmapdata =~ s/^$rawname\s.*?$//gmis) { + report ("removing raw file : $rawname") ; + } + } + $maplist .= $str ; + $pdftexmapdata .= $str ; + } + ($str, $thename) = build_dvips_mapline($option, $usename, $fontname, $rawname, $cleanfont, $encoding, $varlabel, $strange); + # check for redundant entries + if (defined $DVIPSMAP) { + $dvipsmapdata =~ s/^$thename\s.*?$//gmis ; + if ($afmpl) { + if ($dvipsmapdata =~ s/^$rawname\s.*?$//gmis) { + report ("removing raw file : $rawname") ; + } + } + $dvipsmapdata .= $str ; + } + ($str, $thename) = build_dvipdfm_mapline($option, $usename, $fontname, $rawname, $cleanfont, $encoding, $varlabel, $strange); + # check for redundant entries + if (defined $DVIPDFMMAP) { + $dvipdfmmapdata =~ s/^$thename\s.*?$//gmis ; + if ($afmpl) { + if ($dvipdfmmapdata =~ s/^$rawname\s.*?$//gmis) { + report ("removing raw file : $rawname") ; + } + } + $dvipdfmmapdata .= $str ; + } + + # write lines to tex file + if (($strange eq "expert")&&($expert)) { + $fntlist .= "\\definefontsynonym[$cleanfont$namesuffix][$cleanname] \% expert\n" ; + } elsif ($strange ne "") { + $fntlist .= "\%definefontsynonym[$cleanfont$namesuffix][$cleanname]\n" ; + } else { + $fntlist .= "\\definefontsynonym[$cleanfont$namesuffix][$usename][encoding=$encoding]\n" ; + } + next unless $tex ; + if (($strange eq "expert")&&($expert)) { + $texlist .= "\\ShowFont[$cleanfont$namesuffix][$cleanname]\n" ; + } elsif ($strange ne "") { + $texlist .= "\%ShowFont[$cleanfont$namesuffix][$cleanname]\n" ; + } else { + $texlist .= "\\ShowFont[$cleanfont$namesuffix][$usename][$encoding]\n" + } +} + +finish_mapfile("pdftex", $PDFTEXMAP, $pdftexmapdata); +finish_mapfile("dvipdfm", $DVIPDFMMAP, $dvipdfmmapdata); +finish_mapfile("dvips", $DVIPSMAP, $dvipsmapdata); + +if ($tex) + { my $mappath = mappath("pdftex"); + $mappath =~ s/\\/\//go ; + $savedoptions =~ s/^\s+//gmois ; $savedoptions =~ s/\s+$//gmois ; + $fntlist =~ s/^\s+//gmois ; $fntlist =~ s/\s+$//gmois ; + $maplist =~ s/^\s+//gmois ; $maplist =~ s/\s+$//gmois ; + print TEX "$texlist" ; + print TEX "\n" ; + print TEX "\\setupheadertexts[\\tttf example definitions]\n" ; + print TEX "\n" ; + print TEX "\\starttyping\n" ; + print TEX "texfont $savedoptions\n" ; + print TEX "\\stoptyping\n" ; + print TEX "\n" ; + print TEX "\\starttyping\n" ; + print TEX "$mappath/$mapfile\n" ; + print TEX "\\stoptyping\n" ; + print TEX "\n" ; + print TEX "\\starttyping\n" ; + print TEX "$fntlist\n" ; + print TEX "\\stoptyping\n" ; + print TEX "\n" ; + print TEX "\\page\n" ; + print TEX "\n" ; + print TEX "\\setupheadertexts[\\tttf $mapfile]\n" ; + print TEX "\n" ; + print TEX "\\starttyping\n" ; + print TEX "$maplist\n" ; + print TEX "\\stoptyping\n" ; + print TEX "\n" ; + print TEX "\\stoptext\n" } + +if ($tex) { close (TEX) } + +# atl: global cleanup with generated files (afm & ttf don't mix) + +UnLink(@cleanup) ; + +print "\n" ; report ("generating : ls-r databases") ; + +# Refresh database. + +print "\n" ; system ("mktexlsr $fontroot") ; print "\n" ; + +# Process the test file. + +if ($show) { system ("texexec --once --silent $texfile") } + +@files = validglob("$identifier.* *-$identifier.map") ; + +foreach my $file (@files) + { unless ($file =~ /(tex|pdf|log|mp|tmp)$/io) { UnLink ($file) } } + +exit ; -- cgit v1.2.3