package Field;

use strict;
use vars qw($QUOTE);

use XML;
use Message;

use methods;

use members ( scalar => 'name',
	    foldcase => 'type',
	      scalar => [ 'size',
			  'range', # for enum
			  'null',
			  'title',
			  'old',
			  'links',
			  'key',
			  'format',
			  'default',
			  'autoincrement',
			  'metadata_multi',
			  'metadata_field'
			  ],
		text => 'description' );

$QUOTE = '"';

sub new {
	my $package = shift;
	return (bless {}, $package)->init( null => 1, @_ );
}

sub sql_type {
	my ($this) = @_;
	my $ret = $this->{type};
	my $binary = $ret =~ s/ binary$//; # mysql binary hack - should put it in the mysql module?
	if ($this->{type} eq "enum") {
		$ret .= "(".$this->{range}.")" if defined $this->{range};
	} else {
		$ret .= "(".$this->{size}.")" if defined $this->{size};
	}
	$ret .= " binary" if $binary;
	return $ret;
}

sub sql_create {
	my ($this) = @_;
	my $ret = qq{$QUOTE$this->{name}$QUOTE } .  $this->sql_type;
	if (defined $this->{default}) {
		my $Q = $this->numeric ? "" : "'";
		$ret .= " DEFAULT $Q$this->{default}$Q";
	}
	$ret .= " NOT NULL" if defined $this->{null} && ! $this->{null};
	$ret .= " PRIMARY KEY auto_increment" if $this->{autoincrement};
	return $ret;
}

sub sql_drop {
	my ($this) = @_;
	return qq{$QUOTE$this->{name}$QUOTE};
}

# supports postgresql bogus multi-word types explicitly by name!
# this is not good
# I wish they'd quote their types with spaces in :(
my $type_pattern = 'character varying|time(?:stamp)? with(?:out)? time zone|double precision|[a-z0-9]+';
# XXX this $type_pattern is duplicated in Constraint.pm
sub sql_parse {
	my ($this, $sql) = @_;
	$this = $this->new unless ref $this;
	$$sql =~ s/^\s+//s;

	if ($$sql =~ s/^($type_pattern)(?:\s*\(\s*(([\d,\s]|'(\\'|[^'])*')+)\s*\))?//sio) {
		my ($type, $size) = ($1, $2);

		if ($$sql =~ s/^\s+binary//si) {
			$type .= " binary";
		}

		$this->type(lc $type);
		if ($this->type eq "enum") {
			$this->range($size);
		} else {
			$this->size($size);
		}
		
		$this->null(0) if $$sql =~ s/^\s*not\s+null//si; # duplicated

		my $default;
		if ($$sql =~ s/^\s+default\s+"((\\"|[^"\n])*)"(::($type_pattern))?//si ||
		    $$sql =~ s/^\s+default\s+'((\\'|[^'\n])*)'(::($type_pattern))?//si ||
		    $$sql =~ s/^\s+default\s+((\([^)]*\)|[^, \(\)\n])*)(::($type_pattern))//si ||
		    $$sql =~ s/^\s+default\s+((\([^)]*\)|[^, \(\)\n])*)//si) {
			$default = $1;
			# TODO cope with nested parentheses?
		}

		$this->null(0) if $$sql =~ s/^\s*not\s+null//si; # duplicated

		$this->autoincrement(1) if $$sql =~ s/^\s*auto_increment//si;

		if (defined $default) {
			unless ($this->null ? $default eq "NULL" : # XXX this is somewhat dodgy,
								   # if anyone had a default of 'NULL'
								   # instead of NULL, we'd miss it ??
			    $default eq "" || $default =~ /^[-0: \.]*$/ &&
				($this->numeric || $this->date_or_time)) {
				$this->default($default);
			}
		}
	} else {
		die "parse error: field has no type";
	}
	return $this;
}

my %field_cache_types;
my %field_cache_sqltypes;

sub realize {
	my ($this) = @_;
	$this->$_(undef) for qw(description title links key format metadata_multi metadata_field);
	$this->_abstract_realize("realize");
}

sub abstract {
	my ($this) = @_;
	$this->_abstract_realize("abstract");
}

sub _abstract_realize {
	my ($this, $ar) = @_;

	my $method = "_$ar";
	(my $imperf = $ar) =~ s/e?$/ing/;

	my $old_sqltype = $this->sql_type;
	my ($old_type, $old_size) = ($this->type, $this->size);
	my ($new_type, $new_size) = $this->$method(lc $this->type, $this->size);

	if (defined $new_type) {
		$this->type($new_type);
		$this->size($new_size);
		my $new_sqltype = $this->sql_type;

		my $sizeeq = defined $old_size == defined $new_size && ( ! defined $old_size || $old_size eq $new_size );
		if ($old_type ne $new_type && $sizeeq && ! $field_cache_types{$ar}{"$old_type $new_type"} ||
		    ! $sizeeq && ! $field_cache_sqltypes{$ar}{"$old_sqltype $new_sqltype"}) {
			my ($old, $new);
			if ($sizeeq) {
				$field_cache_types{$ar}{"$old_type $new_type"} = 1;
				$old = $old_sqltype;
				$new = $new_sqltype;
				s/\(\d+\)/(*)/ for ($old, $new);
			} else {
				$field_cache_sqltypes{$ar}{"$old_sqltype $new_sqltype"} = 1;
				$old = $old_sqltype;
				$new = $new_sqltype;
			}
			comment("$imperf type `$old' as `$new'");
		}
	}

	$this->recurse();
}

sub _abstract { return; }

sub _realize { return; }

# FIXME this `numeric' predicate may be incomplete!

sub numeric {
	my ($this) = @_;
	return scalar($this->{type} =~ /^(int(eger)?|real|double( precision)?|float|number|decimal|numeric|bool(ean)?|(tiny|small|medium)int)$/);
}

sub datetime {
	my ($this) = @_;
	return scalar($this->{type} =~ /^(datetime|timestamp( with(out)? time zone)?)$/);
}

sub date {
	my ($this) = @_;
	return scalar($this->{type} =~ /^(date)$/);
}

sub time {
	my ($this) = @_;
	return scalar($this->{type} =~ /^(time( with(out)? time zone)?)$/);
}

sub date_or_time {
	my ($this) = @_;
	return $this->datetime || $this->date || $this->time;
}

# this is a function, with a bogus package param... :/

my $warned_bogus_date = 0;
sub fix_date {
	my ($pkg, $date) = @_;
	if ($date =~ /^0{14}$/ or $date eq "0000-00-00 00:00:00") {
		comment("converting bogus date 0000-00-00 to 0001-01-01") unless $warned_bogus_date ++;
		$date = "0001-01-01 00:00:00";
	} elsif ($date =~ /^0{8}$/ or $date eq "0000-00-00") {
		comment("converting bogus date 0000-00-00 to 0001-01-01") unless $warned_bogus_date ++;
		$date = "0001-01-01";
	} else {
		$date =~ s/^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/$1-$2-$3 $4:$5:$6/;
		# or $date =~ s/^(\d\d\d\d)(\d\d)(\d\d)$/$1-$2-$3/
		# or $date =~ s/^(\d\d)(\d\d)(\d\d)$/$1:$2:$3/
		# I don't think mysql ever returns dates or times that match
		# those commented out patterns.
	}
	return $date;
}

1
