opt/psftopst

   1 eval '(exit $?0)' && eval 'exec perl -S $0 ${1+"$@"}' && eval 'exec perl -S $0 $argv:q'
   2   if 0;
   3 use strict;
   4 # ==============================================================================
   5 # psftopst
   6 # Version 1.0 (Mercredi 19 octobre 2011)                      Jean-Michel Sarlat
   7 # Ce script fait partie du projet pst-anamorphosis         (Gilg, Luque, Sarlat)
   8 # http://melusine.eu.org/syracuse/G/pst-anamorphosis                    Checkout
   9 # http://melusine.eu.org/syracuse/G/git/?p=pst-anamorphosis.git              git
  10 # ==============================================================================
  11
  12 our $windows_pstoedit = 'chemin vers pstoedit.exe';
  13
  14 our $on_windows = $^O =~ /^MSWin/;
  15 our $GS = $on_windows ? "gswin32c" : "gs";
  16 our $PS = $on_windows ? $windows_pstoedit : "pstoedit";
  17
  18
  19 # ===  Acquisition des options de la ligne de commande -------------------------
  20 $::opt_dimmax        =  4;                # Dimension maximale : 4 cm par défaut
  21 $::opt_ps            =  0;                # Transformation initiale par pstoedit
  22 use Getopt::Long;
  23 GetOptions(
  24     "dimmax=s",
  25     "ps"
  26 );
  27
  28 our $debug  = 1;
  29
  30 our $GSBBOX = "$GS -sDEVICE=bbox -dBATCH -dNOPAUSE -dNOSAFER -P -c save pop -f";
  31
  32 our $cm = 28.3464567;
  33
  34 our $Fichier = $ARGV[0];
  35 -f $Fichier or die "Fichier <$Fichier> introuvable !\n";
  36
  37 our ($Nom, $Dir, $Ext) = &FichierNRE($Fichier);
  38
  39 # === Transformation éventuelle par pstoedit -----------------------------------
  40 if ($::opt_ps) {
  41   use File::Copy;
  42   my $f = "$Nom-original.$Ext";
  43   copy($Fichier, $f);
  44   my @a = ($PS, "-f", "ps", $f, $Fichier);
  45   $debug and print STDERR "Processing by pstoedit...\n";
  46   system(@a) == 0 or die "Running pstoedit failed\nCommand :".join(" ",@a)."\n";
  47   $debug and print STDERR "Ok!\n";
  48 }
  49 # ==============================================================================
  50
  51 our $ps                = &FichierListe($Fichier);
  52 our $table             = [];
  53 our @Bbox              = ();
  54
  55 our $cmyk              = {};
  56 our $centrex           = 0;
  57 our $centrey           = 0;
  58
  59 our $facteur           = 1;
  60 our $DimMax            = $::opt_dimmax;
  61
  62 our $PageSizeX         = 0;
  63 our $PageSizeY         = 0;
  64
  65 our @currentpoint      = ();
  66 our @lastpoint         = ();
  67 our $dmax              = 0;
  68
  69 # ==============================================================================
  70 # === Analyse
  71 # ==============================================================================
  72 $$table[0] = {
  73   fichier  => $Fichier,
  74   source   => &FichierScalaire($Fichier),
  75   createur => "psftopst"
  76 };
  77 &LecturePostScript($table, $ps);
  78 $$table[0]->{bbox} = \@Bbox;
  79 # ==============================================================================
  80 # === Production
  81 # ==============================================================================
  82 our $pst               = &EcritureFichierPST($table, $Nom);
  83 open PST, ">$Nom.pst" and print PST $pst and close PST;
  84 # ==============================================================================
  85
  86 sub EcritureFichierPST {
  87   my ($r, $n) = @_;
  88   my $c       = $$r[0]->{cmyk};
  89   my $nc      = 1;
  90   my $out     = "%\@PATRON:pstricks\n";
  91   $out       .= "\\makeatletter\n\\def\\psfs\@asolid{\\pst\@fill{\\pst\@usecolor\\psfillcolor eofill}}\n\\makeatother\n";
  92   # Définition des couleurs dans le fichier pstricks
  93   # Elles sont reprises dans la table représentant le fichier ps
  94   $out .= "%\@COULEURS:\n";
  95   foreach (@$c) {
  96     my $roman = &Roman($nc);
  97     $$cmyk{$_} = "Couleur$roman";
  98     s/\s/\,/g;
  99     $out .= "\\definecolor{Couleur$roman}{cmyk}{$_}\n";
 100     $nc++;
 101   }
 102   # Acquisition du centre de l'image
 103   my $b = $$r[0]->{bbox};
 104   $out    .= "%\@BOUNDINGBOX: " . join(" ", @$b) . "\n";
 105   $centrex = ($$b[2] + $$b[0]) / 2;
 106   $centrey = ($$b[3] + $$b[1]) / 2;
 107   $out    .= "%\@TRANSLATION: -($centrex,$centrey)\n";
 108   my $l    = ($$b[2] - $$b[0]);
 109   my $h    = ($$b[3] - $$b[1]);
 110   my $max  = $l; $max = $h if $h > $l;
 111   $facteur = $DimMax / $max;
 112   $out    .= "%\@FACTEUR: $facteur\n";
 113   my $abox = &xy_couple_modifie($b);
 114   $out    .= "%\@PSPICTURE:\n";
 115   $out    .= "% \\begin{pspicture}$abox\n";
 116   if ($PageSizeX) {
 117     my $clipframe = &xy_couple_modifie([0, 0, $PageSizeX, $PageSizeY]);
 118     $out  .= "%\@CLIPPING: $PageSizeX $PageSizeY\n";
 119     $out  .= "% \\begin{psclip}{\\psframe[linestyle=none]$clipframe}\n";
 120   }
 121   $out    .= "%\@PICTURE:\n";
 122   # Éléments de construction
 123   for (my $i = 1; $i < scalar @$r; $i++) {
 124     if ($$r[$i]->{path}) {
 125       $out .= "%% Path : $i\n";
 126       my $couleur   = $$cmyk{$$r[$i]->{setcmykcolor}};
 127       my $epaisseur = $$r[$i]->{setlinewidth}; $epaisseur = sprintf("linewidth=%0.5fpt", $epaisseur * $facteur * $cm);
 128       my $t         = $$r[$i]->{type};
 129       $t eq "fill"   and $out .= "\\pscustom[fillstyle=solid,fillcolor=$couleur,linestyle=none]{\n";
 130       $t eq "eofill" and $out .= "\\pscustom[fillstyle=asolid,fillcolor=$couleur,linestyle=none]{\n";
 131       $t eq "clip"   and $out .= "\\psclip{\\psframe[fillstyle=none,linestyle=none]$abox}\%\n\\pscustom{\n";
 132       $t eq "stroke" and $out .= "\\pscustom[$epaisseur,linecolor=$couleur]{\n";
 133       my $p = $$r[$i]->{path};
 134       my $n = $$r[$i]->{closepath};
 135       foreach (@$p) {
 136         my %e = %$_;
 137         $e{t} eq "moveto"    and $out .= "\\moveto".&xy_couple_modifie($e{p});
 138         $e{t} eq "lineto"    and $out .= "\\psline".&xy_couple_modifie($e{p});
 139         $e{t} eq "curveto"   and $out .= "\\psbezier".&xy_couple_modifie($e{p});
 140         $e{t} eq "closepath" and $out .= "\\closepath";
 141         $out .= "\n";
 142         @lastpoint = @currentpoint;
 143       }
 144       $out .= "}\n";
 145       $$r[$i]->{type} eq "clip" and $out .= "\\endpsclip\n";
 146     }
 147   }
 148   $out .= "%\@---\n";
 149   $out .= "% \\end{psclip}\n" if $PageSizeX;
 150   $out .= "% \\end{pspicture}\n";
 151 }
 152
 153
 154 sub LecturePostScript {
 155   my ($t, $p) = @_;
 156   my $pathnumber = 0;
 157   my $natpath    = "";
 158   my $path       = [];
 159   my $fpath      = 0;
 160   my $niveau     = 0;
 161   my $nclosepath = 0;   # Nombre de closepath rencontrés
 162   foreach (@$p) {
 163     /^\%\s*(\d+)\s+pathnumber/ and $pathnumber = $1 and $$t[$pathnumber] = {};
 164     /^\s*gsave/    and $niveau++;
 165     /^\s*grestore/ and $niveau--;
 166     s/setPageSize\s*$// and &setPageSize($_);
 167     /^\%\%BoundingBox\: ([\d\.-]+) ([\d\.-]+) ([\d\.-]+) ([\d\.-]+)/ and &setBbox($1,$2,$3,$4);
 168     if ($pathnumber) {
 169       /^\%\s*filledpath/   and $natpath = "filledpath" and next;
 170       /^\%\s*eofilledpath/ and $natpath = "eofilledpath" and next;
 171       /^\%\s*strokedpath/  and $natpath = "strokedpath" and next;
 172       /^\%\s*clippath/     and $natpath = "clippath" and next;
 173       /setlinewidth$/      and $$t[$pathnumber]->{setlinewidth} = &setlinewidth($_) and next;
 174       /setcmykcolor$/      and $$t[$pathnumber]->{setcmykcolor} = &setcmykcolor($_) and next;
 175       /^newpath/ and $fpath = 1 and $path = [] and next;
 176       if ($fpath) {
 177         s/moveto\s*$//  and push(@$path, {t => "moveto", p  => &xy($_)});
 178         s/lineto\s*$//  and push(@$path, {t => "lineto", p  => &xy($_)});
 179         s/curveto\s*$// and push(@$path, {t => "curveto", p => &xy($_)});
 180         /closepath/     and push(@$path, {t => "closepath", p => 1}) and $nclosepath++;
 181         if (/(stroke)/ or /(eofill)/ or /(fill)/ or /(clip)/) {
 182           $fpath = 0;
 183           $$t[$pathnumber]->{path}      = $path;
 184           $$t[$pathnumber]->{type}      = $1;
 185           $$t[$pathnumber]->{niveau}    = $niveau;
 186           $$t[$pathnumber]->{closepath} = $nclosepath;
 187           $pathnumber = 0;
 188           $nclosepath = 0;
 189         }
 190       }
 191     }
 192   }
 193   $$t[0]->{cmyk} = [];
 194   foreach (keys %$cmyk) {
 195     push @{$$t[0]->{cmyk}}, $_;
 196   }
 197 }
 198
 199 sub setPageSize {
 200   my $s = shift;
 201   $s =~ s/^\s*|\s*$//g;
 202   ($PageSizeX, $PageSizeY) = split /\s+/, $s;
 203 }
 204
 205 sub setlinewidth {
 206   my $s = shift;
 207   $s =~ s/^\s*|\s+setlinewidth$//g;
 208   return $s;
 209 }
 210
 211 sub setcmykcolor {
 212   my $s = shift;
 213   $s =~ s/^\s*|\s+setcmykcolor$//g;
 214   $$cmyk{$s} = 1;
 215   return $s;
 216 }
 217
 218 sub xy {
 219   my $s = shift;
 220   $s =~ s/^\s*|\s*$//g;
 221   my @xy = split /\s+/, $s;
 222   return \@xy;
 223 }
 224
 225 sub xy_couple_modifie {
 226   my $xy = shift;
 227   my @l  = @$xy; @currentpoint = ($l[-2],$l[-1]);
 228   my $s  = "";
 229   while (my ($x, $y) = splice(@l, 0, 2)) {
 230     $s .= sprintf("(%0.8f,%0.8f)", ($x - $centrex) * $facteur, ($y - $centrey) * $facteur);
 231   }
 232   return $s;
 233 }
 234
 235 # === Contenu d'un fichier et éléments du nom ----------------------------------
 236 # ------------------------------------------------------------------------------
 237 # Contenu sous forme d'une liste de lignes
 238 sub FichierListe {
 239   my $f = shift;
 240   open(FICH, $f) or die "Le fichier $f est introuvable !\n";
 241   my @l = <FICH>;
 242   close FICH;
 243   chomp @l;
 244   return \@l;
 245 }
 246 # Contenu en un seul élément
 247 sub FichierScalaire {
 248   my $f = shift;
 249   local $/;
 250   open(FICH, $f) or die "Le fichier $f est introuvable !\n";
 251   my $c = <FICH>;
 252   close FICH;
 253   return $c;
 254 }
 255 # Nom, Repertoire et Extension d'un fichier
 256 sub FichierNRE {
 257   my $f = shift;
 258   use File::Basename;
 259   my ($n, $r, $e) = fileparse($f,qw{\..*});
 260   $e =~ s/^\.//;
 261   return ($n, $r, $e);
 262 }
 263 # === Acquisition de la BoundingBox --------------------------------------------
 264 sub setBbox {
 265   @Bbox = @_;
 266 }
 267
 268 # === Écriture d'un nombre en chiffres romains ---------------------------------
 269 # Code emprunté au module Roman.pm ; http://search.cpan.org/dist/Roman
 270 # AUTEURS:
 271 #   OZAWA Sakuro <ozawa at aisoft.co.jp> 1995-1997
 272 #   Alexandr Ciornii, C<< <alexchorny at gmail.com> >> 2007
 273 # ------------------------------------------------------------------------------
 274 sub Roman {
 275   my $arg = shift;
 276   0 < $arg and $arg < 4000 or return undef;
 277   my %roman_digit = qw(1 IV 10 XL 100 CD 1000 MMMMMM);
 278   my @figure = reverse sort keys %roman_digit;
 279   $roman_digit{$_} = [split(//, $roman_digit{$_}, 2)] foreach @figure;
 280   my($x, $roman);
 281   foreach (@figure) {
 282     my($digit, $i, $v) = (int($arg / $_), @{$roman_digit{$_}});
 283     if (1 <= $digit and $digit <= 3) {
 284       $roman .= $i x $digit;
 285     } elsif ($digit == 4) {
 286       $roman .= "$i$v";
 287     } elsif ($digit == 5) {
 288       $roman .= $v;
 289     } elsif (6 <= $digit and $digit <= 8) {
 290       $roman .= $v . $i x ($digit - 5);
 291     } elsif ($digit == 9) {
 292       $roman .= "$i$x";
 293     }
 294     $arg -= $digit * $_;
 295     $x = $i;
 296   }
 297   return $roman;
 298 }
 299 # === Wanda --------------------------------------------------------------------
 300 sub WandaExecutePlugin {
 301   my ($cnf, $elm, $args) = @_;
 302 }
 303 sub WandaAnalyseLignes {
 304   my $cnf = shift;
 305   my $l = shift;
 306   my $c = {};
 307   my $e = "CORPS";
 308   my @p = ();
 309   # Traitement
 310   for(my $i=0; $i < scalar @$l; $i++) {
 311     if ($$l[$i] =~ /^%@([\da-zA-Z_]+)\s*:\s*(.+?)\s*$/) {
 312       # Affectation simple : la valeur suit le nom dans la ligne -----
 313       $$c{$1} = $2;
 314     } elsif ($$l[$i] =~ /^%@([\da-zA-Z_]+)\s*:\s*$/) {
 315       # Affectation bloc : la valeur est constituée du bloc à suivre -
 316       push @p, $e; $e = $1;
 317     } elsif ($$l[$i] =~ /^%@\-\-\-/) {
 318       # On ferme l'élément en cours... -------------------------------
 319       $e = pop @p;
 320     } elsif ($$l[$i] =~ /^%@\@lib:\s*(.+?)\s+$/) {
 321       # On ajoute le contenu d'un fichier de la librairie ------------
 322       if (-f "$$cnf{DIR}/lib/$1") {
 323         $$c{$e} .= qx{cat "$$cnf{DIR}/lib/$1"} if $e;
 324       }
 325     } elsif ($$l[$i] =~ /^%@\@inc:\s*(.+?)\s+$/) {
 326       # On ajoute le contenu d'un fichier local ----------------------
 327       if (-f $1) {
 328         $$c{$e} .= qx{cat $1} if $e;
 329       }
 330     } elsif ($$l[$i] =~ /^%@\@exec:\s*(.+?)\s+$/) {
 331       # On éxécute un plugin -----------------------------------------
 332       $$c{$e} .= &WandaExecutePlugin($cnf, $c, $1);
 333     } else {
 334       # La ligne est enregistrée dans l'éventuel élément en cours ----
 335       $$c{$e} .= $$l[$i] if $e;
 336     }
 337   }
 338   return $c;
 339 }
 340 sub WandaAnalyseContenu {
 341   my ($cnf, $fichier) = @_;
 342   open(SRC, $fichier); my @LIGNES = <SRC>; close(SRC);
 343   return &WandaAnalyseLignes($cnf, \@LIGNES);
 344 }
 345
 346
 347