#!/usr/bin/perl

###################################################
# This little (??) Perl Program tryes to convert some Nadmin-PHP
# Functions in the Midgard -Database cause my PHP-ereg, eregi
# and such Funktions crash. I take ABSOLUTE NO WARRANTY
# FOR THIS PROGRAM (although i've debugged it a lot).
# 
# Written by Christopher Kohlert : christopher@kohlert.de
###################################################

#You should uncomment the following PHP-Function and
#set is somewhere (for example auth (element #70)
#Style: adminsite_Master_Style) reacable for the
#Rest of the Nadmin-Code:
#
#/***
# * translate_ereg_parsestring
# ***
# * This PHP Function takes a old ereg_expression pattern-matching 
# * string and returns a responding pattern for the new preg-PHP
# * Functions
# ***/
#function translate_ereg_parsestring($ereg_reg_exp, $addon = "") {
#
#  $ereg_reg_exp=preg_replace("/\[\[\:alnum\:\]\]/","\[a-zA-Z0-9\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:alnum\:\]\]/","\[a-zA-Z0-9\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:alpha\:\]\]/","\[a-zA-Z\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:blank\:\]\]/","\[ \\t\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:cntrl\:\]\]/","\[\\r\\n\\f\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:digit\:\]\]/","\\d",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:graph\:\]\]/","\\S",$ereg_reg_exp); // ?
#  $ereg_reg_exp=preg_replace("/\[\[\:lower\:\]\]/","\[a-zA-Z\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:print\:\]\]/","\[\\s\\S\]",$ereg_reg_exp); // ?
#  $ereg_reg_exp=preg_replace("/\[\[\:punct\:\]\]/","\[\\.,;:-\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:space\:\]\]/","\\s",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:upper\:\]\]/","\[A-Z\]",$ereg_reg_exp);
#  $ereg_reg_exp=preg_replace("/\[\[\:xdigit\:\]\]/","\[0-9a-fA-F\]",$ereg_reg_exp);
#
#  $ereg_reg_exp=preg_replace("/\//","\\\/",$ereg_reg_exp); // ?
#  $ereg_reg_exp=preg_replace("/\:/","\\\:",$ereg_reg_exp); // ?
#
#  return "/" . $ereg_reg_exp . "/" . $addon;
#
#} /* End of translate_ereg_parsestring */
#
#End of the PHP-Function, Start of the Perl-Code

use DBI;

###################################################
# Dieses Script durchcrawled eine Datenbank und holt sich alle
# Text-Elemente dieser
###################################################

###################################################
# Konfigurationsteil
###################################################

my $DBHOST = "localhost";
my $DBNAME = "midgard";
my $DBUSER = "midgard";
my $DBPASS = "midgard";
my $DEBUG = 1;

###################################################

###
# translate_expmatch tries to translate some diffs between
# reg-package and the preg-package and returns the preg-result
###
sub translate_expmatch($$) { # $regmatch, $addon
  my $wmatch=$_[0];
  my $addon=$_[1];
  $wmatch =~ /^\"([\s\S]*)\"$/s;
  my $regmatch = $1;

  # some translations
  $regmatch =~ s/\[\[\:alnum\:\]\]/\[a-zA-Z0-9\]/g;
  $regmatch =~ s/\[\[\:alpha\:\]\]/\[a-zA-Z\]/g;
  $regmatch =~ s/\[\[\:blank\:\]\]/\[ \\t\]/g;
  $regmatch =~ s/\[\[\:cntrl\:\]\]/\[\\r\\n\\f\]/g;
  $regmatch =~ s/\[\[\:digit\:\]\]/\\d/g;
  $regmatch =~ s/\[\[\:graph\:\]\]/\\S/g; # ?
  $regmatch =~ s/\[\[\:lower\:\]\]/\[a-z\]/g;
  $regmatch =~ s/\[\[\:print\:\]\]/\[\\s\\S\]/g; # ?
  $regmatch =~ s/\[\[\:punct\:\]\]/\[\\.,;:-\]/g;
  $regmatch =~ s/\[\[\:space\:\]\]/\\s/g;
  $regmatch =~ s/\[\[\:upper\:\]\]/\[A-Z\]/g;
  $regmatch =~ s/\[\[\:xdigit\:\]\]/\[0-9a-fA-F\]/g;
   
  $regmatch =~ s/(?<!=\\)\//\\\//g; # : -> \:
  $regmatch =~ s/(?<!=\\)\:/\\\:/g; # / -> \/
  
  return "\"/" . $regmatch . "/" . $addon . "\"";
}

###
# translates the 2nd Parameter of a eregx-function
###
sub translate_2nd_exp($) { # $regmatch
  my $regmatch=$_[0];

  #all reg-chars must be escaped!
  $regmatch =~ s/\\/\\\\/g; # \ -> \\ (\n\r\t etc??)
  $regmatch =~ s/\./\\\./g; # . -> \.
  $regmatch =~ s/\?/\\\?/g; # ? -> \?
  $regmatch =~ s/\[/\\\[/g; # [ -> \[
  $regmatch =~ s/\]/\\\]/g; # ] -> \]
  $regmatch =~ s/\{/\\\{/g; # { -> \{
  $regmatch =~ s/\}/\\\}/g; # } -> \}
  $regmatch =~ s/\}/\\\}/g; # } -> \}
  $regmatch =~ s/\|/\\\|/g; # | -> \|
  $regmatch =~ s/\+/\\\+/g; # + -> \+
  $regmatch =~ s/\(/\\\(/g; # ( -> \(
  $regmatch =~ s/\)/\\\)/g; # ) -> \)
  $regmatch =~ s/\^/\\\^/g; # ^ -> \^
  $regmatch =~ s/\$[^a-zA-Z]/\\\$/g; # $[.] && ! $[a-zA-Z] -> \$

  return $regmatch;
}

# If a match contains a Variable - we can't translate on the fly!
sub need2functiontranslate($) { # $matchstring
  my $matchstring=$_[0];
  if ($matchstring =~ /^\"([\s\S]*)\"[\s]*$/s) {
    if (not $2 eq "") { return "true"; }
    my $inhalt=$1;
    if (xrindex($inhalt,"\"",length($inhalt))>=0) { return "true"; }
    if ($matchstring =~ /(?<!=\\)\$[a-zA-Z]/s ) { return "true"; }
    else { return ""; } 
  } else { return "true"; }
}

###
# This function parses one parameter
# returns (0): the parameter ("") if there was none
#             (1): the rest
#             (2): is it a pure constant?
###
sub getaparameter($) { # $rest
  my $rest=$_[0];
  my @presult;
  my @iresult;
  #try to parse the parameter
  if(x_isolate_and_match($rest,",")) { # Parameter isolieren
    @iresult=x_isolate_and_match($rest,",");
  } elsif (x_isolate_and_match($rest,")")) { # war einziger Parameter
    @iresult=x_isolate_and_match($rest,")");
  } else { # Fehler!
    @presult=("",$rest,"");
    return @presult;
  }
  #rest
  @presult=(@iresult[0], @iresult[1] . @iresult[2] , need2functiontranslate(@iresult[0]));
  return @presult;
}

###
# this Function get the rest-page and tries to parse a 2nd Parameter of
# the function and exchange its content. Ever Results:
# (0): the page
# (1): a optional addon to the resultpage
###
sub tryasecondparameter($) { # $page
  my $page=$_[0]; # The rest-Page
  #Erstes Zeichen ist entweder ")", dann gibt es keinen Parameter, oder
  #ein Trenner ","
  if ($page =~ /^\(/s) { # gibt keinen weiteren Parameter
    my @result=($page,"");
    return @result;
  }
  if (not $page =~ /^([\s]*,[\s]*)/) { # Fehler!
    if ($DEBUG) {
      print "Warning: Parameter parse error!\n";
      print "Debug: $page\n";
    }
    my @result=($page,"");
    return @result;
  }
  my $trenna=$1;
  $page=substr($page,length($trenna));
  my @para = getaparameter($page);
  my @result;
  if (not @para[2]) { # constant parameter
    @result = (@para[1], $trenna . translate_2nd_exp(@para[0]));
    if ($DEBUG) { 
      print "2nd parameter $trenna@para[0] -> @result[1] \n";
    }
  } else {
    @result = (@para[1], $trenna . "translate_ereg_parsestring2(". @para[0] . ")" );
    if ($DEBUG) { 
      print "2nd parameter $trenna@para[0] -> @result[1] \n";
    }
  }
  return @result;
}

sub perl_5_parse_test($$) { # a function that was a result in testing perl
  my $page=$_[0];
  my $reg=$_[1]; 
  my @result;
  my $pos=index($page,$reg);
  if ($pos>=0) { # i
    @result=(substr($page,0,$pos),$reg,substr($page,$pos+length($reg)));
    return @result;
  } else {
    return "";
  }
}

sub process_one_reg($$$$$) { # $page, $regin, $regout, $addon, $warnings_only results new page if something changes
  my $page=$_[0];
  my $regin=$_[1];
  my $regout=$_[2];
  my $addon=$_[3];
  my $warnings_only=$_[4];
  my $changed;
  my $resultpage="";

  if (not $DEBUG) { $|=1; } # Zeichen sofort ausgeben

  #$regin -> $regout
  #versuche nun $regin zu finden
  while( perl_5_parse_test($page,$regin) ) { 
    my @iresult=perl_5_parse_test($page,$regin);
    if ($DEBUG>2) {
      print("Found $regin in $page\n");
    }
    my $pmatch = $iresult[0]; # alles vor dem funktionsnamen
    # im Rest dürfte jetzt ein (" auftauchen hoffe ich!
    my $rest = $iresult[2]; # alles hinter dem funktionsnamen
    # so we need for find the first "," behind which is not in a () or ""-Konstruction
    if ($rest=~/^\s*\(\s*/s) {
      my $match1=$&; # Leerzeichen und öffnende Klammer seit dem Funktionsnamen
      my $frest=$'; # alles dahinter
      @presult=getaparameter($frest);
      if (@presult[0]) { # Parameter da?
        if (not @presult[2]) { # constant?
          my $resmatch = translate_expmatch(@presult[0],$addon);
          $resultpage = $resultpage . $pmatch . $regout . 
                                 $match1 . $resmatch ;
          if ($DEBUG) {
            if ($warnings_only) { print "Warning: "; }
            print "Ersetze $regin" . $match1 . @presult[0] . " ...\n";
            print "durch $regout" . $match1 . $resmatch . " ...(3)\n";
          } else {
            print ".";
          }
#        my @iresult2=tryasecondparameter(@presult[1]);
#        $page = @iresult2[0];
#        $resultpage = $resultpage . @iresult2[1];
          $page = @presult[1];
          $changed = "true";
        } else { # variable Parameter
          my $resmatch = "translate_ereg_parsestring(" . @presult[0] ;
          if ($addon) { $resmatch = $resmatch . ",\"" . $addon . "\")" ; }
          else { $resmatch = $resmatch . ")"; }
          $resultpage = $resultpage . $pmatch . $regout . 
                        $match1 . $resmatch ;
          if ($DEBUG) {
            if ($warnings_only) { print "Warning: "; }
            print "Ersetze $regin" . $match1 . @presult[0] . " ...\n";
            print "durch $regout" . $match1 . $resmatch . " ...(2)\n";
          } else {
            print ".";
          }
#        my @iresult2=tryasecondparameter(@presult[1]);
#        $page = @iresult2[0];
#        $resultpage = $resultpage . @iresult2[1];
          $page = @presult[1];
          $changed = "true";
        } 
      } else { # kein Parameter
        if ($DEBUG) {
          print "Warning! Can't match $regin-s first parameter!\n";
          print "Debug: $rest\n";
        }
        $resultpage = $resultpage . $pmatch . $regin;
        $page = $rest;
      }
    } else { # kann das nicht matchen!
      $resultpage = $resultpage . $pmatch . $regin;
      $page = $rest;
    }
  }
  # kleine Restschnipsel und wieder in die $page
  $page = $resultpage . $page;

  if (not $DEBUG) { 
    $|=0; # Wieder normal
  }

  if ($changed) { return $page; }
  else { return ""; }
}

####
# sub process_Nadmin_changes
####
# diese dummy_Funktion liefert entweder content wenn sich was verändert hat
# oder nichts wenn alles beim alten bleibt
####

sub process_Nadmin_changes($$) { #$page, $warnings_only
  my $page=$_[0];
  my $warnings_only=$_[1];
  my $resultpage="";
  my $changed;
  if ($DEBUG>2) {
    print "Processing ";
    if ($warnings_only) {
      print "text/html"
    } else {
      print "PHP"
    }
    print " :\n$page\n";
  }

  #ereg_replace -> preg_replace
  $resultpage=process_one_reg($page,"ereg_replace","preg_replace","",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }

  #eregi_replace -> preg_replace + i
  $resultpage=process_one_reg($page,"eregi_replace","preg_replace","i",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }

  #eregi -> preg_match + i
  $resultpage=process_one_reg($page,"eregi","preg_match","i",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }
  
  #ereg -> preg_match
  $resultpage=process_one_reg($page,"ereg","preg_match","",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }

  #spliti -> preg_split + i
  $resultpage=process_one_reg($page,"spliti","preg_split","i",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }

  #split -> preg_split (Warning - preg_split also contains "split", so i search for " split")
  #so: [ =(,]
  $resultpage=process_one_reg($page," split","preg_split","",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }
  $resultpage=process_one_reg($page,"=split","preg_split","",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }
  $resultpage=process_one_reg($page,"(split","preg_split","",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }
  $resultpage=process_one_reg($page,",split","preg_split","",$warnings_only);
  if ($resultpage) {
    $changed = "true";
    $page = $resultpage;
  }

  # just for care...
  if ($page=~s/preg_preg_split/preg_split/g) {
    $changed = "true";
  }

  if ($warnings_only) {
    return $page; # "";
  } else {
    if ($changed) {
      return $page;
    }
  }
}

###
# extreme-rindex sucht rückwärts nach dem pattern, insofern dies
# nicht durch ein \ ausmaskiert wurde
###
sub xrindex($$$) { # $string,$pattern,$pos
  my $string=$_[0];
  my $pattern=$_[1];
  my $pos=$_[2];
  my $rpos=rindex($string,$pattern,$pos);
  if ($rpos<1) { return $rpos; }
  while(substr($string,$rpos-1,1) eq "\\") {
    $rpos=rindex($string,$pattern,$rpos-1);
    if ($rpos<1) { return $rpos; }
  }
}

###
# extreme-index sucht rückwärts nach dem pattern, insofern dies
# nicht durch ein \ ausmaskiert wurde
###
sub xindex($$$) { # $string,$pattern,$pos
  my $string=$_[0];
  my $pattern=$_[1];
  my $pos=$_[2];
  my $rpos=index($string,$pattern,$pos);
  if (($rpos<0) || ($rpos eq $pos)) { return $rpos; }
  while(substr($string,$rpos-1,1) eq "\\") {
    $rpos=index($string,$pattern,$rpos+1);
    if ($rpos<0) { return $rpos; }
  }
  return $rpos;
}

sub indexhhelper($) { # helper for x_isolate_and_match
  my $string=$_[0];
  my $pos=xindex($string,"\"",0);
  if ($pos<0) { return $pos; }
  # Zeichen die durch \ ausmaskiert wurden gelten natuerlich nicht.
  while(xrindex($string,"[",$pos-1)>=0
           and
           xrindex($string,"]",$pos-1)<xrindex($string,"[",$pos-1)) {
     $pos=xindex($string,"\"",$pos+1);
     if ($pos<0) { return $pos; }
  }
  return $pos;
}

####
# sub x_isolate_and_match
####
# Isoliert den $string von "..." und (...) - Elementen und sucht $pattern ausserhalb.
# Zurueckgegeben wird ein Array, das $PREMATCH, $MATCH, und $POSTMATCH
# enthaelt oder garnix.
# Bugs: 
#        : "href="([^"]+", ... ist etwas was nicht erkannt wird und ich auch nicht verstehe
####
sub x_isolate_and_match($$) { # $string, $pattern
  my $string=$_[0];
  my $pattern=$_[1];
  my $prematch="";
  my $pos;
  while((indexhhelper($string)>=0 and (index($string,"\"")<index($string,$pattern))) or
           (index($string,"(")>=0 and (index($string,"(")<index($string,$pattern)))
          ) {
    $pos1=index($string,"\"");
    $pos2=index($string,"(");
    $pos3=index($string,")");
    if ($pos2>=0 and ($pos2<$pos1 or $pos1<0)) { # Fall "Klammern"
      if ($pos3<$pos2) { return ""; }
      $pos2++;
      $prematch = $prematch . substr($string,0,$pos2);
      $string = substr($string,$pos2);
      # Nun abschliessende Klammer finden
      $pos=index($string,")")+1;
      if ($pos>0) {
        $prematch = $prematch . substr($string,0,$pos);
        $string = substr($string,$pos);
      } else { # ansonsten - keine abschliessende Klammer gefunden! boese!
        return "";
      }
    } else { # Fall ""
      if ($pos3<$pos1) { return ""; }
      $pos1++;
      $prematch = $prematch . substr($string,0,$pos1);
      $string = substr($string,$pos1);
      # Nun abschliessende " finden
      $pos=indexhhelper($string)+1;
      if ($pos>0) {
        $prematch = $prematch . substr($string,0,$pos);
        $string = substr($string,$pos);
      } else { # ansonsten - keine abschliessendes " gefunden! boese!
        return "";
      }
    }
  }
  # if a ")" comes before - error!
  $posk=index($string,")");
  $pos=index($string,$pattern);
  if ($pos>=0 and $posk>=$pos) {
    $prematch = $prematch . substr($string,0,$pos);
    @result=($prematch,$pattern,substr($string,$pos+length($pattern)));
    return @result;
  } else {
    return "";
  }
}

####
# sub isolate_and_match
####
# Isoliert den $string von "..." - Elementen und sucht $pattern ausserhalb.
# Zurueckgegeben wird ein Array, das $PREMATCH, $MATCH, und $POSTMATCH
# enthaelt oder garnix.
####
sub isolate_and_match($$) { # $string, $pattern
  my $string=$_[0];
  my $pattern=$_[1];
  my $prematch="";
  my $pos;
  while(index($string,"\"")>=0 and index($string,"\"")<index($string,$pattern)) {
    $pos=index($string,"\"")+1;
    $prematch = $prematch . substr($string,0,$pos);
    $string = substr($string,$pos);
    # Nun abschliessende Klammer finden
    $pos=index($string,"\"")+1;
    if ($pos>0) {
      $prematch = $prematch . substr($string,0,$pos);
      $string = substr($string,$pos);
    } else { # ansonsten - keine abschliessende Klammer gefunden! boese!
      return "";
    }
  }
  $pos=index($string,$pattern);
  if ($pos>=0) {
    $prematch = $prematch . substr($string,0,$pos);
    @result=($prematch,$pattern,substr($string,$pos+length($pattern)));
    return @result;
  } else {
    return "";
  }
}

####
# sub preparse
####
# diese Funktion teilt den Inhalt in HTML und PHP-Teile auf (insofern
# vorhanden, und gibt diesen Inhalt weiter an process_Nadmin_changes
# und gibt im Falle einer Änderung den gesamten, geänderten Content
# wieder zurueck, ansonsten einen Leerstring
####
sub preparse($$) { #$content, $position
  my $content=$_[0];
  my $position=$_[1];
  #Es wird nun versucht HTML-Elemente und PHP-Elemente des $content
  #zu trennen und in process_Nadmin_changes jeweils mit $warning-Flag
  #und ohne zu geben. Dabei wird in $resultcontent die neue Seite aufgebaut
  #und für den Fall das ein Change eines PHP-Elementes kein Leerelement
  #zurückgibt der $resultcontent zum Schluss zurueckgegeben.
  #beim Trennen wird davon ausgegangen, das alles zunächst HTML ist, und
  #nur der PHP-Code durch <? Eingeleitet und durch ?> wieder beendet
  #wird.
  #Alles was in Anführungszeichen steht darf als <? ?> nicht beruecksichtigt
  #werden...
  my $resultcontent;
  my $shouldresult;
  my $snippet=0;
  if ($DEBUG) {
    print "Processing Datafield $position";
    if ($DEBUG>1) {
      print " with Content:\n$content";
    }
    print "\n";
  }
  my @iresult;
  while(isolate_and_match($content,"\<\?")) { # Solange ich noch <? Elemente finden kann
    @iresult=isolate_and_match($content,"\<\?");
    my $phpsnippet="<?" . @iresult[2]; # $POSTMATCH
    my $lasthtmlsnippet=@iresult[0];   # $PREMATCH
    my $presult=process_Nadmin_changes($lasthtmlsnippet,"true");
    $resultcontent = $resultcontent . $lasthtmlsnippet;
    #aus dem Rest jetzt noch den PHP-Teil herausnehmen
    if (isolate_and_match($phpsnippet,"\?\>")) {
      @iresult=isolate_and_match($phpsnippet,"\?\>");
      $content=@iresult[2]; # $POSTMATCH
      $phpsnippet = @iresult[0] . "?>";
      $presult=process_Nadmin_changes($phpsnippet,""); # PHP-Code
      if ($presult) {
        $shouldresult="true";
        $resultcontent = $resultcontent . $presult;
      } else {
        $resultcontent = $resultcontent . $phpsnippet;
      }   
    } else { # es gab kein schliessendes ?>
      if ($DEBUG) {
        print "Warning: No closing ?> (even processing Code)\n";
      }
      $presult=process_Nadmin_changes($phpsnippet,""); # PHP-Code
      $resultcontent = $resultcontent . $phpsnippet;
      $content=""; # no data left.
    }
  }
  if ($content) { # Uebriggebliebene HTML-Schnipsel
    process_Nadmin_changes($content,"true");
    $resultcontent = $resultcontent . $content;
  }

  if ($DEBUG) {
    if ($shouldresult) { 
       if ($DEBUG>1) {
         print "Ready. Datafield $position now contains";
         print "(UPDATE):\n"; 
         print "$resultcontent\n";
       } else {
         print "Ready. Datafield $position now needs a (UPDATE).\n";
       }
    } else { 
       print "Ready. No need to change original!\n"; 
    }
  }

#  if ($shouldresult) { return $resultcontent; }
#  else { return ""; }

return $resultcontent;
}

###
# eigentliches Hauptprogramm
###

my @DSN = ("DBI:mysql:" .
                     "database=" . $DBNAME . ";" .
                     "host=" . $DBHOST, $DBUSER, $DBPASS);

# An die Datenbank connecten
my $dbh = DBI->connect(@DSN,
                 { PrintError => 0,
                   AutoCommit => 1,
                 });

#Ist ein Fehler aufgetreten?
die $DBI::errstr unless $dbh;

print "## Connection to the Database $DBNAME\@$DBHOST with User $DBUSER successfull ##\n";

#Alle Tables in dieser Datenbank enumerieren
my @tables = $dbh->func('_ListTables');
for(@tables) {
  my $tablename=$_;
  print "Processing Table $tablename\n";

  # Moeglicherweise nur MySQL:
  my $sth = $dbh->prepare("DESCRIBE $tablename");
  $sth->execute or die "Unable to describe : $dbh->errstr\n";
  my @types;
  # @types[0] enthält den Namen des Feldes
  # @types[1] enthält jetzt jeweils den Typ ders Feldes...
  # longtext und varchar(#) u.ä. interessieren uns.
  # Wir bauen jetzt also ein Array auf, das die Fields enthält die uns interessiert
  my @fieldlist;
  my $primarykey;
  while(@types = $sth->fetchrow_array) {
     my $actual_type = @types[1];
     if ($actual_type=~/varchar/ or $actual_type=~/longtext/ or $actual_type=~/tinytext/
         or $actual_type=~/text/ or $actual_type=~/mediumtext/) {   
       my $actual_fieldname = @types[0];
       if ($DEBUG) {
         print " - " . $actual_fieldname . " with type " . $actual_type . " is interesting\n";
       }
       push(@fieldlist,$actual_fieldname);
     }
     # das ist wohl auch nur mysql-kompatibel.
     if (@types[3] eq "PRI") { $primarykey = @types[0]; }
  }
  if ($DEBUG) {
    print " - Primary Key Field: " . $primarykey . "\n";
  }
  $sth->finish; # Fertig mit Describe

  if ($#fieldlist>0) { # Interessiert uns überhaupt was an diesem Table?
    # So, nun die entsprechenden Daten aus der Datenbank holen und zwar
    # einerseits nur die Felder die uns interessieren, und diese über
    # bind_param, da man dadurch binaere Daten gut austauschen kann
    my $preparestring = "SELECT ";
    for ($a=0;$a<$#fieldlist;$a++) { 
       $preparestring = $preparestring . @fieldlist[$a];
       $preparestring = $preparestring . ", ";
    }
    $preparestring = $preparestring . @fieldlist[$#fieldlist] . ", "
                             . $primarykey 
                             . " FROM " . $tablename;
    if ($DEBUG>1) {
      print "## Selecting Data in the Database with the following Prepare-String: ##\n$preparestring\n";
    }
    my $sth = $dbh->prepare($preparestring)
       or die "Unable to prepare query: $dbh->errstr\n";
    #nun die bindings
    my @bound_vars = (0..$#fieldlist); 
    # Ein Array mit Referenzen auf die Skalare auf bound_vars erzeugen
    my @ref_bound;
    for ($a=0;$a<=$#bound_vars;$a++) { push (@ref_bound,\@bound_vars[$a]); }
    my $keyid;
    $sth->execute or die "Unable to execute query: " . $sth->errstr . "\n";
    # Die Skalaren an den Inhalt der rows binden...
    $sth->bind_columns(undef,@ref_bound, \$keyid)
      or die "Unable to bind_columns: $dbh->errstr\n";

    # Nun durch den Inhalt der Tabelle crawlen
    my @row;
    while(@row = $sth->fetchrow_array) {
      # Im den Skalaren des Arrays bound_vars stehen nun die jeweiligen
      # Inhalte
      for($a=0;$a<=$#bound_vars;$a++) { 
         # Soo.... die Inhalte nun Parsen, und für den Fall das etwas verändert wurde
         # die Results in die Tabelle zurueckupdaten
         $changed = preparse(@bound_vars[$a], $tablename . "::" . @fieldlist[$a] . "::id=" . $keyid);
         if ($changed) {
           # Veränderten Inhalt zurueck in die Datenbank
           # $keyid und @fieldlist[$a] markieren in der aktuellen Table $tablename genau
           # das zu treffende Datenbankfeld
           $preparestring = "UPDATE " . $tablename . " SET " 
                                    . @fieldlist[$a] . "= ? "
                                    . " WHERE " . $primarykey . " = " . $keyid;
           if ($DEBUG>1) {
             print "## Updating the Database with the following Prepare-String: ##\n$preparestring\n";
           }
           my $sth2 = $dbh->prepare($preparestring)
             or die "Unable to prepare query: $dbh->errstr\n";
           $sth2->execute($changed) or die "Unable to execute query: $dbh->errstr\n";
           $sth2->finish; # Fertig mit dem Update
         }
      }
    }
    if (not $DEBUG) { 
      print "\n"; # Absatz hinter den Punkten
    }
    $sth->finish; # Fertig mit diesem Table
  }
}

$dbh->disconnect();

print "## Database finished. ##\n";

# Ende