dnrops
/
gimp
mirror of https://github.com/GNOME/gimp.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity
gimp/plug-ins/perl/scm2perl

451 lines
10 KiB
Perl
Executable File
Raw Blame History

#!/usr/bin/perl
#require 5.005;
# Copyright Marc Lehmann <pcg@goof.com>
#
# This is part of the Gimp-Perl extension, and shares its copright with it.
# TODO
# more syntax ;) more functions ;) more exprns ;) more constants ;)
# ui/args
# too many parens
# comments(!)
# This is distributed under the GPL (see COPYING.GNU for details).
=cut
=head1 NAME
scm2perl - convert script-fu to perl
=head1 SYNOPSIS
scm2perl filename.scm...
=head1 DESCRIPTION
This program tries to convert Script-Fu (Scheme) scripts written for The
Gimp into a Perl script.
Don't expect too much from this version. To run it, you need
the Parse::RecDescent module from CPAN.
=head1 CONVERSION TIPS
=head2 PDB functions returning arrays
Perl knows the length of arrays, Script-Fu doesn't. Functions returning
single arrays return them as a normal perl array, Functions returning
more then one array return it as an array-ref. Script-Fu (and the
converted script) expect to get a length argument and then the
arguments. Each occurrence (common ones are C<gimp_list_images> or
C<gimp_image_get_layers>) must be fixed by hand.
=head1 AUTHOR
Marc Lehmann <pcg@goof.com>
=head1 SEE ALSO
gimp(1), L<Gimp>.
=cut
$|=1;
use Parse::RecDescent;
$RD_HINT=1;
#$RD_TRACE=1;
unless(@ARGV) {
print STDERR "Script-Fu to Perl Translator 1.0\n";
print STDERR "Usage: $0 file.scm ...\n";
exit(1);
}
print STDERR "creating parser..." unless $quiet;
$parser = new Parse::RecDescent <<'EOA';
{
# use re 'eval';
$Parse::RecDescent::tokensep = '(?:\s*(?:(;[^\n]*\n))?)*';
my $indent = 0;
my %sf2pf = (
'SF-IMAGE' => 'PF_IMAGE, ',
'SF-LAYER' => 'PF_LAYER, ',
'SF-CHANNEL' => 'PF_CHANNEL, ',
'SF-VALUE' => 'PF_VALUE, ',
'SF-TOGGLE' => 'PF_TOGGLE, ',
'SF-DRAWABLE' => 'PF_DRAWABLE, ',
'SF-STRING' => 'PF_STRING, ',
'SF-COLOR' => 'PF_COLOUR, ',
'SF-ADJUSTMENT' => 'PF_ADJUSTMENT,',
'SF-FONT' => 'PF_FONT, ',
'SF-PATTERN' => 'PF_PATTERN, ',
'SF-GRADIENT' => 'PF_GRADIENT, ',
'SF-FILENAME' => 'PF_FILE, ',
);
my %constant = qw(
TRUE 1
FALSE 0
#t 1
#f 0
RGB RGB_IMAGE
RGBA RGBA_IMAGE
LINEAR LINEAR_INTERPOLATION
NORMAL NORMAL_MODE
ADDITION ADDITION_MODE
MULTIPLY MULTIPLY_MODE
DIFFERENCE DIFFERENCE_MODE
DARKEN_ONLY DARKEN_ONLY_MODE
LIGHTEN_ONLY LIGHTEN_ONLY_MODE
BEHIND BEHIND_MODE
COLOR COLOR_MODE
DISSOLVE DISSOLVE_MODE
HUE HUE_MODE
OVERLAY OVERLAY_MODE
SATURATION SATURATION_MODE
SCREEN SCREEN_MODE
SUBTRACT SUBTRACT_MODE
VALUE VALUE_MODE
ALPHA_MASK ADD_ALPHA_MASK
BLACK_MASK ADD_BLACK_MASK
WHITE_MASK ADD_WHITE_MASK
*pi* 3.14159265
);
my $constants = join("|",map {quotemeta} sort {length($b) <=> length($a)} keys %constant);
my %compat_fun = (
cdr => 'sub cdr {
my(@x)=@{$_[0]};
shift(@x);
@x >1 ? [@x] : $x[0];
}',
cddr => 'sub cddr {
my(@x)=@{$_[0]};
shift(@x); shift(@x);
@x >1 ? [@x] : $x[0];
}',
max => 'sub max {
$_[0] > $_[1] ? $_[0] : $_[1];
}',
min => 'sub min {
$_[0] < $_[1] ? $_[0] : $_[1];
}',
fmod => 'sub fmod {
$_[0] - int($_[0]/$_[1])*$_[0];
}',
'number->string' => 'sub number2string {
sprintf "%$_[1]d",$_[0];
}',
nth => 'sub nth {
$_[1]->[$_[0]];
}',
);
my $xskip;
my $compat_fun = join("|",map {quotemeta} sort {length($b) <=> length($a)} keys %compat_fun);
sub func2perl {
my($name)=@_;
$name=~s/->/2/g;
$name=~y/-*<>?!:\//_/;
$name=~/^[A-Za-z_]/ ? $name : "_$name";
}
sub sf2pf {
my $name=lc $_[0];
$name=~y/ -?!:<>\[]/__/d;
$name=~s/_*[()].*$/"/;
$name=~s/_\d*_/_/g;
$name=~s/_+$//;
sprintf "%-20s","'$name',";
}
}
script : ( ...!/$/ stmt)(s) nl /$/
| <error:unable to recognize next statement>
stmts : ( ...!')' nl stmt)(s?)
stmt : '(' command ')'
| expr gen[";"]
command : cp_expr gen[";"]
| c_let
| c_set
| c_if
| c_while
| e_cond gen[";"]
| c_aset
| c_defun
| c_define
| c_reg
| /print\b/ gen["print "] expr gen[",'\n';"]
| e_call gen[";"]
| atom gen[";"]
| <error:unrecognized statement>
expr : '(' e_if ')'
| '(' gen["("] e_cond gen[")"] ')'
| '(' cp_expr ')'
| '(' ...!pdbfun e_call ')'
| '(' ...pdbfun gen["["] e_call gen["]"] ')'
| '(' gen["do {"] incindent nl command decindent nl gen["}"] ')'
| atom
| ...!')' <error:unrecognized expression>
cp_expr : /car\b/ '(' ...pdbfun e_call ')'
| e_begin
| e_list
| '=' expr 'TRUE'
| '=' 'TRUE' expr
| '=' gen["!"] expr 'FALSE'
| '=' gen["!"] 'FALSE' expr
| '-' gen["-("] expr ...')' gen[")"]
| m{[-+]|and\b} gen["("] e_binop[$item[1]] gen[")"]
| m{<=|>=|!=|[*/<>]|or\b} e_binop[$item[1]]
| '=' e_binop["=="]
| /eq\?|eqv\?|equal\?/ '()' expr gen[" eq ''"] #X#
| /eq\?|eqv\?|equal\?/ e_binop["eq"]
| /realtime\b/ gen["time"]
| /modulo\b/ expr gen[" % "] expr
| 'divide?' gen["!"] expr gen["%"] expr
| 'string-append' expr (...!')' gen["."] expr)(s?)
| 'number->string' expr ...')'
| 'cons-array' gen["("] expr (gen[","] expr)(?) gen[",[])"]
| 'symbol-bound?' string '(' ident ')' gen["0"]
| /aref\b/ expr gen["->["] expr gen["]"]
| /$compat_fun/ { $::add_funcs{$compat_fun{$item[1]}}++ } <reject>
| /car\b/ gen["\@{"] expr gen["}[0]"]
| /cadr\b/ gen["\@{"] expr gen["}[1]"]
| /caddr\b/ gen["\@{"] expr gen["}[2]"]
| 'null?' gen["!\@{"] expr gen["}"]
| /cons\b/ gen["["] expr gen[", "] expr gen["]"]
| ...')' gen["[]"]
| '(' cp_expr ')'
| constant
pdbfun : /gimp-|plug-in-|script-fu-|file-|extension-/
atom : constant
| 'gimp-data-dir' gen["'/usr/local/share/gimp'"]
| ident gen["\$$item[-1]"]
| numeral
| string gen[$item[-1]]
| list
| "'not-guile" gen["1"]
e_dot : 'string-append' expr gen["."] expr
c_defun : 'define' '(' <commit> ident
nl gen["sub $item[-2] {"] incindent
nl (...!')'
gen["my ("]
pardef (...!')' gen[", "] pardef)(s?)
gen[") = \@_;"]
)(?)
')'
stmts decindent
nl gen["}"] nl
#c_define: 'define' ident gen["sub $item[-1] {"] incindent
# (nl command | stmts ) decindent
# nl gen["}"] nl
c_define: 'define' ident gen["\$$item[-1] = "] expr gen[";"]
pardef : ident gen["\$$item[-1]"]
c_reg : 'script-fu-register' <commit>
string string string
string string string
string
{
$item[1]=func2perl(substr($item[3],1,length($item[3])-2));
$item[3]=~s/script-fu/perl_fu/;
$item[3]=~y/-/_/;
$item[4]=~s/Script-Fu/Perl-Fu/;
$item[5]=~s/\s{2,}/ /g;
}
nl gen["register "] incindent
gen[$item[3]] gen[","]
nl gen[$item[5]] gen[","]
nl gen[$item[5]] gen[","]
nl gen[$item[6]] gen[","]
nl gen[$item[7]] gen[","]
nl gen[$item[8]] gen[","]
nl gen[$item[4]] gen[","]
nl gen[$item[9]] gen[","]
nl gen["["] incindent
( <reject:$arg[0]!~/^.<Image>/> skip paramdef paramdef unskip )[$item[4]](?)
(...!')' paramdef)(s?)
decindent
nl gen["],"]
nl gen["\\&$item[1];"]
decindent
paramdef: /SF-\w+/
nl
gen["["] gen[$sf2pf{$item[1]}]
string gen[sf2pf($item[-1])."$item[-1], "]
( '"TRUE"' gen["1"]
| '"FALSE"' gen["0"]
| expr
) gen["],"]
e_call : ( /script-fu-[A-Za-z_*][A-Za-z0-9-_*]*/
gen["\"$item[-1]\"->(RUN_NONINTERACTIVE, "]
| ident gen["$item[-1] ("]
)
(...!')'
expr (...!')' gen[", "] expr)(s?)
)[@arg](?)
gen[")"]
c_set : /set!?/ <commit>
ident gen["\$$item[-1] = "]
expr
gen[";"]
c_aset : /aset\b/ <commit>
ident gen["\$$item[-1]\->["] expr gen["] = "] expr gen[";"]
c_let : /let(\*|rec)?/ <commit>
gen["do {"] incindent
'(' let_expr(s) ')' nl
stmts (expr gen[";"])(?) decindent
nl gen["};"]
let_expr: ...!')' nl '(' ident gen["my \$$item[-1] = "] expr gen[";"] ')'
e_begin : /begin\b|prog1\b/ <commit>
gen["do {"] incindent
stmts decindent
nl gen["}"]
e_if : 'if' <commit>
gen["("] expr gen[") ? ("] expr gen[") : ("] expr gen[")"]
c_if : 'if' <commit>
gen["if ("] expr gen[") {"] incindent
nl stmt decindent
nl gen["}"]
( '(' ')'
|
(...!')'
gen[" else {"] incindent
nl stmt decindent
nl gen["}"]
)(?)
)
c_while : 'while' <commit>
nl gen["while ("] expr gen[") {"] incindent
stmts decindent
nl gen["}"]
e_cond : 'cond' <commit>
cond
cond : '('
( /'?else\b/ expr ')'
| expr gen[" ? "] expr incindent nl gen[": "] ')' decindent
( ...'(' cond | gen["die 'cond fell off the end'"] )
)
e_binop : expr
(...!')'
gen[" $arg[0] "]
expr
)[@arg](s?)
e_list : 'list' gen["["] (expr (...!')' gen[", "] expr)(s?))(?) gen["]"]
ident : /[A-Za-z0-9-#_*!?<>=\/]+/ <reject:$item[1]!~/[A-Za-z]/>
{ func2perl($item[1]) }
numeral : /-?(?:\d+(?:\.\d*)?|\.\d+)/ gen[$item[-1]]
string : /"([^\\"]+|\\.)*"/ { $item[1]=~s/([\$\@])/\\$1/g; $item[1] }
| /'[A-Za-z0-9-_*!?<>=\/]+/ { $item[1]=~s/([\$\@])/\\$1/g; '"'.substr($item[1],1).'"' }
list : "'(" gen["["] (expr (...!')' gen[", "] expr)(s?))(?) gen["]"] ')'
constant: /(?:$constants)(?=[ \t;)\n\r])/ gen[$constant{$item[-1]}]
| /[A-Z-_]{3,}/ gen[func2perl($item[-1])]
nl: gen["\n".(" " x $indent)]
incindent: { printf STDERR " %2d%%\b\b\b\b",$thisoffset*100/$::filesize unless $::quiet } { $indent++ }
decindent: { $indent-- }
skip: { $xskip++ }
unskip: { $xskip-- }
gen: ( <reject:$xskip> <defer: print ::OUT $arg[0] > )[@arg](?)
#gen: { $xskip or print $arg[0] } #d#
EOA
$parser or die;
print STDERR "done\n" unless $quiet;
#$RD_TRACE=15;
sub convert {
my($in,$out)=@_;
open IN,"<$in\0" or die "unable to open '$in' for reading: $!";
open OUT,">$out\0" or die "unable to open '$out' for writing: $!";
print STDERR "header..." unless $quiet;
print OUT <<EOA;
#!/usr/bin/perl
use Gimp qw(:auto);
use Gimp::Fu;
EOA
print STDERR "reading($in)..." unless $quiet;
{ local $/; $file = <IN> }
$file =~ s/;.*?$//gm;
$::filesize = length $file; # make it clear this is a _global_ variable
print STDERR "translating..." unless $quiet;
$parser->script ($file);
print STDERR "trailer..." unless $quiet;
print OUT "\n",join("\n\n",keys %add_funcs),"\n" if %add_funcs;
print OUT <<'EOA';
exit main;
EOA
print STDERR "wrote($out)\n" unless $quiet;
}
for $x (@ARGV) {
(my $y=$x)=~s/\.scm/.pl/i or die "source file '$x' has no .scm extension";
convert($x,$y);
}
Reference in New Issue View Git Blame Copy Permalink