#!/usr/bin/perl -w
#convert sybase table DDL files to oracle
#work in progress





use strict;
use Data::Dumper;
use Text::Balanced qw(extract_bracketed);




main();





sub main {
	for my $file (qw( cust_event cust cust_login cust_login_failed )) {
		convertTableFile("_test/syb/$file.sql", "_test/ora");
		}

	return(1);
	}





sub convertTableFile {
	my ($file, $dirDest) = @_;

	my $sql = loadFile($file) or die("Could not load SQL file ($file)\n");
	my ($description, $nameTable, $defTable, $remainder) = aExtractTableDescNameDef($sql) or die("Could not extract table definition from sql ((($sql))) in file ($file)\n");

	my @aField = aExtractFields($defTable) or die("Could not extract any fields from sql ((($sql))) in file ($file)\n");
	my @aConstraint = aExtractConstraints($defTable);
	my @aIndex = aExtractIndexes($remainder);

	warnOnUnimplemented($sql, $file);

#print "($nameTable)\n";
#print "(|||$description|||$nameTable|||$defTable|||$remainder|||)\n";

	print $file, Dumper(\@aIndex);

	return(1);
	}




=head2 aExtractTableDescNameDef($sql)

Extract the table definition in $sql.

Return array with (description, table name, table
definition, reminder), or an empty array on errors.

=cut
sub aExtractTableDescNameDef {
	my ($sql) = @_;
	my ($description, $nameTable, $sqlReminder) = ($sql =~ m{( /\* .*? \*/ )? \s* create \s+ table \s+ ([\w.]+) \s* (.*) }xsi) or return();
	$description ||= "";
	$nameTable = normalizeName($nameTable);

	my ($def, $remainder) = extract_bracketed($sqlReminder, "()") or return();

	return($description, $nameTable, $def, $remainder);
	}





=head2 aExtractFields($sqlTableDef)

Extract the fields in the $sqlTableDef.

Return array with hash refs (keys: name, type, null,
default, identity, comment), or an empty array on errors. Hash ref
values may be undef for null, default, comment, identity.

=cut
sub aExtractFields {
	my ($sql) = @_;
	my @aField;

	for my $line(split(/\n/, $sql)) {
		#country varchar(20) null,
		#is_sessions_enabled bit default 0,
		#cust_id numeric(10, 0)  not null,
		if($line =~ /
				\s*
				(\w+) \s+ 			#name
				(					#type
					\w+					#word
					(					#optional type specifier
						\( \d+ \s* 			#paren digits and
						(						#optional comma digits
							, \s* \d+
						)?  \)				#closing paren
					)?
				)
				\s*
				(					#option
				[^,]+				#everything up until the final comma
				)? ,				#comma
				\s*
				(					#comment
				--
					(
					.*				#comment token and the rest of the line
					)
				)?
				/x) {
			my $option = $5;
			my $rhField =  {
				name => $1,
				type => $2,
				comment => $7,
				};

			my $null = $1 if($option =~ /((not)? \s* null)/xi);
			$rhField->{null} = $null;

			my $default = $1 if($option =~ /(default \s+ (\w+))/xi);		##todo: works for numbers and NULL, not for strings yet. Implement when needed.
			$rhField->{default} = $default;

			my $identity = $1 if($option =~ /( \b identity \b )/xi);
			$rhField->{identity} = $identity;

			next if($rhField->{name} =~ /^constraint$/i);
			push(@aField, $rhField);
			}
		}

	return(@aField);
	}





=head2 aExtractConstraints($sqlTableDef)

Extract the constraints in the $sqlTableDef.

Return array with hash refs (keys: name, type, index,
raField, referencesTable, raReferencesField), or an empty
array on errors.

The key type is "index" or "foreign key".

=cut
sub aExtractConstraints {
	my ($sql) = @_;
	my @aConstraint;

	for my $line(split(/\n/, $sql)) {
		if($line =~ /
				constraint \s*
				( \w+ ) \s+					#name
				(							#index
					( primary \s+ key )			#PK
					|							#or
					( unique )					#unique
					|							#or
					( foreign \s+ key )			#FK

				) \s*
				(							#clustered (optional)
					( clustered | nonclustered ) \s*
				)?

				\(							#fields
				(  [^)]+  )						#Everything within the paren
				\)
				\s*
				(							#references section, optional
					references \s+
					(						#table name
						\w+ \s*					#word
					)
					(						#field list, optional
						\(							#fields
						(  [^)]+  )						#Everything within the paren
						\)
					)?
					\s*
				)?
				/xi) {
			my $fields = $8;
			my $referencesFields = $12;
			my $rhConstraint = {
				type => "index",
				name => $1,
				index => $2,
				clustered => $6,
				raField => [],
				referencesTable => $10,
				raReferencesField => [],
				};
			$rhConstraint->{raField} = raExtractFields($fields);
			$rhConstraint->{raReferencesField} = raExtractFields($referencesFields);
			$rhConstraint->{index} =~ s/\s+/ /gs;	#Reduce whitespace
			$rhConstraint->{type} = "foreign key" if($rhConstraint->{index} =~ /foreign/i);

			push(@aConstraint, $rhConstraint)
			}
		}

	return(@aConstraint);
	}





=head2 aExtractIndexes($sql)

Extract the indexes in the $sql.

Return array with hash refs (keys: name, index,
raField, referencesTable, raReferencesField), or an empty
array on errors.

=cut
sub aExtractIndexes {
	my ($sql) = @_;
	my @aIndex;

	while($sql =~
				m/
				create \s+
				(							#unique, optionsl
					unique
				)? \s*
				(							#clustered, optional
					clustered
					|
					nonclustered
				)? \s*
				index \s+
				(							#index name
					\w+
				) \s+
				on \s+
				(							#table name
					[\w.]+
				) \s*
				(							#field list, optional
					\(							#fields
					(  [^)]+  )						#Everything within the paren
					\) \s*
				)?
				(							#with clause, optional, (only supports one option as implemented here)
					with \s+ ( \w+ ) \s*
				)?
				/gsxi ) {
		my $fields = $6;
		my $rhIndex = {
			name => $3,
			clustered => $2,
			unique => $1,
			table => $4,
			raField => [],
			with => $8,
			};
		$rhIndex->{name} = normalizeName($rhIndex->{name});
		$rhIndex->{table} = normalizeName($rhIndex->{table});
		$rhIndex->{raField} = raExtractFields($fields);
		push(@aIndex, $rhIndex);
		}

	return(@aIndex);
	}





=head2 raExtractFields($fields)

Extract the field names in $fields and return array ref with
the field names, or [] if none were found or if $fields is
undef.

Any words in $fields are the field names.

=cut
sub raExtractFields {
	my ($fields) = @_;
	$fields or return([]);
	return( [ $fields =~ /(\w+)/g ] );
	}





=head2 warnOnUnimplemented($sql, $file)

warn for any occurrences of not yet supported SQL features
in $sql.

Return 1.

=cut
sub warnOnUnimplemented {
	my ($sql, $file) = @_;

	warn("WARNING: Unsupported ALTER TABLE found in file ($file)\n") if($sql =~ /alter \s+ table/xi);

	return(1);
	}





=head2 normalizeName($name)

Return normalized version of $name, e.g. with the user
stripped ("dbo.cust" becomes "cust").

=cut
sub normalizeName {
	my ($name) = @_;
	$name =~ s/^.*\.(\w+)$/$1/;		#Remove any owner from the beginning of the name
	return($name);
	}





sub loadFile {
	open(my $fh, "< $_[0]") or return(undef);
	local $/;
	return(<$fh>);
	}





__END__