#!/usr/bin/perl -w
#
# jMax
# Copyright (C) 1994, 1995, 1998, 1999 by IRCAM-Centre Georges Pompidou, Paris, France.
# 
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser Lesser General Public License
# as published by the Free Software Foundation; either version 2.1
# of the License, or (at your option) any later version.
# 
# See file COPYING.LIB for further informations on licensing terms.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU Lesser General Public License for more details.
# 
# You should have received a copy of the GNU Lesser Lesser General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
#
# This script is here to help porting jMax packages from version 2.5 to
# version 4.0. It saves the developer from doing stupid "search-and-replace"
# work by automatically changing deprecated function calls into their new counterparts
# and by doing other simple substitutions. What the "autoporter" cannot do, it
# informs the user of, giving indications as to what should be done and where.
#
# This script (as it says above) comes WITHOUT ANY WARRANTY. Make sure you do a
# complete backup of the sources of the package you wish to convert before
# using this tool.
#


### Program #####################################################################


print("This is autoport, version 0.1, by Carl Seleborg\n");
print("Copyright (C) 2003 by IRCAM-Centre Georges Pompidou, Paris, France\n");




# Parse command-line and return associative array with values set.
my %options = &ParseArguments();
my $package_name = $options{"package-name"};
my $package_directory = $options{"src-location"};
print("Could not find directory '$package_directory' - abort\n") and exit(1)
    if !(-e $package_directory && -d $package_directory);


# Make backup if requested
if($options{'copy-location'})
{
    if(!-e $options{'copy-location'} && system "mkdir $options{'copy-location'}")
    {
		print("autoport : error : failed to create directory $options{'copy-location'} - abort\n");
		exit(1);
    }
    if(system "cp -dpr $options{'src-location'}/* $options{'copy-location'}")
    {
		print("autoport : error : failed to copy source directory - abort\n");
		exit(1);
    }
}



print("autoport : Attempting port of package " . $package_name . " ...\n");


# Gather list of files
my @files = &GetListOfFiles();

# print("autoport : found the following source files :\n");
# foreach $file (@files)
# {
#     print("\t$file\n");
# }


# Scan all files and locate important information
%info = &ScanFilesAndCollectInfo(\@files);
$info{"package-name"} = $package_name;


# Checking that all is there
if(!($info{"package-init"}{"name"}))
{
    printf("autoport : warning : could not find module-init function (port already done?)\n");
}


&DoSubstitutionsInFiles(\@files, \%info);



### Functions ###################################################################

###
# Gets the list of C source files in the package's directory and returns an
# array of them.
#
sub GetListOfFiles
{
    # The list of filenames
    @list = ();

    open(FILELIST, 'find ' . $package_directory . ' -name "*.[ch]" -print |')
		or print("autoport : error : failed to get list of files - abort\n") and exit(1);
    while($filename = <FILELIST>)
    {
		chomp($filename);
		push(@list, $filename);
    }

    return @list;
}


###
# Prints usage syntax.
#
sub PrintUsage
{
    print("Usage : autoport name-of-package [options]\n");
    print(" Options can be the following :\n");
    print("  -c dir : If specified, copies the source directory to the 'dir' directory\n");
    print("           before modifying the files\n");
    print("  -d dir : If specified, tells autoport where to find the sources\n");
    print("           (default is 'name-of-package/')\n");

    return 1;
}



###
# Parses the command-line arguments and returns an associative array
# with key-value pairs. The following keys are returned :
#  - package-name : name of the package
#  - copy-location : if set, tells where to make the backup
#  - src-location : tells where the source files are
#
sub ParseArguments
{
    my %values;
    my $arg;
    
    &PrintUsage() and exit(1) if $#ARGV == -1;

    $values{'package-name'} = shift @ARGV;
    $values{'src-location'} = $values{'package-name'};

    while($#ARGV > -1)
    {
		$arg = shift @ARGV;
		
		if($arg eq "-c")
		{
      	    print("autoport : error : -c must be followed by directory name - abort\n") and exit(1)
				if $#ARGV == -1;

			$values{'copy-location'} = shift @ARGV;
		}
		elsif($arg eq "-d")
		{
			print("autoport : error : -d must be followed by directory name - abort\n") and exit(1)
				if $#ARGV == -1;

			$values{'src-location'} = shift @ARGV;
		}
		else
		{
			print("autoport : error : unknown option '$arg' - abort\n");
			exit(1);
		}
    }
    
    return %values;
}


###
# Reads and stores a whole file into a string
#
# @param file Name of the file to load
#
sub LoadFile
{
    my $filename = shift;
    my $contents = "";
    my $chunk;
    
    open(FILEHANDLE, "<" . $filename)
		or print("autoport : error : failed to open file '$filename' for reading - abort\n") and exit(1);

    while(!eof(FILEHANDLE))
    {
		read(FILEHANDLE, $chunk, 8192);
		$contents .= $chunk;
    }

    close(FILEHANDLE);

    return $contents;
}



###
# Writes a file back to disk from a string
#
# @param filename Name of the file
# @param contents Contents of the file
#
sub WriteFile
{
    my ($filename, $contents) = @_;
    
    open(FILEHANDLE, ">" . $filename)
		or print("autoport : error : failed to open file '$filename' for writing - abort\n") and exit(1);

    print("autoport : error : failed to write to file '$filename' - abort\n") and exit(1)
		if(syswrite(FILEHANDLE, $contents, length $contents) == -1);
}


###
# Scans all files in the list of files and collects information about
# modules, classes, objects, etc.
#
# @param files List of files to scan
# @return A hash containing the information :
#   - package-init
#      - name : name of the function
#      - file : file containing that function
#
sub ScanFilesAndCollectInfo (\@)
{
    my $ref_files = shift;
    my ($file, $conents);
    my $struct_member = '\s*([^,]+|"[^"]*")\s*';
    my %result;

    foreach $file (@$ref_files)
    {
		$contents = &LoadFile($file);

		# printf("autoport : scanning file '%s'...\n", $file);

		# Search for module initialization functions
		if($contents =~ 
		   /fts_module_t \s+ \w+ \s* = \s* \{ $struct_member , $struct_member , $struct_member , $struct_member , $struct_member \}\s*;/x)
		{
			$result{"package-init"}{"name"} = $3;
			$result{"package-init"}{"file"} = $file;
			# printf("autoport : (%s) found module initialization function : '%s'\n", $file, $3);
		}
    }

    return %result;
}


###
# Does substitutions in the given files
#
# @param files List of files to modify
# @param info The information previously collected by ScanFilesAndCollectInfo
#
sub DoSubstitutionsInFiles (\@\%)
{
    my ($ref_files, $ref_info) = @_;
    my ($file, $contents, $old, $new);

    print("autoport : processing files :\n");

    foreach $file (@$ref_files)
    {
		$contents = &LoadFile($file);
		
		# Remove module declaration (fts_module_t)
		$old = "fts_module_t\\s*[^;]*;";
		$new = "";
		$contents = &DoSubstitutionsInString($contents, $old, $new, 1);


		# Substitute package-module init function name
		# from $info{"package-init"}{"name"} to package_config
		if($ref_info->{"package-init"}{"name"})
		{
			$old = 'void\s+' . $ref_info->{"package-init"}{"name"};
			$new = 'void ' . $ref_info->{"package-name"} . "_config";
			$contents = &DoSubstitutionsInString($contents, $old, $new);
		}


		# fts_new_symbol_copy -> fts_new_symbol
		$old = 'fts_new_symbol_copy';
		$new = 'fts_new_symbol';
		$contents = &DoSubstitutionsInString($contents, $old, $new);

		# Replace "post" with "fts_post"
		$contents = &DoSubstitutionsInString($contents, 'post', 'fts_post');

		# Replace ivec_atom_get with (ivec_t*)fts_get_object
		$contents = &DoSubstitutionsInString($contents, "ivec_atom_get", "(ivec_t*)fts_get_object");


		# Replace fvec_atom_get with (fvec_t*)fts_get_object
		$contents = &DoSubstitutionsInString($contents, "fvec_atom_get", "(fvec_t*)fts_get_object");


		# Replace vec_atom_get with (vec_t*)fts_get_object
		$contents = &DoSubstitutionsInString($contents, "vec_atom_get", "(vec_t*)fts_get_object");

		
		# Remove fts_symbol_name macro
		$contents = &DoSubstitutionsInString($contents, "fts_symbol_name", "", 1);


		# Instanciation and constructor/destructor declaration
		$contents = &FiddleWithInstanciationFunctions($contents);


		# Replace obsolete calls to fts_bloc_malloc() and friends.
		$contents = &DoSubstitutionsInString($contents, "fts_block_alloc", "fts_malloc");
		$contents = &DoSubstitutionsInString($contents, "fts_block_zalloc", "fts_zalloc");
		$contents = &DoSubstitutionsInString($contents, "fts_block_free", "fts_free");
		$contents = &DoSubstitutionsInString($contents, "fts_do_block_alloc", "fts_do_malloc");
		$contents = &DoSubstitutionsInString($contents, "fts_do_block_zalloc", "fts_do_zalloc");
		$contents = &DoSubstitutionsInString($contents, "fts_do_block_free", "fts_do_free");
		


		# Replace fts_method_define calls by fts_class_inlet_* or fts_class_message_*
		$contents = &DoMethodDefinitionReplacements($contents, $file);


		# Replace fts_get_ptr by ftr_get_pointer
		$contents = &DoSubstitutionsInString($contents, "fts_get_ptr", "fts_get_pointer");
		$contents = &DoSubstitutionsInString($contents, "fts_word_get_ptr", "fts_word_get_pointer");
		$contents = &DoSubstitutionsInString($contents, "fts_set_ptr", "fts_set_pointer");
		$contents = &DoSubstitutionsInString($contents, "fts_word_set_ptr", "fts_word_set_pointer");


		# Warn if fts_alarm_t or fts_file_get_read_path are used
		if($contents =~ /fts_alarm_t/)
		{
			printf("autoport : warning : fts_alarm_t has been replaced by FTS timebases\n" .
				   "                     (see fts_timebase*() functions in <fts/time.h>) (in file %s)\n", $file);
		}
		if($contents =~ /fts_file_get_read_path/)
		{
			printf("autoport : warning : fts_file_get_read_path must not be used anymore (in file %s)\n", $file);
		}
		if($contents =~ /fts_param_/)
		{
			printf("autoport : warning : use of param has changed. Use fts_param_t objects instead now,\n" .
				   "                     see <fts/param.h> for details. (in file %s)\n", $file);
		}
		
		&WriteFile($file, $contents);

		printf("\t%s\n", $file);
    }
}


###
# Substitutes a s2 with s3 (along with a comment to declare the modification) in s1.
#
# @param s1 The string to search
# @param s2 The string to find
# @param s3 The string to replace s2 with
# @param remove If true, the matched pattern is removed
#
# @return The modified s1
#
sub DoSubstitutionsInString
{
    my ($s1, $s2, $s3, $s4) = @_;
    my $r = $s1 =~ /(^(.*)($s2))/mgx;
    
    return $s1 unless $r;

    $old_trimed = Trim($3);
    $new_trimed = Trim($s3);

    if(!$s4)
    {
		$s1 =~ s/^(.*)($s2)/\/\* CODE MODIFIED BY autoport : \'$old_trimed\' -> \'$new_trimed\' \*\/\n$1$s3/mgx;
    }
    else
    {
		$s1 =~ s/^(.*)($s2)/\/\* CODE REMOVED BY autoport : \'$2\' \*\/\n$1/mgx;
    }
    return $s1;
}


sub Trim
{
    $_ = shift;
    s/^\s*(.*)/$1/;
    s/(.*\S)\s*$/$1/;
    return $_;
}


###
# Fiddles with the instanciation functions in a source file.
#
# @param contents The string holding the contents of the file
#
# @return Returns the modified contents of the file
#
sub FiddleWithInstanciationFunctions
{
    my $file_contents = shift;
    my $r = 0;
    my $sep = '\s*,\s*';
    my $fun_ptr = '(\(\w+\))?\w+';
    my $regexp1 = '((fts_status_t\s+(\w+)_instantiate\s*\(\s*fts_class_t\s*\*\s*(\w+)\s*,[^)]*\))\s*\{([^\n]|\n[^}])*\n\})';
    my $regexp2 = '((fts_status_t\s+(\w+)_instantiate\s*\(\s*fts_class_t\s*\*\s*(\w*)\s*,[^)]*\))\s*;)';


    # First step : find an unmodified instanciation function :
    $r = $file_contents =~ /$regexp1/;
    
    while($r)
    {
		$class_arg_name = $4;
		$obj_name = $3;
		$contents = $1;
		$old_contents = $1;
		$constructor_name = "";
		$destructor_name = "";
		$constructor_statement = "";
		$destructor_statement = "";

		# printf("%d\n", $contents =~ quotemeta($2));
		$def = quotemeta($2);
		$contents = &DoSubstitutionsInString($contents, $def, "void ${obj_name}_instantiate(fts_class_t* $class_arg_name)");
		# $contents =~ s/$def/void ${obj_name}_instantiate(fts_class_t* $class_arg_name)/;

		# Search for constructor
		if($contents =~ /(^.*fts_method_define\w*\s*\(\s*[^,]+,\s*fts_SystemInlet\s*,\s*fts_s_init\s*,\s*($fun_ptr)[^)]*\)\s*;)/mx)
		{
			# printf("Found constructor declaration : %s (constructor named %s)\n", $1, $2);
			$constructor_name = $2;
			$constructor_statement = $1;

			# Remove it from function code
			$contents = &DoSubstitutionsInString($contents, quotemeta($1), "", 1);
		}

		# Search for destructor
		if($contents =~ /(^.*fts_method_define\w*\s*\(\s*[^,]+,\s*fts_SystemInlet\s*,\s*fts_s_delete\s*,\s*($fun_ptr)[^)]*\)\s*;)/mx)
		{
			# printf("Found destructor declaration : %s (destructor named %s)\n", $1, $2);
			$destructor_name = $2;
			$destructor_statement = $1;

			# Remove it from function code
			$contents = &DoSubstitutionsInString($contents, quotemeta($1), "", 1);
		}

		# Search for class initialization
		if($contents =~ /(fts_class_init\s*\(\s*(\w+) $sep ([^,]*) $sep [^)]*\))\s*;/mx)
		{
			$constructor_name = "0" if !$constructor_name;
			$destructor_name = "0" if !$destructor_name;
			$contents = &DoSubstitutionsInString($contents, quotemeta($1), "fts_class_init\($2, $3, $constructor_name, $destructor_name\)");
		}

		# Search for return statements
		while($contents =~ /[^\'](return\s+(\S+\s*);)/mx)
		{
			$contents = &DoSubstitutionsInString($contents, quotemeta($1), "return;");
		}


		# printf("autoport : found instantiation function for object %s (class param %s) : \n%s\n",
		#       $obj_name, $class_arg_name, $contents);

		$quoted = quotemeta($old_contents);
		$file_contents =~ s/$quoted/$contents/gmx;
		$r = $file_contents =~ /$regexp1/;
	}



	# Treat function declarations the same way
	if($file_contents =~ /$regexp2/gxm)
	{
		$class_arg_name = $4;
		$obj_name = $3;
		$def = quotemeta($2);
		$file_contents = &DoSubstitutionsInString($file_contents, $def, "void ${obj_name}_instantiate(fts_class_t* $class_arg_name)");
	}

	return $file_contents;
}


###
# Replaces method definitions by the new calls to fts_class_inlet* and fts_class_define*
#
# @param contents The text to modifiy
#
# @return The modified text
#
sub DoMethodDefinitionReplacements
{
    $_ = shift;
    $filename = shift;


    while(/(^.*[^\'\s]\s*|^\s*)(fts_method_define(\w*)([^;]*)\s*;)/mgx)
    {
		$instr = $2;
		$suffix = $3;
		$params = $4;

		$params =~ /\s*\(([^,]*),([^,]*),.*\)$/m;
		$class = $1;
		$winlet = $2;
		$method = "";

		printf("FOUND instruction <%s> in file %s : ", $instr, $filename);


		# We have two cases : either the method is declared to take a single atom as argument,
		# (because it's declared with a fts_s_[type] argument or because it's defined using
		# a fts_method_define_[type] version of the fts_method_define function), either
		# the method is a little more sophisticated (with a varargs and other strange messages).
		if($params =~ /fts_s_(int|float|number|symbol|bang|list|anything|void)/
		   || $suffix =~ /_(int|float|number|symbol|bang|list|anything|void)/)
   		{
			print("atom");

		    if($params =~ /fts_SystemInlet/)
		    {
				printf("autoport : warning : %s\n", $instr);
				printf("                   : defining a method for fts_SystemInlet that matches a fts_s_[atomic] selector is probably wrong (in file %s)\n", $filename);
		    }
	    
		    # Deduce type from suffix or from parameter?
		    $type = "";
		    if($suffix =~ /_(int|float|number|symbol|bang|list|anything|void)/)
		    {
				$type = $1;
				$params =~ /\s*\(([^,]*,){2} (.*)\)/x;
		    	$method = $2;
		    }
		    elsif($params =~ /fts_s_(int|float|number|symbol|bang|list|anything|void)/)
		    {
				$type = $1;
				$params =~ /\s*\(([^,]*,){3} ([^,]*) (,.*)?\)/x;
	    		$method = $2;
		    }
	    
		    $_ = &DoSubstitutionsInString($_, quotemeta($instr), "fts_class_inlet_$type($class,$winlet,$method);");
		}
		else
		{
			print("message");

		    # Here, two cases again : if fts_SystemInlet is specified, we must use the
		    # fts_class_message_varargs() function. Otherwise, we use the fts_class_inlet_varargs()
		    # function.
			$params =~ /\s*\(([^,]*), ([^,]*), ([^,]*), ([^,]*) (,.*)?\)/x;
		 	$symbol = $3;
			$method = $4;

		    if($params =~ /fts_SystemInlet/)
		    {
				$_ = &DoSubstitutionsInString($_, quotemeta($instr), "fts_class_message_varargs($class,$symbol,$method);");
		    }
			else
			{
				$_ = &DoSubstitutionsInString($_, quotemeta($instr), "fts_class_inlet_varargs($class,$symbol,$method);");
			}
		}

		print("\n");

	}

	return $_;
}













