Menu results from the CPAN

Graphics-VTK

#!/usr/local/bin/perl -w

# This is a tcl -> perl converted heavily modified from  Nick Ing-Simmons Tk Package
#   The original was found in the Tk800.022 distribuion. Thanks Nick!


use Tk::Pretty;
use Carp;

use Parse::RecDescent; # used for parsing the tcl text
use Data::Dumper;

use File::Basename;

#use GraphViz::Parse::RecDescent; # For Debugging

################### global ################
%Parse::RecDescent::vtkObjects = ();  # hash of vtk object variable names defined
%Parse::RecDescent::vtkObjects = ();  # appears twice to avoid warning message

%Parse::RecDescent::Objects = ();  # hash of any object variable names defined
%Parse::RecDescent::Objects = ();  # appears twice to avoid warning message

%Parse::RecDescent::Procs = ();  # hash of any procs defined 
%Parse::RecDescent::Procs = ();  # appears twice to avoid warning message

%Parse::RecDescent::MyVariables= (); # appears twice to avoid warning message
%Parse::RecDescent::MyVariables= (); # hash of any local variables used in the current context
					# ( Will be translated to 'my' variables )

%Parse::RecDescent::GlobalVariables= (); # appears twice to avoid warning message
%Parse::RecDescent::GlobalVariables= (); # hash of any global variables used in the current context

%Parse::RecDescent::MenuPaths= (); # appears twice to avoid warning message
%Parse::RecDescent::MenuPaths= (); # Mapping of -menu paths used in menubutton commands to the
				   #  pathname of the menubutton. This is used to translate
				   #  the tcl way of adding menubutton commands using the 'menu'
				   #   command to the perltk way of $menubutton->command(... syntax

###########################################

#################### Parse::RecDescent Grammer #################
my $parse = Parse::RecDescent->new(<<'EndGrammar');

	main:  statements  /\s*\Z/ { $item[1] }
#	main:  statements  /\s*\Z/ { {$item[1]}}
	    | <error>

        statements: <skip:'[ \t]*'> <leftop: statement /[\;\n]+/ statement> 
	    | <error>
#        statements:  statement(s) 
	
	statement: tcl_set 
	    | tcl_comment
	    | tcl_expr
	    | tcl_for
	    | tcl_foreach
	    | tcl_incr
	    | tcl_if
	    | tcl_while
	    | tcl_eval
	    | tcl_catch
	    | tcl_info
	    | tcl_proc
	    | tcl_global
	    | tcl_puts
	    | tcl_lindex
	    | tcl_string
	    | tcl_switch
	    | tcl_wm
	    | tcl_grid
	    | tcl_packforget
	    | tcl_packpropagate
	    | tcl_pack
	    | tcl_tkmenu
	    | tcl_imageCreate
	    | tcl_bind
	    | tcl_update
	    | tcl_winfo
	    | tcl_widget
	    | tcl_GetWidgetVarValue
	    | tcl_SetWidgetVarValue
	    | tcl_NewWidgetObj
	    | tcl_scan
	    | tcl_format
	    | tcl_append
	    | tcl_vtkConstructor
	    | tcl_vtkCallback
	    | tcl_vtkAddObserver
	    | tcl_tkadd
	    | tcl_tkentryconfig
	    | tcl_return
	    | tcl_tagbind
	    | tcl_exec
	    | tcl_method

examples/tcl2perl view on Meta::CPAN


	# tcl tk winfo command. Mapped to $widget->command
	tcl_winfo: 'winfo' plainBareword lvar
		{ ['->',$item[3],$item[2]] }

	# tcl tk bind command
	tcl_bind: 'bind' object /\<[^>]+\>/ block
		{ bindProc( @item); }

	# tcl tk tag bind command
	tcl_tagbind: object 'tag' 'bind' tcl_arg /\<[^>]+\>/ block
		{ tagbindProc( @item); }
			
	# tcl tk update command					
	tcl_update: 'update' { [ '->','$MW','update']}

	# tcl 'scan' command. This is usually used in tcl to split a string list to
	#   some variables, so that is how we map it here. i.e. 'scan command format var1 var2
	#  gets mapped to ($var1,$var2) = command;
	tcl_scan: 'scan' '[' statement ']' tcl_arg lvar(s)
		{ scanProc( @item); }
	
	# tcl format command. Mapped to sprintf
	tcl_format: 'format' formatString tcl_arg(s)
		{ my ($rule, $format, $formatString, $args) = @item;
		  my $retVal = [ 'sprintf', $formatString,@$args];
		  $retVal;
		 }

	# tcl append command.
	tcl_append: /append(?![A-Za-z0-9.])/ lvar tcl_arg(s)
		{ my ($rule, $append, $lvar, $args) = @item;
		  my $retVal;
		  if( @$args == 1){
		  	$retVal = [ '=', $lvar, ['.',$lvar,$args->[0]]];
		  }
		  else{
		  	$retVal = [ '=', $lvar, ['join','',$lvar,@$args]];
		  }
		  $retVal;
		 }
	
	# format string in the format commands
	formatString: quotedString | curlyBracesString | /\S+/
	
	# vtk Object Constructor:
	tcl_vtkConstructor: /vtk\w+/ object tcl_arg(s?) 
			{ my ($rule, $class, $varName, $args) = @item;
			  my $varLookup = $varName; # get rid of '$' for lookup
			  $varLookup =~ s/^\$//g;
			  $class =~ s/^vtk//;
			  $Parse::RecDescent::vtkObjects{$varLookup} = 1;
			  ['=', $varName,[ '->', "Graphics::VTK::".$class, 'new', @$args]];
			} 

	# tk add command
	tcl_tkadd: lvar 'add' tcl_arg tkoption(s?)
			{
				my ($rule, $name, $add, $method, $options) = @item;
				
				# if name is a pre-defined MenuPath, then map it to
				#  a menubutton
				if( defined( $Parse::RecDescent::MenuPaths{$name} )){
					$name = $Parse::RecDescent::MenuPaths{$name};
				}
				
				
				# Flatten the options
				my @options = map {@$_} @$options;
				
				my %argHash = @options;
				# convert -variable option to variable reference
				if( defined( $argHash{-variable})){
					my $varname = $argHash{-variable};
					$argHash{-variable} = "\\\$".$varname;
				}

				@options = %argHash;
				
				my $retVal = ['->',$name, $method, @options];
				
			}

	# tk methods command (currently only entry configure supported
	tcl_tkentryconfig: lvar 'entryconfigure' tcl_arg tkoption(s?)
			{
				my ($rule, $name, $method, $entry, $options) = @item;
				
				# if name is a pre-defined MenuPath, then map it to
				#  a menubutton
				if( defined( $Parse::RecDescent::MenuPaths{$name} )){
					$name = $Parse::RecDescent::MenuPaths{$name};
				}
				
				
				# Flatten the options
				my @options = map {@$_} @$options;
				
				my %argHash = @options;
				# convert -variable option to variable reference
				if( defined( $argHash{-variable})){
					my $varname = $argHash{-variable};
					$argHash{-variable} = "\\\$".$varname;
				}

				@options = %argHash;
				
				my $retVal = ['->',$name, $method, $entry,@options];
				
			}


	tcl_vtkCallback: object /Set\w+?Method/ callback
			{
				my ($rule, $name, $method, $callback) = @item;
				
				my $retVal =  ['->',$name,$method, $callback];
			}

	# vtk AddObserver method
	tcl_vtkAddObserver: object /AddObserver/ tcl_arg callback
			{
				my ($rule, $name, $method, $event, $callback) = @item;
				
				my $retVal =  ['->',$name,$method, $event, $callback];
			}

	tcl_method: object tcl_arg tcl_arg(s?)
			{ methodProc(@item) }

	# Args to a tcl method/call
	tcl_arg: 
		      /[A-Za-z]\w*\([^)]+\)/ { '$'.$item[1]; } # Array Style Variable like a(man)
		      | number
		      |  rvar
		      |  quotedString
		      |  curlyBracesString
		      | '[' statement ']'{ $item[2]; }
		      | commandSub
		      | colorNumber
		      # Variables with embedded string, like xs$string, map to $xs($string)
		      #   which will get translated to a perl hash like $xs{$string}
		      | /[A-Za-z]\w*\$[A-Za-z]\w*/
			      {
				      my($var, $index) = $item[1] =~ /([A-Za-z]\w*)\$([A-Za-z]\w*)/;
				      '$'.$var.'($'.$index.')';
			      }
		      # Another variation of Variables with embedded string, like ${cell}Centers, map to $centers($cell)
		      #   which will get translated to a perl hash like $centers{$cell}
		      | /\$\{[A-Za-z]\w*\}[A-Za-z]\w*/
			      {
				      my($index, $var) = $item[1] =~ /\$\{([A-Za-z]\w*)\}([A-Za-z]\w*)/;

examples/tcl2perl view on Meta::CPAN

 croak "No item!" unless defined $item;
 if (ref($item))
  {
   if (ref($item) eq 'ARRAY')
    {
     if (@$item)
      {
       my $kind = $item->[0];
       push @output_context, $kind; # save context
       if (exists $statement{$kind})
        {
         &{$statement{$kind}}($depth,@$item);
        }
       else
        {
         print indent($depth);
         expression(0,$item);
         print ";\n";
        }
       pop @output_context; # pop context
      }
     else
      {
       print "\n";
      }
    }
   else
    {
     die "Not an array reference $item";
    }
  }
 else
  {
   print indent($depth),$item,"\n";
  }
}

sub statements
{
 my $depth = shift;
 while (@_)
  {
   statement($depth,shift);
  }
}

############################## Main Program #######################
$SIG{INT} = sub { croak "Interrupt" };

undef $/;
my $outPath = shift @ARGV;
foreach $file (@ARGV)
 {
  if ($file =~ /\.tcl$/)
   { # Clear Global Variables
     %Parse::RecDescent::vtkObjects = ();  
     %Parse::RecDescent::Procs = ();  
     %Parse::RecDescent::Objects = ();  
     %Parse::RecDescent::MyVariables= (); 
     %Parse::RecDescent::GlobalVariables= ();  
     %Parse::RecDescent::MenuPaths= (); 

    
    my $perl = basename($file);
    $perl =~ s/\.tcl/.pl/;
    
    my $preprocedFile = preProcessFile($file, basename($file));
    open(TCL,"<$preprocedFile") || die "Cannot open $preprocedFile:$!";
    print STDERR "$file => $perl\n";
    my $prog = <TCL>;
    close(TCL);
    unlink $preprocedFile;
    $prog =~ s/\\\n/ /sg;
    my $body = $parse->main($prog) || die("Invalid tcl Syntax\n");
    
    push(@$ClassInit,['return','$class']) if (defined $ClassInit);
    open (PERL, ">tempFile$$") or die("Can't Open Temp Output File 'tempFile$$'\n");
    

    my $old = select(PERL);
    if (defined $class)
     {
      print "package Tk::",$class,";\n";
      if (exists $info{-superclass})
       {
        my $superclass = $info{-superclass};
        $superclass =~ s/^[Tt]ix//;
        print '@Tk::',$class,'::ISA = qw(Tk::',$superclass,");\n";
       }
     }
    statements(0,@$body);
    select($old);
    close(PERL);
    
    # Post-Process the file:
    postProcessFile("tempFile$$","$outPath/$perl",basename($file));
    unlink "tempFile$$"; 
     # open(PERL,">$outPath/$perl") || die "Cannot open $perl:$!";

    #if (system("perl","-wc",$perl) != 0)
    # {
    #  rename($perl,"$perl.oops");
    #  exit(4) 
    # }
   }
 }
 
 
 ################################ PreProcess File ######################
 sub preProcessFile{ 
 
 	my $inputFile = shift;
	my $outputFile = "tempFile$$"; # temporary pre-processed File
	
	my $basename = shift;

	local( $/ );
	$/ = "\n";


	open( INFILE, $inputFile) or die("Can't open Input File '$inputFile'\n");

examples/tcl2perl view on Meta::CPAN

	
	if( $vtkInt){
		print OUTFILE "Graphics::VTK::Tk::vtkInt::vtkInteract(\$MW);\n";
	}
	if( $tkFlag){
		print OUTFILE "\nTk->MainLoop;\n";
	}
	
	close INFILE;
	close OUTFILE;
	
	return $outputFile;
}
#
# Parse::RecDescent Vars
#########################################################
### Sub to process the item variable returned from a parse::recdecsent match
sub Parse::RecDescent::processMatch{ 
	my @item = @_;
	my $subexpr = [@item]; # put the operator first
	shift @$subexpr; # get rid of rule name
	my $result;
	if( scalar(@{$subexpr->[1]}) > 0){  # flatten array
		$result = [$subexpr->[0], @{$subexpr->[1][0]}];
		# Put operator first
		my $op = splice(@$result,1,1);
		@$result = ($op,@$result);
	}
	else{ 
	# only 1st element present, return that

	$result = $subexpr->[0];
	}
	#print " Subexpr1 = ".Data::Dumper::Dumper(\@item);
	#print " Subexpr1 result = ".Data::Dumper::Dumper($result);
	return	$result;

}
#########################################################
### Sub to process the item variable returned from a continue-type rule match
sub Parse::RecDescent::processCont{ 
	my $subexpr = [@_]; # put the operator first
	shift @$subexpr; # get rid of rule name
	$subexpr;
}

## Sub to process widget commands
sub Parse::RecDescent::widgetProc{

	my ( $rule, $widget, $path, $args) = @_;
	
	# Flatten the options
	@$args = map {@$_} @$args;

	my ($parent,$name) = ($path =~ /^(.*)\.([^.]+)$/);
	my $retVal;
	$widget = ucfirst($widget) unless( $widget =~ /^vtk/);
	if (defined($parent) && defined($name)){

		my %argHash = @$args;
		# Save Menubutton -menu if present:
		if( $widget eq 'Menubutton'){
			if( defined($argHash{-menu})){
				$Parse::RecDescent::MenuPaths{$argHash{-menu}} = $path;
				delete $argHash{-menu};
			}
		}
		
		# convert -variable option to variable reference
		if( defined( $argHash{-variable})){
			my $varname = $argHash{-variable};
			$argHash{-variable} = "\\\$".$varname;
		}

		# convert -image option to variable 
		if( defined( $argHash{-image})){
			my $varname = $argHash{-image};
			$argHash{-image} = "\$".$varname;
		}


		@$args = %argHash;
		
		# Add to object list:
		$Parse::RecDescent::Objects{$path} = 1;
		
		# print "parent, name = '$parent', '$name'\n";
		# If top level parent (.), make equal to MW
		my $ourParent;
		my $mainVar;
		if( $parent !~ /\S/ ){
			$ourParent = '$MW';
			$mainVar = '$MW';
		}
		elsif( $parent =~ /^\$\w+/ ){ # parent is a variable
			$ourParent = $parent;
			$mainVar = $parent;
			$path = ".$name";
		}
		else{
			$ourParent = [ '->{}', '$MW',$parent]; # parent is in MW hash
			$mainVar = '$MW';
		}


		$retVal = [ '=', [ '->{}', $mainVar, $path ], [ '->', $ourParent, $widget, @$args ]];
	}
	else{
		warn("Can't get parent from '$path'\n");
		$retVal = undef;
	}

	$retVal;
}
## Sub to process the tcl 'string' command:
##  Currently only supports 'match' options
sub Parse::RecDescent::tcl_stringProc{

	my ( $rule, $string,$option,$args) = @_;

	if( $option eq 'match'){ # Match option
		my ($pattern, $string) = @$args;

( run in 1.150 second using v1.01-cache-2.11-cpan-39bf76dae61 )