#!/usr/bin/perl

#----------------------------------------------------------------
# ars-gen-subclass
#
# queries ARS and generates a subclass module from a schema.  The
# parameter '-e' can be used to specify an existing subclass module
# to be 'edited', which really means the old subclass module is read
# beforehand and customizations are noted and inserted into the new
# subclass module.
#
# Things preserved by edit-mode:
# 1. package name
# 2. the 'query' value for individual fields
# 3. all methods between the 'START CUSTOMIZATION' and 'END CUSTOMIZATION'
#    markers
#----------------------------------------------------------------

use FileHandle;

use ARS;
use ArsBaseClass;

#----------------------------------------------------------------
# make sure you have set $ARSUSER, $ARSPASS, or $ARSSERVER in.
# ArsBaseClass.pm properly.
# ars-gen-subclass uses the CTL object from ArsBaseClass.pm
# change the corresponding variables there.
#----------------------------------------------------------------

my $BASECLASSNAME = 'ArsBaseClass';
my $MODIFY_TIME = 6;

my $DEBUG = 0;
my $CTL;

my $METHOD_STYLE = 'us';		# can be 'us' or 'ucfirst'
								# us = underscore: this_is_a_method_name
								# ucfirst = uppercase first: thisIsAMethodName

$query_field = 'undef,	# EDIT ME';
$query_field2 = 'undef,	# EDIT ME';

my $comment_block = <<_EOF_;
#----------------------------------------------------------------
# the CLASS_DATA structure was generated automatically using
# "ars-gen-subclass".  It has many porpoises:
#
# 1. it maps my private field-keys to the official ones
#	(example: private = "status_confirmed", official = "Status Confirmed")
#
# 2. it describes the fields as ARS knows them.  This makes it
#	possible to perform a "sanity check" later as insurance that
#	the ARS data-structure hasn't been secretly changed.
#
# 3. it determines whether fields will be retrieved during a query.
#	This is controlled, oddly enough, by setting "query => 1" to
#	retrieve.
#
# the keys to the hash are as follows:
#	
#	schema	=> 'the-name-of-the-schema',
#	query_field => 'the fieldname to be used for finding a single record',
#	query_field2 => 'the second fieldname to be used for finding a record',
#	priv_keys => {
#		"private-key" => {
#			real	=> "real-key",
#			id		=> ARS-field-id,
#			type	=> (char/enum/time/diary),
#			query	=> 0|1,
#		}
#	},
#
#	# this part is generated automatically
#	reverse_map => {
#		'ARS-field-id'	=> 'private-key',
#	}
#
# if type is "enum", there is an additional hash-key "enum":
#		enum => {
#			"private-enum-val-1"	=> [ internal-position, "ARS-name" ],
#			"private-enum-val-2"	=> [ internal-position, "ARS-name" ],
#			"private-enum-val-n"	=> [ internal-position, "ARS-name" ],
#		}
#
# CHANGES:
#
# 7-MAY-2004:
#
# - added default function "query()" to generated class to
#   allow generic (sort-of) queries
# - generated class now contains start/end markers for customized
#   code.
# - added ability to "edit" an existing generated class file, which
#   really means the old class file is read and the "interesting"
#   information is saved to re-generate the class:
#    - package name
#    - the designated query_field
#    - the "query" settings for all fields
#    - any customized code
#----------------------------------------------------------------
_EOF_

$edit	= undef;
$backup	= 0;

while($_ = shift) {
	if (/^-e/) {
		$edit = shift;
	} elsif (/^-b/) {
		$backup = 1;
	} elsif (!$schema) {
		$schema = $_;
	} else {
		die "usage: $0 [-b] [-e <subclass-to-edit>] schema\n";
	}
}

if (!$schema) {
	exit;
}

if ($edit) {
	(-e $edit) || die "file [$edit] not found\n";
	if ($backup) {
		backupFile($edit);
	}
	$fh = FileHandle->new($edit);
	defined($fh) || die "open of [$edit] for reading failed\n";
	$saving = 0;
	$in_struct = 0;
	while(<$fh>) {
		$DEBUG && print "DBG> $_";
		if ($in_struct) {
			if (/^};/) {
				$in_struct = 0;
				next;
			}
			if (/^\s+query_field\s+=>\s+([^,]+,)(\s+#\s*EDIT\s+ME)?\s*$/) {
				$query_field = $1;
			}
			if (/^\s+query_field2\s+=>\s+([^,]+,)(\s+#\s*EDIT\s+ME)?\s*$/) {
				$query_field2 = $1;
			}
			if (/^\t\t'([^']+)'\s+=>\s+{/) {
				$curr_field = $1;
				$DEBUG && print "curr_field = [$curr_field]\n";
			}
			if (/^\t\t\tquery\s+=>\s+(\d+),/) {
				$query_values{$curr_field} = $1;
				$DEBUG && print "saving query{$curr_field} = $1\n";
			}
		} else {
			if (/^my \$CLASS_DATA = {/) {
				$in_struct = 1;
				next;
			}
			if (/^package\s+(\S+);/) {
				$old_package = $1;
			}
		}
		if ($saving) {
			if (/^#\sEND\sCUSTOMIZATION/) {
				$saving = 0;
				$DEBUG && print " -stop saving-\n";
				last;
			}
			$DEBUG && print " -saving-\n";
			$customized .= $_;
		} else {
			if (/^#\sSTART\sCUSTOMIZATION/) {
				$DEBUG && print " -start saving-\n";
				$saving = 1;
			}
		}
	}
	$fh->close;
}

$CTL = ArsBaseClass::_arsControl;

# get field info

(%fields = ars_GetFieldTable($CTL, $schema)) || 
	die "schema [$schema] seems not to exist.\n";

$package = packageName($schema);

if ($edit) {
	$fh = FileHandle->new($edit, 'w');
} else {
	$fh = FileHandle->new;
	open($fh, '>&STDOUT') || die "can't dup stdout";
}

if ($edit) {
	print $fh "package ${old_package};\n\n";
} else {
	print $fh "package ${package};	# EDIT ME\n\n"
}

print $fh "use $BASECLASSNAME;\n\n\@ISA = '$BASECLASSNAME';\n\n"
	."$comment_block\n\n"
	."my \$CTL = undef;\n"
	."my \$ARSSERVER = undef;\nmy \$ARSUSER = undef;\nmy \$ARSPASS = undef;\n\n"
	."my \$CLASS_DATA = {\n"
	."\tschema => '$schema',\n"
	."\tquery_field => $query_field\n"
	."\tquery_field2 => $query_field2\n"
	."\tpriv_keys => {\n";

foreach $field (sort sortById keys(%fields)) {
	($finfo = ars_GetField($CTL, $schema, $fields{$field})) || die $arr_errstr;
	$type = $finfo->{dataType};
	$DEBUG && print STDERR "FIELD: $field, type=[$type]\n";
	if ($type =~ /^(control|trim|page|table)$/) {
		$DEBUG && print STDERR "is control/trim/page/table, skipping.\n";
		next;
	}
	$key = normalize($field, 'field');
	my $real = $field;
	$real =~ s/'/\\'/g;
	if ($edit && exists($query_values{$key})) {
		$query = $query_values{$key};
	} else {
		$query = ($type eq 'diary') ? 0 : 1;
	}

	if ($key eq 'write') {
		print "CONFLICT! you have a field named \"write\", which conflicts\n";
		print "with an existing method.  Renaming to \"write_conflict\"\n";
		$key = 'write_conflict';
	}

	my $gui_label = getGuiLabel($finfo);
	$gui_label =~ s/'/\\'/g;

	print $fh "\t\t'$key'	=> {\n"
		."\t\t\treal\t=> '$real',\n"
		."\t\t\tid\t\t=> '$fields{$field}',\n"
		."\t\t\ttype\t=> '$type',\n"
		."\t\t\tquery\t=> $query,\n"
		."\t\t\tgui_label\t=> '$gui_label',\n";
		#."\t\t\tquery\t=> 0,\n";
	if ($type eq 'enum') {
		print $fh "\t\t\t# '$field' is of type enum, (special handing)\n";
		print $fh "\t\t\tenum => {\n";
		#if ($#{$finfo->{limit}} == 0) {
		exists($finfo->{limit}->{enumLimits}) ||
			die "I'm not sure what to do with non-regularLists of enums";
		my @values = @{$finfo->{limit}->{enumLimits}};
		if ($#values == 0) {
			print $fh "\t\t\t\t'yes'	=> [ 0, '$values[0]' ],\n";
		} else {
			$ind = 0;
			foreach $val (@values) {
				$ekey = normalize($val);
				$val =~ s/'/\\'/g;
				print $fh "\t\t\t\t'$ekey'	=> [ $ind, '$val' ],\n";
				$ind++;
			}
		}
		print $fh "\t\t\t},\n";
	}
	print $fh "\t\t},\n";
}
print $fh "\t},\n};\n\n";

print $fh "# initialization\n${BASECLASSNAME}::init(\$CLASS_DATA);\n\n";

print $fh <<_EOF_;
sub new
{
	my \$proto = shift;
	my \$class = ref(\$proto) || \$proto;

	my \@args;
	if (!grep(/^CTL\$/, \@_) && \$CTL) {
		push(\@args, 'CTL', \$CTL);
	}

	my \$self = \$class->SUPER::new(\@args, \@_);
	if (!defined(\$self)) { return undef; }

	bless(\$self, \$class);
}

INIT {
	my \@params;
	\$ARSSERVER && push(\@params, SERVER => \$ARSSERVER);
	\$ARSUSER && push(\@params, USER => \$ARSUSER);
	\$ARSPASS && push(\@params, PASS => \$ARSPASS);
	if (\@params) {
		\$CTL = ArsBaseClass::login(\@params);
	}
}

sub import
{
	shift; # get rid of \$class

	my \$word;
	while (\$word = shift) {
		if (\$word eq 'USER') {
			\$ARSUSER = shift;
		} elsif (\$word eq 'PASS') {
			\$ARSPASS = shift;
		} elsif (\$word eq 'SERVER') {
			\$ARSSERVER = shift;
		}
	}
}

sub _getClassData
{
	\$CLASS_DATA;
}

sub schemaChanged
{
	return ${BASECLASSNAME}::schemaChanged(\$CLASS_DATA);
}

sub query
{
	my \@result = ArsBaseClass::query(\$CLASS_DATA, \@_);

	if (\@result) {
		return wantarray ? \@result : \$result[0];
	}

	return wantarray ? () : undef;
}

# START CUSTOMIZATION
${customized}# END CUSTOMIZATION

1;
_EOF_

exit;

sub sortById
{
	return $fields{$a} <=> $fields{$b};
}

#--------------------------------------------
# generates package name from schema name
#--------------------------------------------
sub packageName
{
	my $schema = shift;

	$schema =~ s/([a-z])([A-Z])/$1 $2/g;
	$schema =~ tr/A-Z/a-z/;
	$schema =~ s/^\s*//;			# remove WS at beginning
	$schema =~ s/\s*$//;			# remove WS at end
	$schema =~ s/[^a-z0-9 ]+/ /g;	# substitute WS for all non-word chars
	my @f = split(' ', $schema);
	my $package = join('', map(ucfirst($_), @f));

	$package;
}

sub normalize
{
	my $str = shift;
	my $use = shift;

	$str =~ s/([a-z])([A-Z])/$1 $2/g;
	$str =~ tr/A-Z/a-z/;
	$str =~ s/^\s*//;			# remove WS at beginning
	$str =~ s/\s*$//;			# remove WS at end
	if (($use eq 'field') && ($METHOD_STYLE eq 'ucfirst')) {
		$str =~ s/[^a-z0-9 ]/ /g;	# substitute WS for all non-word chars
		my ($first, @rest) = split(' ', $str);
		$str = join('', $first, map(ucfirst($_), @rest));
	} else {
		$str =~ s/[^a-z0-9_ ]/ /g;	# substitute WS for all non-word chars
		$str =~ s/\s+/_/g;			# condense multiple WS chars to single "_"
		$str =~ s/_*$//g;			# remove trailing underscores
	}

	$str;
}

sub backupFile
{
	my $file = shift;

	my $suffix = '';
	my $name = "${file}.bak$suffix";
	while(-e $name) {
		$suffix++;
		$name = "${file}.bak$suffix";
	}

	my $cmd = "cp $file $name";
	if (system($cmd)) {
		die "backupFile: cmd $cmd failed";
	}
}

sub getGuiLabel
{
	my $finfo = shift;

	# {displayInstanceList}->{dInstanceList}->[0]->{props}->[0]

	exists($finfo->{displayInstanceList})					|| return undef;
	(ref($finfo->{displayInstanceList}) eq 'HASH')			|| return undef;
	exists($finfo->{displayInstanceList}->{dInstanceList})	|| return undef;
	(ref($finfo->{displayInstanceList}->{dInstanceList}) eq 'ARRAY')|| return undef;
	exists($finfo->{displayInstanceList}->{dInstanceList}->[0])	|| return undef;
	exists($finfo->{displayInstanceList}->{dInstanceList}->[0]->{props})
		|| return undef;
	(ref($finfo->{displayInstanceList}->{dInstanceList}->[0]->{props}) eq 'ARRAY')
		|| return undef;
	foreach my $elem (@{$finfo->{displayInstanceList}->{dInstanceList}->[0]->{props}}) {
		(ref($elem) eq 'HASH') || die "expected ref to be HASH";
		if ($elem->{prop} == 20) {			# AR_DPROP_LABEL
			return $elem->{value};
		}
	}
}