#!/usr/bin/perl -w

BEGIN { select(STDERR); $|=1; select(STDOUT);
        unshift(@INC,($ENV{'POPHOME'}||'@POPHOME@').'/lib')
			unless $ENV{'KUNDE_NO_PERLPATH'};
      }

use utf8;
use strict;
use warnings;
use Umlaut qw(utf8modus textmodus);

# Source: @RPM_PACKAGE_VERSION@-@RPM_PACKAGE_RELEASE@

use Cf qw($DATABASE $POPHOME);
use Dbase::Help;
use Dbase qw(db_handle);

### Analysiert die Datenbankbeschreibung.
### -g generiert die Datenbanktabellen.
### -i initialisiert die Sequenznummern.
### -d einlesen der Datensatzbeschreibung in Tabellen

sub Usage() {
my $vers = '@RPM_PACKAGE_VERSION@-@RPM_PACKAGE_RELEASE@';
	textmodus(\*STDERR);
    die <<END;
Usage: $0 -- baut Datenbankstruktur aus Konfigdatei
         -a      Alias für -g -k -i -d
         -g      generiert die eigentlichen Tabellen
          -e     ... auch wenn die Tabelle schon existiert (GEFAHR!)
          -x     ... auch obsolete Einträge
          -X     ... nicht demnächst-obsolete Einträge
         -i      generiert Sequenznummern für Pseudo-Autoincrement
         -k      generiert ALTER TABLE ... ADD FOREIGN KEY-Statements
         -K      generiert ALTER TABLE ... ADD KEY-Statements
		         (für die von FOREIGN KEYs automagisch angelegten Indices)
         -d      liest Datenbankstruktur auf Konfigdatei in Tabellen ein
         -f XXX  Beschreibungsdatei
         -v      schreibt Datenbankbefehle mit
           -n    ... aber führt sie nicht aus
         -t XXX  Tabellentyp
         -m XXX  verwende XXX als Muster für die folgenden Namen
         -D XXX  verwende XXX als Datenbankpräfix
         Name... nur für diese Tabelle (sonst: alle)

VORSICHT -- führt bei unvorsichtiger Anwendung zu komplettem Datenverlust!

Version: $vers
END
  exit 1;
}

use Getopt::Std;
use vars qw( $opt_h $opt_g $opt_d $opt_i $opt_v $opt_e $opt_X $opt_x $opt_f $opt_t $opt_k $opt_K $opt_n $opt_m $opt_a $opt_D);
getopts("adD:ef:ghikKm:nt:vxX") or Usage;
Usage if $opt_h;
$opt_g=not $opt_g if $opt_a;
$opt_k=not $opt_k if $opt_a;
$opt_i=not $opt_i if $opt_a;
$opt_d=not $opt_d if $opt_a;
Usage if $opt_m and not @ARGV;
warn "Note -- not changing the database\n" unless $opt_n or $opt_g or $opt_d or $opt_i or $opt_k;
$opt_v=0 if $opt_n;
$opt_g=$opt_n=1 if not ($opt_g or $opt_i or $opt_K or $opt_k or $opt_d);
db_handle(DB => $opt_D) if defined $opt_D;

if(defined $opt_t) {
	$opt_t="InnoDB" if $opt_t eq "i";
	$opt_t="MYISAM" if $opt_t eq "m";
	$opt_t="BDB" if $opt_t eq "b";
	$opt_t="engine = $opt_t";
} else {
	$opt_t="";
}

=head1 Name

dbbuild -- baut Datenbankstruktur aus Konfigdatei

=head1 Zusammenfassung

dbbuild -- baut Datenbankstruktur aus Konfigdatei
         -g      generiert die eigentlichen Tabellen
          -e     ... auch wenn die Tabelle schon existiert (GEFAHR!)
          -x     ... auch obsolete Einträge
         -i      generiert Sequenznummern für Pseudo-Autoincrement
         -k      generiert ALTER TABLE ... ADD FOREIGN KEY-Statements
         -d      liest Datenbankstruktur auf Konfigdatei in Tabellen ein
         -f XXX  Beschreibungsdatei
         -v      schreibt Datenbankbefehle mit
         -t XXX  Tabellentyp
         Name... nur für diese Tabelle (sonst: alle)

VORSICHT -- führt bei unvorsichtiger Anwendung zu komplettem Datenverlust!

=head1 Beschreibung

C<dbbuild> generiert aus der textuellen Datenbankbeschreibung in <$POPHOME>
SQL-Befehle, um

=over 4

=item die Datenstrukturen mit Indices anzulegen,

=item für das Datenbankbackup die Satzbeschreibungen einzutragen,

=item und evtl. notwendige Sequenznummern zu initialisieren.

=back

=head2 Optionen

=over 4

=item C<-g>

generiert die eigentlichen Tabellen.

=item C<-e>

generiert auch dann, wenn die Tabelle bereits existiert.

Vorsicht: Damit wird der Inhalt dieser Tabellen gelöscht!

=item C<-x>

als obsolet markierte Spalten werden mitgeneriert.

=item C<-X>

als demnächst-obsolet markierte Spalten werden nicht mitgeneriert.

=item C<-d>

generiert die Datensatzbeschreibungen für die automatische Codegenerierung.
Siehe L<dbdump> und L<dbrestore>.

=item C<-i>

generiert Sequenznummern für Pseudo-Autoincrement.
(Sowas können nunmal nicht alle Datenbanken.)

=item C<-k>

generiert ALTER TABLE ... ADD FOREIGN KEY-Statements.

=item C<-v>

protokolliert die CREATE-TABLE-Datenbankbefehle auf stdout.

=item C<-n>

führt die Datenbankbefehle nicht aus. 

Die Optionen C<-d -v -n> sind äquivalent zu C<-v>.

=item C<-h>

Kurzhilfe.

=item C<Tabellenname> ...

nur für diese Tabellen.

Ohne Angabe von Tabellennamen wird die Datenbank komplett reinitialisiert.

=back

=head1 Daten

=head2 C<$POPHOME/POP-Datenbank>

Diese Datei enthält die komplette Datenbankbeschreibung.

Format: siehe Dateikopf.

=head2 Datenbank

Je nach Konfiguration in C<$POPCONFIG>.

=cut

use constant PD => 'POP-Datenbank';

open IN,
  defined $opt_f ? $opt_f : -d 'kunde'
  && -f './' . PD ? './' . PD : "$POPHOME/" . PD
  or die "Keine Datenbankbeschreibung angegeben oder gefunden\n";
utf8modus(\*IN);

my $cmd = "";
my $ids = "";
my %info;
my %muster;
my %has_idx;
my $maxtid;

$/="";
while(<IN>) {
	if(s/^ID-Liste:\s+//) {
		$ids .= "$_ ";
		next;
	}
	1 while s/\n#.*\n/\n/mg;
	next unless /^Tabelle:\s+(\S+)$/m;
	my $tn = $1;
	$info{$tn} = $_;
	if(/^Tabelle:\s+\S*\{(\S+)\}\S*$/m) {
		die "Für $1 gibt es schon eine Vorlage"
			if exists $muster{$1};
		$muster{$1} = $tn;
	}
}

my $muster;
if($opt_m) {
	die "Eine Vorlage für '$opt_m' existiert nicht!\n"
		unless exists $muster{$opt_m};
	$muster = $muster{$opt_m};
}

sub doit($;$$) {
	my($cmd,$tn,$constr) = @_;
	print "# $cmd\n" if $opt_v;
	print "$cmd;\n" if $opt_n;
	if($constr and not $opt_n) {
		my($tn,$td) = DoFn("show create table $tn");
		return if $td =~ /\`$constr\`/;
	}
	Do "$cmd\n" unless $opt_n;
}

sub dumpi($$$$) {
	my($prefix,$who,$ind,$pref) = @_;
	foreach my $idx(split /\,\s*/,$ind) {
		$idx =~ s/\s+/,/g;
		doit "create$prefix index ${who}_$pref on $who ($idx)" if $opt_g;
		$pref++;
	}
	$pref;
}

sub dumpii($$$) {
	my $ret = "";
	my($tname,$pri,$ind) = @_;

	foreach my $idx(split /\,\s*/,$ind) {
		my $iname;
		$iname = $1 if $idx =~ s/^(\S+):\s+//;
		$idx =~ s/^>>?\S*\s//;
		my $liname = $idx;
		$liname =~ s/ /_/g;
		$idx =~ s/\b([a-z_A-Z][-_a-zA-Z0-9]+)\b/`$1`/g;
		$idx =~ s/\s+/,/g;
		$ret .= ", ".(($pri>1)?"primary key":$pri?"unique":"key")
		     .  ($iname ? " `$iname`" : "")
		     .  " ($idx)";
		$pri = 1 if $pri > 1;
		while($liname) {
			$has_idx{$tname}{$liname} = 1;
			last unless ($liname =~ s/(\w+)_\w+$/$1/);
		}
	}
	$ret;
}
# neue Sub für tabellen nach sehen ob schon da im falle von opt_d
# JA->felderlöschen->
# NEIN -> neu anlegen -> tabellenID merken->verwendung speichern
sub tabneu($$) {
	return unless $opt_d;

	my ($tab, $tabtext) = @_;
	my($tid,$ttext) = DoFn("select id,text from db_tabelle where name='$tab'");
	if(defined $tid) {
		if($ttext ne $tabtext) {
			print "# " if $opt_v;
			print "update db_tabelle set text=${\qquote $tabtext} where id=$tid;\n"
				if $opt_v or $opt_n;
			Do("update db_tabelle set text=${\qquote $tabtext} where id=$tid;")
				unless $opt_n;
		}
	}
	# Neue ID erzeugen.
	else {
		$tabtext =~ s/^'// if defined $tabtext;
		if($opt_n) {
			$maxtid=DoFn("select max(id) from db_tabelle")+1
				unless defined $maxtid;
			$tid = $maxtid++;
		} else {
			$tid = Do("insert into db_tabelle set name=${\qquote $tab}, text=${\qquote $tabtext}");
		}
		print "# " if $opt_v;
		print "insert into db_tabelle set id=$tid, name=${\qquote $tab}, text=${\qquote $tabtext};\n"
			if $opt_n or $opt_v;
		# print "Neuer Eintrag in db_tabelle: ".$tid." ".$tab." ".$tabtext."\n";
	}
	$tid;
}

sub feldneu($$$$$) {
	return unless $opt_d;

	my ($fname, $ftype, $bes, $info, $tabid) = @_;
	my ($fid,$ftyp,$fbes,$frem) = DoFn("select id,typ,beschreib,rem from db_feld where db_tabelle=$tabid and name=${\qquote $fname}");

	$bes = "" unless defined $bes;
	$info = "" unless defined $info;
	if ($bes=~ /^\!/) {} else { $info=$bes." ".$info; $bes=""; }
	$ids .= "$1 " if $bes =~ /\!\?(\w+)/;

	if(defined $fid) {
		my $fn = "";
		my $fdi;
		if($ftyp ne $ftype) {
			$fn .= "typ=${\qquote $ftype}, ";
			$fdi .= "Typ: $ftyp | $ftype;  ";
		}
		if($fbes ne $bes) {
			$fn .= "beschreib=${\qquote $bes}, ";
			$fdi .= "Beschr.: $fbes | $bes;  ";
		}
		if($frem ne $info) {
			$fn .= "rem=${\qquote $info}, ";
			$fdi .= "Info: $frem | $info;  ";
		}
		if($fn ne "") {
			$fn =~ s/,\s*$//;
			$fdi =~ s/;\s*$//;
			print "# $fdi\n" if $opt_v or $opt_n;
			print "# " if $opt_v;
			print "update db_feld set $fn where id=$fid;\n"
				if $opt_n or $opt_v;
			Do "update db_feld set $fn where id=$fid"
				unless $opt_n;
		}
	} else {
		print "# " if $opt_v;
		print "insert into db_feld set db_tabelle=$tabid, name=${\qquote $fname}, typ=${\qquote $ftype}, beschreib=${\qquote $bes}, rem=${\qquote $info};\n"
			if $opt_v or $opt_n;
		Do("insert into db_feld set db_tabelle=$tabid, name=${\qquote $fname}, typ=${\qquote $ftype}, beschreib=${\qquote $bes}, rem=${\qquote $info}")
			unless $opt_n;
	}
}

sub foreign_keys($$) {
	my($tname,$ind) = @_;
	return unless $opt_k or $opt_K;

	$ind =~ s/\s+$//;
	foreach my $idx(split /\,\s*/,$ind) {
		next unless $idx =~ s/^>(>)?(\S+)\s//;
		my $dest = $2;
		my $casc = $1 ? "cascade" : "restrict";
		$idx =~ s/\b([a-z_A-Z][-_a-zA-Z0-9]+)\b/`$1`/g;
		$idx =~ s/\(\d+\)//g;
		$idx =~ s/\s+/,/g;
		my $iname = $idx;
		$iname =~ s/,/_/g;
		my $liname = $iname;
		$iname = "r_${tname}__${iname}";
		$iname =~ s/`//g;
		$liname =~ s/`//g;
		
		doit "alter table $tname add constraint $iname foreign key($idx) references $dest($idx) on update cascade on delete $casc",$tname,$iname if $opt_k;
		return if $has_idx{$tname}{$liname};
		doit "alter table $tname add key `$liname`($idx)",$tname,$iname if $opt_K;
	}
}

sub foreign_key($$$) {
	my ($tname, $fname, $bes) = @_;

	return unless $opt_k or $opt_K;

	return if $bes !~ s/^\!//;
	foreach my $b (split(/\!/,$bes)) {
		next unless $b =~ s/^\>(>)?([a-z][a-z0-9_]+)(\.([a-z][a-z0-9_]+))?(?:\/[a-z][a-z0-9_]+)?$/$2/;
		my $casc = $1 ? "cascade" : "restrict";
		my $c = $4 || "id";
		my $iname = "r_${tname}__${fname}";
		doit "alter table $tname add constraint $iname foreign key($fname) references $b($c) on update cascade on delete $casc",$tname,$iname if $opt_k;
		return if $has_idx{$tname}{$fname};
		doit "alter table $tname add key `$fname`($fname)",$tname,$iname if $opt_K;
	}
}

sub dumpm($;$) {
	my($tabname,$who) = @_;
	$who ||= $tabname;
	my $state = 0;
	my $descr = "";

	my $id;
	my $ind = "";
	my $tabtext = "";	# Tabellenbeschreibung
	my $tabid;			# TabellenID
	my @fk;				# foreign key-Definitionen
	my @fks;			# foreign key-Definitionen, Teil 2
	
	if(defined($info{$who})) {
		foreach my $line(split /\n+/s, $info{$who}) {
			next if $line =~ /^\s/;
			if($line =~ s/^Tabelle:\s+//) {
				$state = 1;
				next;
			}
			# Verwendung holen wenn Status auf anfang
			if ($state == 1) { 
				if($line =~ s/^Verwendung:\s+//) {
					$tabid = tabneu($tabname, $line);
					$state = 2;
					next;
				} else {
					$tabid = tabneu($tabname, "");
				}
			}
			if($line =~ s/^Index:\s+//) {
				if($state == 1 or $state == 2) {
					$ind .= dumpii($who,2,$line) if($DATABASE eq "mysql");
					push(@fks,[$tabname, $line]);
					$state = 3;
				} elsif($state == 3) {
					$ind .= dumpii($who,0,$line) if($DATABASE eq "mysql");
					push(@fks,[$tabname, $line]);
					$state = 4;
				}
			}
			if($line =~ /^Aufbau:\s*$/) {
				$state = 5;
				next;
			}
			if($line =~ /^\S+\:/) {
				$state = 6 if $state == 5;
			} elsif($state == 5) {
				my $fchar;
				my($fname,$ftype,$info) = split(/\s+/,$line,3);
				my $mftype=$ftype;
				my ($mbes, $minfo) = split(/\s+/,$info,2);
				next if defined $mbes and ($mbes =~ /!\#\#/ and not $opt_x);
				next if defined $mbes and ($mbes =~ /!\#/ and $opt_X);

				$descr .= "," if $descr ne "";
				my $fadd;
				if(defined $mbes and $mbes =~ /!\?\+/) {
					$fadd = "AUTO_INCREMENT";

					# nette Idee, aber dann müßten wir sämtliche
					# FOREIGN KEYs wegwerfen und neu bauen
					#$ftype = "u".$ftype if $ftype =~ /^int/;
				} elsif(defined $mbes and $mbes =~ /!-/) {
					$fadd = "NULL";
				} else {
					$fadd = "NOT NULL";
				}
				my $fchr;
				if($ftype =~ s/^(u?)int(\d+)?$//) {
					if(not defined $2 or $2 == 4) { $ftype = "int"; }
					elsif($2 == 1) { $ftype = "tinyint"; }
					elsif($2 == 2) { $ftype = "smallint"; }
					elsif($2 == 3) { $ftype = "mediumint"; }
					elsif($2 == 8) { $ftype = "bigint"; }
					else {
						print STDERR "$who: Feldtyp '$ftype$1' unbekannt\n";
						next;
					}
					$fadd = "UNSIGNED $fadd" if $1 eq "u";
						## or $mbes =~ /!>*\w+(?:[^-]|$)/ or $mbes =~ /!\?/;
						## ... nächster Schritt
					$fchar = "n";
				} elsif($ftype eq "datetime") {
					if ($mbes =~ /!\/\+/ and ($opt_n or (DoFn("show variables like 'version'"))[1] gt "4.1")) {
						$ftype = "timestamp";
						$fadd = "default current_timestamp on update current_timestamp";
					}
					$fchar = "n";
				} elsif ($ftype =~ s/^text(\d+)?$/$1/) {
					$fchr="utf8";
					if(!defined($1)) { $ftype = "TEXT"; }
					elsif($1 == 1) { $ftype = "TINYTEXT"; }
					elsif($1 == 2) { $ftype = "TEXT"; }
					elsif($1 == 3) { $ftype = "MEDIUMTEXT"; }
					elsif($1 == 4) { $ftype = "LONGTEXT"; }
					else {
						print STDERR "$who: Feldtyp '$ftype$1' unbekannt\n";
						next;
					}
					$fchar = "y";
				} elsif ($ftype =~ s/^bin(\d+)?$/$1/) {
					if(!defined($1)) { $ftype = "BLOB"; }
					elsif($1 == 1) { $ftype = "TINYBLOB"; }
					elsif($1 == 2) { $ftype = "BLOB"; }
					elsif($1 == 3) { $ftype = "MEDIUMBLOB"; }
					elsif($1 == 4) { $ftype = "LONGBLOB"; }
					else {
						print STDERR "$who: Feldtyp '$ftype$1' unbekannt\n";
						next;
					}
					$fchar = "y";
				} elsif ($ftype =~ s/^char(\d+)$/$1/) {
					$fchr = (($ftype > 1) ? "utf8" : "ascii");
					$ftype = "varchar($ftype)";
					$fchar = "y";
				} elsif ($ftype =~ s/^fchar(\d+)$/$1/) {
					$fchr = (($ftype > 1) ? "utf8" : "ascii");
					$ftype = "char($ftype)";
					$fchar = "y";
				} elsif ($ftype =~ /^f?char$/) {
					$fchr = "ascii";
					$ftype = "char(1)";
					$fchar = "y";
				} elsif ($ftype =~ /^float$/) {
					$ftype = "double";
					$fchar = "n";
				} elsif ($ftype =~ /^double$/) {
					$ftype = "double";
					$fchar = "n";
				} elsif ($ftype =~ /^datetime$/) {
					$ftype = "datetime";
					$fchar = "y";
				} else {
					print STDERR "$who: Feldtyp '$ftype' unbekannt\n";
					next;
				}
				if(defined $mbes and ($mbes =~ /!=([^!\s]+)/ or $mbes =~ /![a-z]+\.([^!\s]+)/)) {
					if($fchar eq "y") {
						if($opt_n) {
							$fadd .= " DEFAULT '$1'";
						} else {
							$fadd .= " DEFAULT ${\qquote $1}";
						}
					} else {
						$fadd .= " DEFAULT $1";
					}
				}
				$fchr = $1 if $mbes =~ /!%(latin1|utf8|ascii)\b/;

				if($mbes =~ /!%case_sens\b/) {
					my $fc = $fchr || "utf8";
					# $fadd = "collate ${fc}_general_cs";
					$fadd = "collate ${fc}_bin";
				}
				$fadd = "character set $fchr $fadd" if $fchr;

				$descr .= "`$fname` $ftype $fadd";
				# Hier muß feld abgespeichert werden
				feldneu ($fname, $mftype, $mbes, $minfo, $tabid);

				# foreign_key ($tabname, $fname, $mbes);
				# geht jetzt noch nicht, wenn gleichzeitig die Tabelle
				# angelegt wird -- denn das passiert erst weiter unten
				push(@fk,[$fname, $mbes]);
			}
		}
	}
	if($state < 5) {
		if($state == 0) {
			print STDERR "$who: Unbekannt\n" if $state == 0;
		} else {
			print STDERR "$who: Unvollständig\n" if $state == 0;
		}
	} else {
		print "# drop table $tabname\n" if $opt_v and $opt_e;
		print "drop table $tabname\n" if $opt_n and $opt_e;
        DoN "drop table $tabname" if $opt_g and $opt_e;
        doit "create table $tabname (".$descr.$ind.") $opt_t" if $opt_g;
		foreach my $k (@fk) {
			my ($fname, $mbes) = @$k;
			foreign_key ($tabname, $fname, $mbes);
		}
		foreach my $k (@fks) {
			my ($tabname, $line) = @$k;
			foreign_keys ($tabname, $line);
		}
	}
}

if(@ARGV) {
	foreach my $i(@ARGV) {
		if($opt_m) {
			(my $name = $muster) =~ s/\E{$opt_m}\Q/$i/;
			dumpm $name,$muster;
			# Do "insert into db_vorlagen set muster=${\qquote $opt_m}, name=${\qquote $i}" if $opt_d;
		} else {
			dumpm $i;
		}
	}
} else {
	foreach my $i(keys %info) {
		next if $i =~ /\{\S+\}/; # das ist eine Vorlage
		dumpm $i;
	}
}
if($opt_i) {
	chop $ids;
	foreach my $id(split(/\s+/,$ids)) {
		# Ignoriere Fehler (schon vorhanden?)
		DoN("insert into nextid set id=1, name='${\quote $id}'");
	}
}
exit(0);
