scm2perl - metacpan.org

#!/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.

# this file is called "the dong"

# 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])*$_[1];
}',

'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);
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)