Création du dossier <Scripts d'appoint> avec psftopst dedans...
[pst-anamorphosis.git] / opt / pstopst
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 # psftopdf
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_t             =  0;                # Transformation initiale par pstoedit
22 use Getopt::Long;
23 GetOptions(
24     "dimmax=s",
25     "t"
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_t) {
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 * $cm) / $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);
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

Licence Creative Commons Les fichiers de Syracuse sont mis à disposition (sauf mention contraire) selon les termes de la
Licence Creative Commons Attribution - Pas d’Utilisation Commerciale - Partage dans les Mêmes Conditions 4.0 International.