=head1 DemogTrak.pm - top-level module for manipulating DemogTrak databases.

=cut

=head1 USAGE:

=over 4

use DemogTrak;

$ch = new Channel;   # connect to the postgres backend. No arguments.

$me = new Person;    # create a new Person object...
$me = new Person(\%hash); # or create one with the info in %hash.

$me->fill(\%hash);   # fill an existing Person object with the info in %hash.

$me = get Person($where, $ch) #return (the first) Person that matches $where.
@we = get Person($where, $ch) #return an array of Persons that match $where.

Person->put($ch);    # add or update Person's record, return the id.
When using the put method, keys beginning with an underscore (_) are
ignored. This allows you to put junk in a record that won't ever be
inserted into the database.  As a convenience, an Event record 
provides eight such entries, _spec1name through _spec8name, which 
are the specs from the event type for that event.


for all of the above, substitute for Person:
Event
EventType
FundingSource

=cut

$SIG{'__WARN__'} = sub { 
  return if $_[0] =~ /uninitialized/;
  warn "DemogTrak message: $_[0]";
};
unless ($^O =~ /win/i) {
  open(STDERR, '| /home/davis/app2/dt2/log.pl') || die "Ouch! $!\n";
}

package DemogTrak;
require Exporter;
@ISA=qw/Exporter/;
@EXPORT_OK=qw/Getname Shortdate now dtWarn safeTeX dispatch min/;

sub Getname {
  my $id = shift;
  my $person = Person->getfromid($id, new Channel);
  return $person->namestring;
}

sub Shortdate {
  #take a postgres-style date, return a short date.
  return '' unless defined $_[0];
  my($dy,$month,$day,$time,$year,$tz) = split(/\s+/, $_[0]);
  return "$month $day, $year";
}

sub now {
  #return the postgres system time.
  my $dbh = new Channel;
  my $sth = $dbh->prepare('SELECT now()');
  $sth->execute;
  my $now = $sth->fetchrow_arrayref;
  if ($now) {
    return $now->[0];
  } else {
    return undef;
  }
}

sub safeTeX {
  my @in = @_;
  my $debug = 0;
  foreach my $in (@in) {
    $debug && warn "safeTeX: in is $in";
    $in =~ s/([&\#%\$])/\\$1/g;
    $debug && warn "safeTeX: out is $in";
  }
  return @in;
}

sub dispatch {
  my $script = shift;
  $script .= ' debug' if $Channel::_debug;
  $script .= ' trace' if $Channel::_trace;
  warn "dispatch $script" if $Channel::_debug;
  system("perl $script &");
}

sub min {
  my $min=$_[0];
  $min > $_ and $min = $_ foreach @_;
  return $min;
}

1;

package Channel;
use DBI;
use vars qw/$_debug $channel $user $pw $_trace/;

sub new {
  return $Channel::channel if $Channel::channel;
  my $mod = shift;
  my $Rparam = shift;
  if (ref $Rparam eq 'HASH') {
    $Channel::user = $Rparam->{user} if exists $Rparam->{user};
    $Channel::_trace = $Rparam->{trace} if exists $Rparam->{trace};
    $Channel::_debug = $Rparam->{debug} if exists $Rparam->{debug};
  }
  $Channel::_debug && warn 'Channel::new';
  $Channel::user = getlogin unless $Channel::user;
  return undef unless $Channel::user;
  if ($^O =~ /win/i) { #windows user
     my $pw;
     print 'Enter postgres password: ';
     chomp($pw = <STDIN>);
     $Channel::pw = $pw;
     $dbh=DBI->connect('dbi:Pg:dbname=demogdata;host=davis.demog.berkeley.edu',
		       $Channel::user, $Channel::pw);
  } else {
    $dbh = DBI->connect("dbi:Pg:dbname=demogdata", $Channel::user);
  }
  $dbh->trace($Channel::_trace) if $Channel::_trace;
  $Channel::channel = $dbh;
  return $dbh;
}

1;

package Record;
# generic class Record for consolidating classes.

sub _table {
# returns the appropriate table for a record
  my $rec = shift;
  my $type;
  if (ref($rec)) {
    $type = ref($rec);
  } else {
    $type = $rec;
  }
  my %tables = ( Person        => 'personal_data' ,
		 Event         => 'event_detail' ,
		 EventType     => 'event_universe' ,
		 FundingSource => 'funding_universe' );
  return $tables{$type};
}

sub _id {
# returns the unique id field for the record's table
  my $rec = shift;
  my $type;
  if (ref($rec)) {
    $type = ref($rec);
  } else {
    $type = $rec;
  }
  my %ids =    ( Person        => 'id' ,
		 Event         => 'event_id' ,
		 EventType     => 'eventtypeid' ,
		 FundingSource => 'sourceid' );
  return $ids{$type};
}

sub _defined_fields {
  #returns an array of fields that are not undef in a record.
  my $rec = shift;
  my @out;
  foreach (keys %$rec) {
    push(@out,$_) if defined $rec->{$_};
  }
  return @out;
}

sub _missing_fields {
  my $rec = shift;
  my @missing;
  foreach ($rec->required) {
    push(@missing,$_) unless defined $rec->{$_};
  }
  return @missing;
}

sub fill {
  $Channel::_debug && warn "fill: @_";
  my $record = shift;
  my $data = shift;
  my $noclobber = shift;
  return $record unless $data;
  foreach (keys %{$data}) {
    if (exists $data->{$_}) {
      if ($noclobber) {
	$record->{$_} = $data->{$_} unless defined $record->{$_};
      } else {
	$record->{$_} = $data->{$_};
      }
    }
  }
  return $record;
}

sub put {
  $Channel::_debug && warn "put: @_";
  my $record = shift;
  my $dbh = new Channel;
  my $sql;
  my $type = ref($record);
  if ($type eq 'Person' or
      $type eq 'Event') {
    $record->{updated} = $Channel::user . ' ' . DemogTrak::now;
  }
  my $id = $record->_id;
  my $table = $record->_table;
  my @fields = $record->_defined_fields;
  if ($record->{$id}) {
    return -2 if @fields < 2;
    # we're editing an existing record
    $sql = "UPDATE $table SET ";
    foreach (keys %{$record}) {
      next if /^$id/i or /^_/;
      if ((defined $record->{$_}) and ($record->{$_} !~ /^\s$/)) {
	$sql .= ', ' unless $sql =~ /SET\s+$/;
	$sql .= "$_ = " . $dbh->quote($record->{$_});
      }
    }
    $sql .= " WHERE $id = " . $record->{$id};
    print STDERR "$sql\n";
    if ($dbh->prepare($sql)->execute) {
      return $record->{$id};
    } else {
      return undef;
    }
  } else {
    # we're adding a new record
    my @missing = $record->_missing_fields;
    if (@missing) {
      print STDERR qq{ERROR: The following fields are required to save:\n};
      print STDERR qq{\t@missing\n};
      return 0;
    }
    return -2 if @fields < 1;
    $sql = "INSERT INTO $table (";
    my @keys;
    foreach (sort grep(!/^_/, keys %{$record})) {
      push(@keys, $_) if defined $record->{$_};
    }
    $sql .= join(', ', @keys);
    $sql .= ') VALUES (';
    foreach (@keys) {
      next unless defined $record->{$_};
      $sql .= ', ' unless $sql =~ /\($/;
      $sql .= $dbh->quote($record->{$_});
    }
    $sql .= ')';
    print STDERR "$sql\n";
    if ($dbh->prepare($sql)->execute) {
      my $idh = $dbh->prepare(qq{SELECT currval('${table}_${id}_seq')});
      $idh->execute;
      my $id = $idh->fetchrow_arrayref->[0];
      return $id;
    } else {
      return undef;
    }
  }
}

sub get {
  # get a record from a where string. Trusts the where string.
  # Usually not called directly.
  $Channel::_debug && warn "get: @_";
  my $mod = shift;
  my $where = shift;
  my $dbh = shift;
  my $order = shift;
  $dbh = new Channel;
  my $foo = {};
  my $type = ref($mod);
  my $id = $mod->_id;
  my $table = $mod->_table;
  my (@out, $err);
  # connect to the db and get a hashref.
  my $sql = "SELECT * FROM $table";
  $sql .= " WHERE $where" if $where;
  $sql .= " ORDER BY $order" if $order;
  print STDERR "$sql\n";
  my $sth = $dbh->prepare($sql);
  $sth->execute;
  my @datefields;
  for my $i (1..$sth->{NUM_OF_FIELDS}) { #Checking for date fields to shorten
    push(@datefields,$sth->{NAME}->[$i-1]) if $sth->{TYPE}->[$i-1] == 1184;
  }
  my $Rrecords = $sth->fetchall_arrayref($foo);
  if ($sth) {
    foreach (@{$Rrecords}) {
      foreach my $field (@datefields) {
	$_->{$field} = DemogTrak::Shortdate($_->{$field});
      }
      push(@out, $mod->new($_));
    }
    wantarray ? return @out : return $out[0];
  } else {
    print STDERR "ERROR: ", $sth->errstr, "\n";
    return (0, $sth->errstr)
  }
}

sub reget {
  # insert a record based on where into an existing record's hash. Returns
  #  first record found.
  $Channel::_debug && warn "reget: @_";
  my $mod = shift;
  my $type = ref $mod;
  $type = $mod unless ref $mod;
  my $newrec = $type->get(@_);
  foreach (keys %$mod) {
    delete $mod->{$_} unless exists $newrec->{$_};
  }
  $mod->{$_} = $newrec->{$_} foreach keys %$newrec;
  return $mod;
}

sub renew {
  #insert a blank record of type mod into existing hash; populate if
  # appropriate.
  $Channel::_debug && warn "renew: @_";
  my $mod = shift;
  my $type = ref $mod;
  $type = $mod unless ref $mod;
  my $newrec = $type->new(@_);
  foreach (keys %$mod) {
    delete $mod->{$_} unless exists $newrec->{$_};
  }
  $mod->{$_} = $newrec->{$_} foreach keys %$newrec;
  return $mod;
}

sub getfromid {
  $Channel::_debug && warn "getfromid: @_";
  my $mod = shift;
  my $id = shift;
  return $mod->new() unless $id;
  my $dbh = new Channel;
  my $idfield = $mod->_id;
  my $where = "$idfield = $id";
  return $mod->get($where,$dbh);
}

sub regetfromid {
  $Channel::_debug && warn "regetfromid: @_";
  my $mod = shift;
  my $id = shift;
  my $dbh = new Channel;
  my $idfield = $mod->_id;
  my $where = "$idfield = $id";
  return $mod->reget($where,$dbh);
}

sub _lc {
  # make all keys lowercase
  $Channel::_debug && warn "_lc: @_";
  my $rec = shift;
  foreach my $field (keys %$rec) {
    delete $rec->{$field} unless (defined $rec->{$field} and
				  $rec->{$field} !~ /^\s*$/);
    my $newfield = lc $field;
    $newfield =~ s/(?:^\s*)|(?:\s*$)//g;
    unless ($newfield eq $field) {
      $rec->{$newfield} = $rec->{$field};
      delete $rec->{$field};
    }
  }
  return $rec;
}

sub diff {
  $Channel::_debug && warn "diff: @_";
  my $oldrec = shift;
  my $newrec = shift;
  $oldrec->_lc;
#  $newrec->_lc;
  my $type = ref $newrec;
  return undef unless ref ($oldrec) eq $type;
  my $idfield = $oldrec->_id;
  my $diffrec = $type->new({$idfield => $oldrec->{$idfield}});
  foreach my $field (keys %{$newrec}) {
    next unless defined $newrec->{$field};
    next if $field eq $idfield;
    if ((not defined $oldrec->{$field}) or
	($oldrec->{$field} ne $newrec->{$field}) ) {
      $diffrec->{$field} = $newrec->{$field};
    }
  }
  return $diffrec->_lc;
}

sub dumpout {
  my $rec = shift;
  print STDERR 'Dumping a ', ref($rec), "\n";
  foreach (sort keys %$rec) {
    print STDERR "$_  =>  $$rec{$_}\n";
  }
}

package Person;
@ISA=qw/Record/;

sub new {
  my $mod = shift;
  my %self;
  foreach (qw/
	   id
	   last_name
	   first_name
	   mi
	   institution
	   printinst
	   title
	   printtitle
	   addressa1
	   addressa2
	   campusa
	   campuscodea
	   citya
	   statea
	   zipa
	   countrya
	   addressb1
	   addressb2
	   campusb
	   campuscodeb
	   cityb
	   stateb
	   zipb
	   countryb
	   addressc1
	   addressc2
	   campusc
	   campuscodec
	   cityc
	   statec
	   zipc
	   countryc
	   useaddress
	   e_mail
	   home_phone
	   office_phone
	   office_ext
	   other_phone
	   other_ext
	   fax
	   ssn
	   sid
	   eid
	   sex
	   birthdate
	   faculty
	   exfaculty
	   student
	   exstudent
	   staff
	   exstaff
	   bacpop
	   brownbag
	   list1
	   list2
	   list3
	   list4
	   list5
	   list6
	   list7
	   list8
	   list9
	   list0
	   created
	   updated /) {
    $self{$_} = undef;
  }
  $person = \%self;
  bless $person, 'Person';
  $person->fill($_[0]) if $_[0];
  return $person;
}

sub required {
  return qw(first_name last_name);
}

sub namestring {
  my $person = shift;
  my $out = $person->{first_name};
  $out .= ' ' . $person->{mi} . ' ' if $person->{mi};
  $out .= ' ' . $person->{last_name};
  $out = '(New Record)' unless $out;
  return $out;
}

sub instline {
  my $person = shift;
  my $out = '';
  if ($person->{printtitle}) {
    $out .= $person->{title};
  }
  if ($person->{printinst}) {
    $out .= ', ' if $out;
    $out .= $person->{institution};
  }
  return $out;
}

1;

package Event;
@ISA=qw/Record/;

sub new {
  my $mod = shift;
  my %event;
  foreach ( qw/
	    event_id
	    eventtypeid
	    id
	    date_effective
	    date_expires
	    expected
	    title
	    sourceid
	    cost
	    spec1
	    spec2
	    spec3
	    spec4
	    spec5
	    spec6
	    spec7
	    spec8
	    comments
	    current_interests
	    updated
	    override
	    expected / ) {
    $event{$_} = undef;
  }
  my $event = \%event;
  bless $event, 'Event';
  $event->fill ($_[0]);
  return $event;
}

sub required {
  my $rec = shift;
  my @req = qw(eventtypeid id date_effective);
  $rec->getspecnames unless exists $rec->{_spec1req};
  foreach (1..8) {
    push(@req, "spec$_") if (defined $rec->{"_spec${_}req"} &&
			     $rec->{"_spec${_}req"});
  }
  return @req;
}

sub get {
  # make the default order reverse date.
  my ($mod,$where,$dbh,$order) = @_;
  $order = 'date_effective DESC' unless $order;
  return Record::get($mod,$where,$dbh,$order);
}

sub getspecnames {
  # add the _spec?name keys to an Event hash.
  my $event = shift;
  if (defined $event->{eventtypeid}) {
    my $ch = new Channel;
    my $type = getfromid EventType($event->{eventtypeid},$ch);
    for (1..8) {
      $event->{"_spec${_}name"} = $type->{"spec${_}name"};
      $event->{"_spec${_}type"} = $type->{"spec${_}type"};
      $event->{"_spec${_}req"} = $type->{"spec${_}req"};
    }
    $event->{_event_name} = $type->{event_name};
  } else {
    $event->{"_spec${_}name"} = undef for 1..8;
  }
  return $event;
}

sub fill {
  #this modification to the Record::fill sub includes the spec
  # name types from eventtype.  Just a convenience, really. They
  # end up in $event->{_event?name} where ? is 1..8.
  my $event = shift;
  my $data = shift;
  Record::fill($event,$data);
  return $event->getspecnames;
}

sub htmlline {
  my $event = shift;
  my $out = $event->{date_effective};
  $out .= '-' . $event->{date_expires} 
    if $event->{date_expires};
  $out .= ' (<STRONG>Expected</strong>)' if $event->{expected};
  $out .= ': ' . $event->{_event_name} . ': ';
  foreach (1..8) {
    if (exists $event->{"_spec${_}name"} and
	defined $event->{"_spec${_}name"}) {
      $out .= $event->{"_spec${_}name"} . ': ';
      if (exists $event->{"spec$_"} and
	  defined $event->{"spec$_"}) {
	$out .= $event->{"spec$_"} . '. ';
      } else {
	$out .= '<STRONG>***MISSING***</STRONG> ';
      }
    }
  }
  $out .= '<BR>Title: ' . $event->{title} if $event->{title};
  return $out;
}

sub latexline {
  my $debug = 0;
  my $event = shift;
  my $out = $event->{_event_name} . "\n";
  my $specs = 0;
  $out .= '\\\\Title: ' . $event->{title} if defined $event->{title};
  foreach (1..8) {
    if (exists $event->{"_spec${_}name"} and
	defined $event->{"_spec${_}name"}) {
      unless ($specs) {
	$out .= "\\begin{itemize}\n";
	$specs = 1;
      }
      $out .= '\\item ' . $event->{"_spec${_}name"} . ': ';
      if (exists $event->{"spec$_"} and
	  defined $event->{"spec$_"}) {
	$out .= $event->{"spec$_"};
      } else {
	$out .= 'missing. ';
      }
      $out .= "\n";
    }
  }
  $out .= "\\end{itemize}\n" if $specs;
  return $out;
}

sub lineout {
  #depracated.
  return latexline(@_);
}

sub _oldlineout {
  my $event = shift;
  my $dbh = new Channel;
  my ($sth, $out, $i);
  $sth=$dbh->prepare
    ('SELECT ' .
     'spec1name, spec2name, spec3name, spec4name, ' .
     'spec5name, spec6name, spec7name, spec8name, ' .
     'event_name ' .
     'FROM event_universe WHERE eventtypeid = ' .
     $event->{eventtypeid});
  $sth->execute;
  my %specs = %{$sth->fetchrow_hashref};
  $out = $specs{event_name} . ": \\\\\n";
  foreach (keys %specs) {
    next unless (/^spec/ && ($specs{$_}));
    my $spec = $_;
    $spec = $1 if $spec =~ /(.*)name$/;
    if (exists $event->{$spec}) {
      $out .= $specs{$_} . ': ' . $event->{$spec} . '. ';
    } else {
      $out .= $specs{$_} . ': missing. ';
    }
  }
  return $out;
}

1;

package EventType;
@ISA=qw/Record/;

sub new {
  my $mod = shift;
  my $type;
  my %self;
  foreach (
	   'eventtypeid',
	   'oldeventtypeid',
	   'event_name',
	   'event_group',
	   'spec1name',
	   'spec2name',
	   'spec3name',
	   'spec4name',
	   'spec5name',
	   'spec6name',
	   'spec7name',
	   'spec8name',
	   'spec1type',
	   'spec2type',
	   'spec3type',
	   'spec4type',
	   'spec5type',
	   'spec6type',
	   'spec7type',
	   'spec8type',
	   'spec1req',
	   'spec2req',
	   'spec3req',
	   'spec4req',
	   'spec5req',
	   'spec6req',
	   'spec7req',
	   'spec8req',
	   'studentstatus',
	   'applicantstatus',
	   'funded',
	   'exclusive',
	   'isunique',
	   'funded',
	   'collective',
	   'isunique'
	  ) {
    $self{$_} = undef;
  }
  $type = \%self;
  bless $type, 'EventType';
  $type->fill($_[0]) if $_[0];
  return $type;
}

sub required {
  return qw(event_name);
}

1;

package FundingSource;
@ISA=qw/Record/;

sub new {
  my $mod = shift;
  my %self;
  my $source;
  foreach (qw/
sourceid
acsourceid
source_name
nickname
description
granttitle
grantor
grantset
amount
date_awarded
date_expires
recipient
administering_department
comments
/) {
    $self{$_} = undef;
  }
  $source = \%self;
  bless $source, 'FundingSource';
  $source->fill($_[0]) if $_[0];
  return $source;
}

sub required {
  return qw(source_name);
}

1;