package PMLTQ::PML2BASE;
our $AUTHORITY = 'cpan:MICHALS';
{
  $PMLTQ::PML2BASE::VERSION = '0.8.3';
}

# ABSTRACT: Convert from PML to SQL


use 5.006;
use strict;
use warnings;
$|=1;
use Data::Dumper;

use open qw(:std :utf8);
use Carp;

# $SIG{__WARN__} = sub { Carp::cluck(@_); };

use constant MAX_NAME_LENGTH => 16;

use constant HYBRID=>1;        # create both separate node table and node table with attributes
use constant NO_TREE_TABLE=>2; # don't create one common common node table for all node types
use constant MAX_MIN_ORD=>4;   # node tables have #max_ord and #min_ord columns
use constant TOP_TREE_FLAG=>8; # The <root>__#files table has a 'top' column indicating that
                               # a given root node belongs to the top-level tree list
                               # of a file (i.e. it is not a nested #NODE within
                               # some non-#NODE and non-#TREES data structure)
#
# Generic SQL DB scheme for PML data:
#
# - every structure/container/ has a unique idx (Number) and carries attributes as columns
#
# - container has a '#content' column
#
# - cdata/constant/choice attributes are stored in the respective columns
#
# - structure/container members are in a separate table where they have a unique idx,
#   referred to by the member column
#
# - unordered-list/alt members are stored in a separate table, whose columns
#   are a 1:N idx referred to by the member column, and a LM/AM column
#   containing the value (following the rules described here);
#
# - sequence members are in a separate table whose columns correspond
#   to the elements, each containing an reference to a table
#   representing all occurrences of that element; this table has
#   an 1:N idx, '#pos' containing position of the element in the sequence,
#   '#elem-pos' containing the number of preceding elements of the same name in the sequence+1,
#   and the value, as usual. To retrieve a complete content of a certain sequence as a table,
#   one has to use a UNION on all the element tables, ordering by #pos and possibly outputing
#   a constant '#name' column
#
# - the table names should be derived from PML type names in a canonical way,
#   one per PML schema type decl
#
# Possible modifications:
#
# a) cast all cdata structure members also into separate tables and thus
#    keep varchar data in separate tables
#
# b) cast node attributes to a separate table, separating the tree structure
#    from node data, making the tree-structure table very thin
#    in fact: this is necessary, since nodes can be of different types
#
# c) use cdata format information to determine the table column format
#
#  some hacks:
#
#  - updating refs in strips .rf suffix if the member is a PMLREF but
#    not if it is a list of PMLREFs
#
#  - prefix of PMLREFs is stripped down; should be kept and
#    used to verify the target based on filename on UPDATE
#
#

use Treex::PML::Schema;
use Treex::PML::Instance;
use PMLTQ::Common;
use List::Util qw(max first);
use Cwd;
use Carp;

my ($file_table,$root_name,$schema,$references_table,%schema,%fh,%orig_name,%seen_ref_schema,
    $node_table,$index_id,$last_type_no,$tree_no,$filename,
    $idx,$node_idx, $last_tree_no, %pmlref_target_info
   );

our %opts;

sub init {
  $idx = $opts{'init-idx'} || 0;
  $node_idx=($opts{'init-node-idx'}|| $opts{'init-idx'} || 0);
  $last_type_no=0;
  $index_id=0;
  $tree_no=0;
  $filename=undef;

  %pmlref_target_info=();

  $opts{'related-schema'} ||= [];
  $opts{other_schemas}||=[
    map {
      Treex::PML::Schema->new({filename=>$_,use_resources=>1})
    } @{$opts{'related-schema'}}
  ];
  $opts{hybrid}||=1;
  $opts{prefix}||='';
  $opts{'data-dir'}||='';
}

sub varchar {
  my ($l,$non_ascii)=@_;
  if (lc($opts{syntax}) eq 'oracle') {
    return $non_ascii ? "NVARCHAR2($l)" :"VARCHAR2($l)";
  } else {
    return "VARCHAR($l)";
  }
}
sub numeric {
  my ($l)=@_;
  if (lc($opts{syntax}) eq 'oracle') {
    return "NUMBER($l)";
  } else {
    return "NUMERIC($l)";
  }
}
sub boolean {
  my ($l)=@_;
  if (lc($opts{syntax}) eq 'postgres') {
    return "BOOLEAN";
  } else {
    return "NUMBER(1)";
  }
}

sub mkdump {
  if (lc($opts{syntax}) eq 'postgres') {
    return join("\t",map {
      if (defined) {
	my $x=$_;
	$x=~s/[\t\n]/ /g;
	$x=~s/(\\|\r)/\\$1/g;
	$x
      } else {
	"\\N"
      }
    } @_)."\n";
  } else {
    return join("\t",map {
      if (defined) {
	my $x=$_;
	$x=~s/[\t\n]/ /g;
	$x
      } else {
	''
      }
    } @_)."\n";
  }
}
sub mkload {
  my ($f,$opts)=@_;
  if ($opts && $opts->{quiet}) {
    return qq{  run_sql_commands '$f' 2>/dev/null 1>&2\n};
  } else {
    return qq{  run_sql_commands '$f'\n};
  }
}
sub mkdataload {
  my ($f,$opts)=@_;
  if ($opts && $opts->{quiet}) {
    return qq{  run_loader_commands '$f' 2>/dev/null 1>&2\n};
  } else {
    return qq{  run_loader_commands '$f'\n};
  }
}

sub complete_schema_pmlref_list {
  my ($schema)=@_;
  $schema->for_each_decl(
    sub {
      my ($decl)=@_;
      my $decl_is = $decl->get_decl_type;
      return if ($decl->get_role||'') eq '#CHILDNODES';
      return if $decl_is == PML_TYPE_DECL or $decl_is==PML_ROOT_DECL;
      my $p=$decl->get_parent_decl;
      return if ($p and $p->get_decl_type == PML_MEMBER_DECL and ($p->get_role||'') eq '#CHILDNODES');
      return if $decl->is_atomic;
      my $table = table_name($decl,1);
      my @m;
      if ($decl_is == PML_STRUCTURE_DECL) {
	@m = map [$_->get_name, $_->get_knit_content_decl], $decl->get_members;
      } elsif ($decl_is == PML_CONTAINER_DECL) {
	@m = ['#content', $_->get_content_decl],map [$_->get_name, $_->get_content_decl], $decl->get_attributes;
      } elsif ($decl_is == PML_SEQUENCE_DECL) {
	@m = map [$_->get_name, $_->get_knit_content_decl], $decl->get_elements;
      } elsif ($decl_is == PML_LIST_DECL or $decl_is == PML_ALT_DECL) {
	@m = ['#value', $decl->get_knit_content_decl];
      } else { return }
      foreach my $member (@m) {
	next unless $member->[1] and $member->[1]->get_decl_type == PML_CDATA_DECL and
	  $member->[1]->get_format eq 'PMLREF';
	my $p=$member->[1]->get_parent_decl;
	next if ($p and (($p->get_role||'') eq '#KNIT'
			       or ($p->get_decl_type == PML_LIST_DECL or $p->get_decl_type == PML_ALT_DECL)
				 and ($p->get_role||'') eq '#KNIT'));
	my $path =$member->[0] eq '#value' ? $table : $table.'/'.$member->[0];
	unless (ref($opts{ref}) and exists ($opts{ref}{$path})) {
	  $opts{ref}{$path}='-';
	}
      }
    });
  return ($opts{ref}||={});
}

# test if a given DECL is a known PMLREF type
# that we can handle
# It can aslo produce a warning when finding an unknown PMLREF

sub get_pmlref_target_info {
  my ($decl,$table,$column,$warn) = @_;
  if (!$warn and exists($pmlref_target_info{$decl})) {
    return @{$pmlref_target_info{$decl}};
  }
  my $ret = ($pmlref_target_info{$decl}||=[]);
  return unless $decl->get_decl_type == PML_CDATA_DECL and $decl->get_format eq 'PMLREF';
  my $p=$decl->get_parent_decl;
  unless ($p and (($p->get_role||'') eq '#KNIT'
		    or ($p->get_decl_type == PML_LIST_DECL or $p->get_decl_type == PML_ALT_DECL)
		      and ($p->get_role||'') eq '#KNIT')) {
    my $o_name = $orig_name{$table} || $table;
    my $path =$column eq '#value' ? $o_name : $o_name.'/'.$column;
    unless (ref($opts{ref}) and exists ($opts{ref}{$path})) {
      warn "UNHANDLED PMLREF: $path\n" if $warn;
      return;
    }
    if ($opts{ref}{$path} ne '-') { # ignore
      @{$ret} = split(/:/,$opts{ref}{$path},2);
      return @$ret;
    }
  }
  return;
}

# column_spec returns one or more values for colspec
sub column_spec {
  my ($table,$column,$decl,$is_required,$role)=@_;
  my $create_index = (!$decl->is_atomic or (($role||'') eq '#ID')) ? 1 : 0;
  confess("cannot determine column type for undefined declaration")
    unless defined $decl;
  my $decl_is = $decl->get_decl_type;
  my $constraint = $is_required ? ' NOT NULL' : '';
  if ($decl_is == PML_CHOICE_DECL || $decl_is == PML_CONSTANT_DECL) {
    my $max = max(map length, $decl->get_values);
    if (first { !/^(?:0|-?[1-9][0-9]*(?:\.[0-9]*[1-9])?)$/ } $decl->get_values) {
      return [$column => varchar($max).$constraint,$create_index];
    } else {
      return [$column => numeric($max).$constraint,$create_index];
    }
  } elsif ($decl_is == PML_CDATA_DECL) {
    my $format = $decl->get_format;
    return [$column => 'INT'.$constraint,$create_index] if $format =~ /(integer$|int$|short$|byte|long)/i;
    return [$column => boolean().$constraint,$create_index] if $format eq 'boolean';
    return [$column => 'FLOAT'.$constraint,$create_index] if $format =~ /(decimal$|float$|double$)/i;
    if ($format eq 'PMLREF') {
      my ($target,$target_type) = get_pmlref_target_info($decl,$table,$column,1);
      if ((!$opts{'no-schema'} || $opts{'incremental'} ) and
	  (defined($target) or defined($target_type))) {
        if (!$target_type) {
	  $target_type=$target;
	  $target=$root_name;
	}
	my $target_id;
	if ($target_type=~s/[@](.*)$//) {
	  $target_id=$1;
	}
	my $comment = "Updating PMLREF column: $table/$column refers to nodes in $target of type $target_type";
	if ($opts{syntax} eq 'postgres') {
	  $fh{'#POST_SQL'}->print("\\echo $comment\n");
	} elsif ($opts{syntax} eq 'oracle') {
	  $fh{'#POST_SQL'}->print("prompt $comment\n");
	} else {
	  $fh{'#POST_SQL'}->print("-- $comment\n");
	}
	my $col = $column;
	$col=~s/\.rf$//;
	$table = rename_type($table);
	my $tt;
	if ($target eq $root_name) {
	  $tt = rename_type($target_type);
	} else {
	  $tt = q(' || tab || ');
	}
	my $rename='';
# 	if ($opts{syntax}=~/(oracle|postgres)/) {
# 	  $rename=<<"EOF";
# ALTER TABLE "$table" RENAME COLUMN "#tmp" TO "$col";
# EOF
# 	} else {
# 	  $rename=<<"EOF";
# ALTER TABLE "$table" ADD "$col" INT;
# UPDATE "$table" t SET "$col"="#tmp";
# ALTER TABLE "$table" DROP COLUMN "#tmp";
# EOF
# 	}
	unless ($target_id) {
	  my $target_decl = eval { PMLTQ::Common::QueryTypeToDecl($target_type,$schema,@{$opts{other_schemas}}) };
	  warn $@ if $@;
	  if ($target_decl) {
	    my $decl_is = $target_decl->get_decl_type;
	    if ($decl_is==PML_STRUCTURE_DECL or
		  $decl_is==PML_CONTAINER_DECL) {
	      my ($id_m) = $target_decl->find_members_by_role('#ID');
	      if ($id_m) {
		$target_id = $id_m->get_name;
	      }
	    }
	  }
	  $target_id||='id';
	}
	my $sql = <<"EOF";
UPDATE "$table" t SET "$col"=(SELECT a."#idx" FROM "$tt" a WHERE a."$target_id"=t."$column~") WHERE "$col" IS NULL;
EOF
	unless ($opts{incremental}) {
	  $sql .= <<"EOF";
ALTER TABLE "$table" DROP COLUMN "$column~";
EOF
	}
# 	unless ($opts{'no-schema'}) {
# 	  $sql .= <<"EOF";
# CREATE INDEX "#i_${root_name}_$index_id" ON "$table" ("$col");
# EOF
# 	}
	unless ($target eq $root_name) {
	  if ($opts{syntax} eq 'oracle') {
	    my $execute = join("\n",map {qq(  EXECUTE IMMEDIATE '$_';)} grep /\S/, split /;\s*\n/, $sql)."\n";
	    $sql = <<"EOF"
DECLARE
  tab VARCHAR(40);
BEGIN
  BEGIN
    SELECT "table" INTO tab FROM "#PMLTABLES" WHERE "type"='$target_type';
  EXCEPTION
    WHEN NO_DATA_FOUND THEN
      tab := '$target_type';
  END;
$execute
END;
/

EOF
	  } elsif ($opts{syntax} eq 'postgres') {
	    $sql =~ s/'/''/g;
	    my $execute = join("\n",map {qq(EXECUTE (''$_'');)} grep !/^\s*--/, grep /\S/, split /;\s*\n/, $sql)."\n";
	    $sql = <<"EOF"
CREATE OR REPLACE FUNCTION pml2base__update_pmlref() RETURNS integer AS '
DECLARE
  tab VARCHAR(40);
BEGIN
  SELECT "table" INTO tab FROM "#PMLTABLES" WHERE "type"=''$target_type'';
  IF tab IS NULL THEN tab := ''$target_type'';  END IF;
$execute
  RETURN 1;
END;
' LANGUAGE plpgsql;
SELECT pml2base__update_pmlref();
DROP FUNCTION pml2base__update_pmlref();
EOF
	  }
	}
	$fh{'#POST_SQL'}->print($sql);
	$index_id++;
	#my $fk="";
	#$fk=' FOREIGN KEY REFERENCES "$tt" ("#idx")' if $target eq $root_name;
	{
	  my $col = $column;
	  $col=~s/\.rf$//;
	  return ([$column.'~' => 'STRING()'.$constraint,1], [$col => 'INT',1]);
	}
      }
    }
    return [$column => 'STRING()'.$constraint,$create_index];
  } else {
    my $ref = table_name($decl);
    return [$column => qq{INT${constraint} FOREIGN KEY REFERENCES "$ref" ("#idx")}, 1]
      if ($decl_is==PML_CONTAINER_DECL or $decl_is==PML_STRUCTURE_DECL or $decl_is==PML_SEQUENCE_DECL);
    return [$column => 'INT'.$constraint, $create_index];
  }
}

sub to_filename {
  my ($tab,$ext)=@_;
  $ext ||= 'dump';
  $tab=~s{/}{_0}g;
  if ($tab=~s/__#/__1/s) {
    return $tab.'.'.$ext;
  } else {
    return $root_name.'__'.$tab.'.'.$ext;
  }
}
sub table2filename {
  my ($tab,$ext)=@_;
  $tab=~s{/#content((?:/|$))}{/7content$1}g;
  if ($tab=~/#/) {
    return to_filename($tab,$ext);
  } else {
    $ext ||= 'dump';
    $tab=~s{/}{_0}g;
    return $root_name.'__type_'.$tab.'.'.$ext;
  }
}

sub _abs2rel {
  my ($file)=@_;
  my $base=$opts{'data-dir'}; # we assume base has already been abs-path'ed
  return $file unless defined($base) and length($base);
  if (UNIVERSAL::isa($file,'URI')) {
    if ($file->scheme eq 'file') {
      $file=$file->file;
    } elsif (!$file->scheme) {
      $file->scheme('file');
      $file=$file->file;
    } else {
      return $file;
    }
  }
  $file = Cwd::abs_path($file);
  return File::Spec->abs2rel($file,$base);
}

sub abs2rel {
  my ($file)=@_;
  my $ret = _abs2rel($file);
  croak "Incorrect --data-dir value '$opts{'data-dir'}' (resolved to '$ret') or invalid filename '$file'\n"
    ."Explanation: Paths stored in the database should not start with ../ since this breaks URLs"
      if $ret=~m{^\.\.};
  return $ret;
}

our %node_schema = (
  colspec => [
    ["#idx", 'INT NOT NULL PRIMARY KEY',0],
    ["#r", 'INT NOT NULL', 1],
    ["#lvl", 'INT NOT NULL',0],
    ["#chld", 'INT NOT NULL',0],
    ["#chord", 'INT NOT NULL',0],
    ["#parent_idx", 'INT', 1],
    ["#root_idx", 'INT NOT NULL', 1],
    ["#name", 'STRING()',0],
    ["#type", 'STRING()',0],
    ["#min_ord", 'INT',0],
    ["#max_ord", 'INT',0],
    # ["#ID", 'STRING()',0]
   ],
);

sub convert_schema {
  $schema = shift;
  my ($opts)=@_;
  if ($opts{'load-rename-map'}) {
    open my $fh, '<:utf8', $opts{'load-rename-map'} or die "Cannot load rename map: $!\n";
    while (<$fh>) {
      chomp;
      my ($k,$v)=split /\t/,$_;
      $opts{'rename-type'}{$k}=$v;
    }
    close $fh;
  }
  if ($opts{'rename-type'}) {
    %orig_name=(reverse %{$opts{'rename-type'}});
  } else {
    %orig_name=();
  }

  # in theory, we can now check whether we need #min_ord and #max_ord at all
  # and drop them if not

  $root_name= $opts{prefix}.$schema->get_root_name;
  $node_table = $root_name."__#trees";
  $file_table = $root_name."__#files";
  $references_table = $root_name."__#references";
  my $pmlref_table = $root_name."__#pmlref_map";
  open $fh{'#INIT_SH'},'>',to_filename("init",'sh') || die "$!";
  unless ($opts{'no-schema'}) {
    open $fh{'#INIT_SQL'},'>',to_filename("init",'sql')  || die "$!";
    open $fh{'#DELETE_SQL'},'>',to_filename("delete",'sql')  || die "$!";
  }
  unless ($opts{'no-schema'} and !$opts{'incremental'}) {
    open $fh{'#POST_SQL'},'>',to_filename("postprocess",'sql')  || die "$!";
  }
  open $fh{'#FILE_TABLE'},'>',to_filename($file_table)  || die "$!";
  open $fh{'#REFFILE_TABLE'},'>',to_filename($references_table)  || die "$!";
  open $fh{$node_table},'>',to_filename($node_table)  || die "$!";

  my ($db_cmd,$ldr_cmd,$extra_flags);
  $extra_flags='';
  if ($opts{syntax} eq 'oracle') {
    $db_cmd = 'echo quit | sqlplus';
    $ldr_cmd = 'sqlldr';
  } elsif ($opts{syntax} eq 'postgres') {
    $db_cmd = 'psql';
    $ldr_cmd = 'psql';
  } elsif ($opts{syntax} eq 'db2') {
    $db_cmd = 'db2';
    $ldr_cmd = 'db2';
  }
  if ($opts{'schema'} and !$opts{'incremental'}) {
    $extra_flags.=' --init|--finish'
  }

  $fh{'#INIT_SH'}->print(<<"EOF");
#!/bin/bash

if [ -z "\$1" ]; then

  echo "Usage: \$0$extra_flags -u|--user <db_user> [-d|--database <db_name>] [-w|--password <db_password>] [-h|--host <db_host>] [-p|--port <db_port>] -- [ <db_options> ]"

  exit 1;
fi
db_cmd='$db_cmd'
loader_cmd='$ldr_cmd'

EOF

  $fh{'#INIT_SH'}->print(<<'EOF');
while [ $# -gt 0 ]; do
    case "$1" in
	-u|--user) user=$2; shift 2; ;;
	-d|--database) db=$2; shift 2; ;;
	-w|--password) password=$2; shift 2; ;;
	-h|--host) host=$2; shift 2; ;;
	-p|--port) port=$2; shift 2; ;;
	-c|--db-cmd) db_cmd=$2; shift 2; ;;
	-l|--loader-cmd) loader_cmd=$2; shift 2; ;;
	--init|--finish) task=$2; shift 2; ;;
	--) shift ; break ;;
	*) echo "Unknown argument: $1" ; exit 1 ;;
    esac
done

if [ -z $user ]; then
  echo "Required parameter: -u|--user <db_user> missing"
  exit 1;
fi
if [ -z $db ]; then
  echo "Required parameter: -d|--database <db_name> missing"
  exit 1;
fi

EOF


  if (lc($opts{syntax}) eq 'postgres') {
    $fh{'#INIT_SH'}->print(<<'EOF');
    sql_files=""
    export PGUSER=$user
    export PGDATABASE=$db
    [ -n $host ] && export PGHOST=$host
    [ -n $port ] && export PGPORT=$port
    if [ -n "$password" ]; then
      [ -n "$TMPDIR" ] || TMPDIR="/tmp"
      PGPASSFILE="${TMPDIR}/pgpass.$USER.$$.conf"
      [ -f "$PGPASSFILE" ] && rm "$PGPASSFILE"
      touch "$PGPASSFILE"; chmod 600 "$PGPASSFILE"
      cat <<EOP >> $PGPASSFILE
$host:$port:$db:$user:$password
EOP
      export PGPASSFILE
    fi
    run_sql_commands() {
      sql_files="$sql_files '$1'"
    }
    run_loader_commands() {
      sql_files="$sql_files '$1'"
    }
    finish() {
      load_cmd=$db_cmd
      [ -n "$@" ] && load_cmd="$db_cmd $@"
      eval cat $sql_files | eval "$load_cmd";
      [ -n "$password" ] && rm -f "$PGPASSFILE"
      echo "Finished!"
    }
EOF
  } elsif (lc($opts{syntax}) eq 'oracle') {
    $fh{'#INIT_SH'}->print(<<'EOF');
    ora_login="${user}";
    [ -n "$password" ] && ora_login="${ora_login}/${password}";
    ora_login="${ora_login}@";
    if [ -n "$host" ]; then
      ora_login="${ora_login}${host}";
      [ -n "$port" ] && ora_login="${ora_login}:${port}";
      ora_login="${ora_login}/";
    fi
    ora_login="${ora_login}$db";

    run_sql_commands() {
      echo "Running Oracle SQL commands from '$1'"
      eval "$db_cmd -L -S '${ora_login}' @'$1' \"$@\""
      sleep 0.2;
    }
    run_loader_commands() {
      echo "Running Oracle SQL Loader commands from '$1'"
      eval "$loader_cmd SILENT=ALL USERID='${ora_login}' CONTROL='$1'"
    }
    finish() {
      echo "Finished!"
    }
EOF
  } elsif (lc($opts{syntax}) eq 'db2') {
    $fh{'#INIT_SH'}->print(<<'EOF');
    #FIXME: setup host/port (if it makes sense for DB2)
    connect="$db_cmd connect to '$db' USER '$user'"
    if [ -n $password ]; then
      connect="$connect USING '$password'"
    fi
    eval "$connect"
    run_sql_commands() {
      echo "Running DB2 SQL commands from '$1'"
      eval "$db_cmd -t -f '$1' \"$@\""
      sleep 0.2;
    }
    run_loader_commands() {
      echo "Running Oracle SQL Loader commands from '$1'"
      eval "$db_cmd -t -f '$1' \"$@\""
      sleep 0.2;
    }
    finish() {
      eval "$db_cmd disconnect current"
      echo "Finished!"
    }
EOF
  } else {
    $fh{'#INIT_SH'}->print(<<'EOF');
    run_sql_commands() {
      echo "Should run SQL commands from '$1' (doing nothing)"
    }
    run_loader_commands() {
      echo "Should run SQL Loader commands from '$1' (doing nothing)"
    }
    finish() {
      echo "Finished (doing nothing)!"
      echo
      echo "This script is a dummy stub: when this script was generated, the SQL flavour was not known!"
    }
EOF
  }

  if ($opts{'schema'} and !$opts{'incremental'}) {
    $fh{'#INIT_SH'}->print(<<'EOF');
if [ "@${task}" = "@--init" ]; then
EOF
  }

  $schema{$node_table} = {
    table => $node_table,
    %node_schema,
  };
  $schema{$file_table} = {
    '#decl_order' => 0,
    table => $file_table,
    colspec => [
      ["#idx", 'INT NOT NULL PRIMARY KEY',0],
      ["file", 'STRING()',0],
      ["tree_no", 'INT',0],
      ["top", boolean(),0],
     ],
    col => { file=>0 },
  };
  $schema{$references_table} = {
    '#decl_order' => 0,
    table => $references_table,
    colspec => [
      ["source", 'STRING()',0],
      ["name", 'STRING()',0],
      ["id", 'STRING()',1],
      ["file", 'STRING()',0],
     ],
    col => { file=>0, name=>0, id=>0, source=>0 },
  };


  unless ($opts{'no-schema'}) {
    $fh{'#INIT_SH'}->print(mkload(to_filename("delete",'sql'),{quiet=>1}));
    $fh{'#INIT_SH'}->print(mkload(to_filename("init",'sql')));
    dump_schema($schema);
    for my $decl ($schema->node_types) {
      my $tab = table_name($decl,1);
      $fh{'#INIT_SQL'}->print(qq{INSERT INTO "#PMLTYPES" VALUES('$tab','$root_name');\n});
    }
    $fh{'#DELETE_SQL'}->print(qq{DELETE FROM "#PML" WHERE "root"='$root_name';\n});
    $fh{'#DELETE_SQL'}->print(qq{DELETE FROM "#PMLTYPES" WHERE "root"='$root_name';\n});

    #   $fh{'#INIT_SQL'}->print(qq{CREATE TABLE "" (}.
    # 			    qq{ "ref_type" }.varchar(128).
    # 			    qq{, "ref_table" }.varchar(MAX_NAME_LENGTH).
    # 			    qq{, "target_layer" }.varchar(128).
    # 			    qq{, "target_table" }.varchar(MAX_NAME_LENGTH).
    # 			    qq{, "target_type" }.varchar(128).
    # 			    qq{, "pmref" }.boolean().qq{);\n});
    $fh{'#INIT_SQL'}->print(qq{CREATE TABLE "$pmlref_table" (}.
   		            qq{ "ref_type" }.varchar(128).
			    qq{, "ref_table" }.varchar(MAX_NAME_LENGTH).
			    qq{, "target_layer" }.varchar(128).
			    qq{, "target_table" }.varchar(MAX_NAME_LENGTH).
			    qq{, "target_type" }.varchar(128).qq{);\n});

    $fh{'#DELETE_SQL'}->print(qq{DROP TABLE "$pmlref_table";\n});
    for my $k (sort keys %{$opts{ref}}) {
      my ($t1,$t2) = split /:/,$opts{ref}{$k};
      unless ($t2) {
	$t2=$t1;
	$t1=$root_name;
      }
      my $tab = rename_type($k);
      if ($t1 eq $root_name) {
	my $tab = rename_type($t2);
	$fh{'#INIT_SQL'}->print(qq{INSERT INTO "$pmlref_table" VALUES('$k','$tab','$t1','$tab','$t2');\n});
      } else {
	$fh{'#INIT_SQL'}->print(qq{INSERT INTO "$pmlref_table" VALUES('$k','$tab','$t1',}.
				  qq{(SELECT "table" FROM "#PMLTABLES" WHERE "type"='$t2'),'$t2');\n});
	$fh{'#INIT_SQL'}->print(qq{UPDATE "$pmlref_table" SET ("target_table")=('$t2') }.
				  qq{WHERE "ref_type"='$k' AND "target_table" IS NULL;\n});
      }
    }
  }

  my $decl_order=10;
  $schema->for_each_decl(
    sub {
      my ($decl)=@_;
      my $decl_is = $decl->get_decl_type;
      return if ($decl->get_role||'') eq '#CHILDNODES';
      return if $decl_is == PML_TYPE_DECL or $decl_is==PML_ROOT_DECL;
      my $p=$decl->get_parent_decl;
      if ($p and $p->get_decl_type == PML_MEMBER_DECL
	    and ($p->get_role||'') eq '#CHILDNODES') {
	return;
      }
      my $table = table_name($decl);
      my $desc;
      my $is_node = (($opts{no_tree_table}||$opts{hybrid}) && (($decl->get_role||'') eq '#NODE')) ? 1  : 0;
      if ($decl_is == PML_STRUCTURE_DECL) {
	my @m = grep {
	  (!defined($_->get_role) or $_->get_role ne '#CHILDNODES')
	    and (($_->get_content_decl && $_->get_content_decl->get_role ||'') ne '#TREES')
	  } $decl->get_members;
	$desc = {
	  table=> $table,
	  colspec => [
	    ($is_node ? @{$node_schema{colspec}} : ['#idx', 'INT NOT NULL PRIMARY KEY', 0]),
	    map column_spec($table,$_->get_knit_name,$_->get_knit_content_decl,$_->is_required,$_->get_role),
	    @m
	   ],
	 };
      } elsif ($decl_is == PML_CONTAINER_DECL) {
	my ($content_decl) = grep {
	  (!defined($_->get_role) or $_->get_role ne '#CHILDNODES')
	    and ((($_->get_content_decl && $_->get_content_decl->get_role) ||'') ne '#TREES')
	      } grep defined, $decl->get_knit_content_decl;
	$desc = {
	  table=> $table,
	  colspec => [
	    ($is_node ? @{$node_schema{colspec}} : ['#idx', 'INT NOT NULL PRIMARY KEY']),
	    ($content_decl ? column_spec($table,"#content",$content_decl,$content_decl->get_role) : ()),
	    map column_spec($table,$_->get_name,$_->get_content_decl,$_->is_required,$_->get_role), $decl->get_attributes
	   ],
	};
      } elsif ($decl_is == PML_SEQUENCE_DECL) {
	$desc = {
	  table=> $table,
	  colspec => [
	    ["#idx", 'INT NOT NULL PRIMARY KEY',0],
	    map [$_->get_name,'INT',1], $decl->get_elements
	   ],
	 };
      } elsif ($decl_is == PML_ELEMENT_DECL) {
	my $content_decl = $decl->get_knit_content_decl;
	$table = '#e_'.table_name($content_decl);
	$desc = {
	  table=> $table,
	  colspec => [
	    ["#idx",'INT'],
	    ["#pos",'INT'],
	    ["#elpos",'INT'],
	    column_spec($table,'#value',$content_decl,$content_decl->get_role)
	   ]
	 };
      } elsif ($decl_is == PML_LIST_DECL) {
	my $content_decl = $decl->get_knit_content_decl;
	$desc = {
	  table=> $table,
	  colspec => [
	    ["#idx",'INT',1],
	    ($decl->is_ordered ? ["#pos",'INT'] : ()),
	    column_spec($table,'#value',$content_decl,$content_decl->get_role),
	   ]
	 };
      } elsif ($decl_is == PML_ALT_DECL) {
	my $content_decl = $decl->get_knit_content_decl;
	$desc = {
	  table=> $table,
	  colspec => [
	    ["#idx",'INT',1],
	    column_spec($table,'#value',$content_decl,$content_decl->get_role),
	   ]
	 };
      } elsif ($decl_is == PML_CHOICE_DECL) {
      } elsif ($decl_is == PML_CONSTANT_DECL) {
      } elsif ($decl_is == PML_CDATA_DECL) {
      } elsif ($decl_is == PML_ATTRIBUTE_DECL
	       || $decl_is == PML_MEMBER_DECL
	       || $decl_is == PML_ELEMENT_DECL) {
	#    print $decl->get_parent_decl->get_decl_path,"/[".$decl->get_name,"]\n";
      } else {
	print STDERR "Unexpected decl: ",$decl->get_decl_type_str,"\n";
      }
      if ($desc) {
	warn "couldn't determine table name for decl $decl\n" if !defined $table;
	$desc->{'#decl_order'}=$decl_order++;
	$schema{$desc->{table}}=$desc;
	unless ($opts{schema}) {
	  my $fn = table2filename($desc->{table});
	  open $fh{$desc->{table}},'>',$fn or  die "Cannot open '$fn' for writing: $!";
	}
      }
    });
  if ($opts and ref $opts->{for_schema}) {
    $opts->{for_schema}->($schema,\%schema,\%fh);
  }

  if ($opts{'load-idx'}) {
    if (open my $fh, '<:', $opts{'load-idx'}) {
      $_ = <$fh>;
      chomp;
      ($idx, $node_idx) = split /\t/,$_,2;
      close $fh;
    } else {
      warn "Cannot load idx info: $!\n";
    }
  }
  if ($opts{'load-col-info'}) {
    open my $fh, '<:utf8', $opts{'load-col-info'} or die "Cannot load rename map: $!\n";
    while (<$fh>) {
      chomp;
      my ($table,$column,$length,$non_ascii)=split /\t/,$_;
      my $l = $schema{$table}{col}{$column}||0;
      $schema{$table}{col}{$column} = $length if $length>$l;
      $schema{$table}{non_ascii}{$column} ||= $non_ascii;
    }
    close $fh;
  }
}


# this function creates a loader that loads a PML schema into the database
# and stores information about the schema in the #PML table
sub dump_schema {
  my ($schema,$append)=@_;
  return if $opts{'no-schema'};
  my $root_name = $schema->get_root_name;
  return if ($seen_ref_schema{$root_name});
  $seen_ref_schema{$root_name}=1;
  $root_name = $opts{prefix}.$root_name;

  my $data_dir = $opts{'data-dir'};
  my $filename= _abs2rel($schema->get_url);
  if ($filename=~/\.\./) {
    $filename = "".$schema->get_url; # using absolute URL
  }

  my $flags = MAX_MIN_ORD | TOP_TREE_FLAG;
  $flags |= HYBRID if $opts{hybrid};
  $flags |= NO_TREE_TABLE if $opts{no_tree_table};

  if (lc($opts{syntax}) eq 'postgres') {
    my $schema_dump = "${root_name}__schema.dump";
    my $blob;
    $schema->write({string=>\$blob});
    open(my $fh, '>', $schema_dump);
    my $r=$root_name;

    s{(\\|\n|\r|\^)}{\\$1}g for $r,$filename,$data_dir,$blob;
    print $fh ($r.'^',
	       $filename.'^',
	       $data_dir.'^',
	       $flags.'^',
	       $blob
	      );
    close $fh;
    my $ctl = "${root_name}__pml_init.ctl";
    open $fh, ($append ? '>>' : '>'), $ctl;
    print $fh <<"EOF";
\\echo Loading PML meta-table
\\copy "#PML" ("root", "schema_file", "data_dir", "flags", "schema") from '$schema_dump' delimiter '^'
EOF
    close $fh;
    $fh{'#INIT_SH'}->print(mkdataload($ctl));
    #print $fh{'#INIT_SH'}(qq{sleep 0.2; echo quit | sqlldr SILENT=ALL USERID="\$login" CONTROL="$ctl"\n});
  } elsif (lc($opts{syntax}) eq 'oracle') {
    my $schema_dump = $root_name."__schema.pml";
    $schema->write({filename=>$schema_dump});
    my $ctl = $root_name."__pml_init.ctl";
    open my $fh, '>', $ctl;
    print $fh <<"EOF";
LOAD DATA CHARACTERSET UTF8 LENGTH SEMANTICS CHAR
INFILE *
APPEND
INTO TABLE "#PML"
FIELDS TERMINATED BY ','
(
 "root",
 "schema_file",
 "data_dir",
 "flags",
 "filename" FILLER,
 "schema" LOBFILE ("filename") TERMINATED BY EOF
)
BEGINDATA
$root_name,$filename,$data_dir,$flags,$schema_dump
EOF
    close $fh;
    $fh{'#INIT_SH'}->print(mkdataload($ctl));
  } elsif (lc($opts{syntax}) eq 'db2') {
    my $schema_pml = $root_name."__schema.pml";
    my $schema_dump = $root_name."__schema.dump";
    $schema->write({filename=>$schema_pml});
    my $fh;
    my $r=$root_name;
    open $fh, '>', $schema_dump;
    print $fh qq{$r,$filename,$data_dir,$schema_pml\n};
    close $fh;
    my $ctl = to_filename("pml_init",'ctl');
    open $fh, '>', $ctl;
    print $fh <<"EOF";
IMPORT FROM  '$schema_dump' OF DEL LOBS FROM '.'
COMMITCOUNT 400 INSERT INTO "#PML";
EOF
    close $fh;
    $fh{'#INIT_SH'}->print(mkdataload($ctl));
  }
}

sub analyze_string {
  my ($table,$column,$string)=@_;
  return unless defined $string;
  my $l = length($string) || 0;
  if ($opts{'enforce-col-info'}) {
    for ($schema{$table}{col}{$column}||0) {
      if ($l > $_) {
	warn "Truncating value in table $table, column $column from $l to $_ chars\n";
	$_[2] = substr($string,0,$_);
      }
    }
    warn "NON-ASCII value in table $table, column $column\n"  if !$schema{$table}{non_ascii}{$column} and $string=~/[^[:ascii:]]/;
  } else {
    for ($schema{$table}{col}{$column}) {
      $l+=10 if $opts{incremental};
      $_=$l if $l > ($_||0)
    }
    $schema{$table}{non_ascii}{$column}=1 if $string=~/[^[:ascii:]]/;
  }
}

sub dump_typemap {
  my $typemap = $opts{'rename-type'};
  return unless ref $typemap;
  my ($type_name, $table_name);
  while (($type_name,$table_name)=each %$typemap) {
    if (exists $schema{$table_name}) {
      # qq{DELETE FROM "#PMLTABLES" WHERE "type"='$type_name';\n}.
      $fh{'#INIT_SQL'}->print(qq{INSERT INTO "#PMLTABLES" VALUES('$type_name','$table_name');\n});
      $fh{'#DELETE_SQL'}->print(qq{DELETE FROM "#PMLTABLES" WHERE "type"='$type_name';\n});
    }
  }
}

sub convert_references {
  my ($source,$schema,$references,$refnames,$refdata,$opts)=@_;
  return unless keys %$references;
  $source = abs2rel($source);
  analyze_string($references_table,source =>$source);
  my %name = map {
    my $name = $_;
    my $ids = $refnames->{$name};
    ref($ids) ? (map { $_ => $name } @$ids) : ( $ids => $name )
  } keys %$refnames;
  my ($id,$reffile,$name);
  while (($id,$reffile)=each %$references) {
    $name = $name{$id};
    my $r = $schema->get_named_reference_info($name);
    next unless $r and $r->{readas}; # skip references that are not requried
    my $file = abs2rel($reffile);
    analyze_string($references_table,name =>$name);
    analyze_string($references_table,id =>$id);
    analyze_string($references_table,file =>$file);
    $fh{'#REFFILE_TABLE'}->print(mkdump($source,$name,$id,$file));
    if ($r->{readas} eq 'pml' and ref($refdata)) {
      # we need to extract the schema
      my $refpml = $refdata->{$id};
      if (UNIVERSAL::DOES::does($refpml,'Treex::PML::Instance')) {
	my $ref_schema = $refpml->get_schema;
	# dump_schema($ref_schema);
	convert_references($reffile,
		     $ref_schema,
		     $refpml->get_references_hash,
		     $refpml->get_refname_hash,
		     $refpml->get_ref($id),
		     $opts);
      }
    }
  }
}

sub col_val {
  my ($decl,$table,$col,$str)=@_;
  if (get_pmlref_target_info($decl,$table,$col)) {
    # the column named "$col" will contain #idx pointers
    # the culumn "$col~" will contain the original PMLREF
    $col.='~';
  }
  return $col => val($decl,$table,$col,$str);
}

sub val {
  my ($decl,$table,$col,$str)=@_;
  if (ref($str)) {
    Carp::confess("Attempt to store a reference $str as vchar in table $table, column $col");
  }
  analyze_string($table,$col => $str);
  if (defined($str) and $decl and $decl->get_decl_type == PML_CDATA_DECL and $decl->get_format eq 'PMLREF') {
    $str=~s/^.+?#// if defined $str;
  }
  if ($decl and !(defined $str and length $str)) {
    my $def = $opts{defaults}{ table_name($decl) };
    $str=$def if defined $def;
  }
  return $str;
}

sub table_name {
  my ($decl,$no_rename) = @_;
  confess("missing decl") unless $decl;
  my $path = $decl->get_decl_path;
  if (!$path) {
    my $parent_is = $decl->get_parent_decl->get_decl_type;
#    warn("Couldn't determine table name for $decl with parent ".$decl->get_parent_decl."\n");
    return rename_type('/'.$decl->get_parent_decl->get_name,$no_rename) if $parent_is==PML_ROOT_DECL;
    if ($parent_is==PML_STRUCTURE_DECL or
	$parent_is==PML_SEQUENCE_DECL or
	$parent_is==PML_CONTAINER_DECL) {
      my $name = $decl->get_name;
      $path = table_name($decl->get_parent_decl,1);
#      print "result: $path/$name\n";
      return rename_type($path.'/'.$name,$no_rename) if $path;
    }
    $decl->write({fh=>\*STDERR});
    confess("Couldn't determine table name for $decl with parent ".$decl->get_parent_decl."\n");
  }
  $path=~s{^/}{ '/'.$decl->get_schema->get_root_name.'/' }e;
  $path = PMLTQ::Common::DeclPathToQueryType($path);
  return rename_type($path,$no_rename);
}


sub rename_type {
  my ($table_name,$no_rename)=@_;
  return $table_name if $no_rename;
  $table_name=$opts{prefix}.$table_name;
  if ($opts{'rename-type'} and
	$opts{'rename-type'}{$table_name}) {
    $table_name=$opts{'rename-type'}{$table_name};
  } elsif (length($table_name)>MAX_NAME_LENGTH) {
    my $new_name = $opts{'rename-type'}{$table_name} = $root_name.'##'.($last_type_no++);
    $orig_name{$new_name}=$table_name;
    warn "renaming table for type '$table_name' to '$new_name'\n" if $opts{debug};
    $table_name = $new_name;
  }
  return $table_name;
}


sub traverse_data {
  my ($decl,$value,$index,$opts)=@_;
  $opts||={};
  my $table = delete($opts->{'#table'}) || table_name($decl);
  my $decl_is = $decl->get_decl_type;
  $index=$idx++ unless defined $index;
  my $is_tree = UNIVERSAL::DOES::does($value,'Treex::PML::Node') && !$value->parent? 1 : 0;
  my $desc;
  if ($decl_is == PML_STRUCTURE_DECL) {
      $is_tree = 1 if ($opts{is_treex} and ($decl->get_structure_name || '') =~ /[atn]-root/);
    my %midx;
    my @members = grep {
      (!defined($_->get_role) or $_->get_role ne '#CHILDNODES')
	and (($_->get_content_decl && $_->get_content_decl->get_role ||'') ne '#TREES')
	} $decl->get_members;
    $desc = {
      '#table' => $table,
      '#idx' => ($is_tree ? new_tree($value,$desc) : $index),
    };
    for (@members) {
      my $n = $_->get_knit_name;
      my $v = $value->{$n};
      my $d = $_->get_knit_content_decl;
      if (defined($v) and !$d->is_atomic) {
	my $mdump = traverse_data($d,$v);
	$desc->{$n} = data_index($mdump);
      } else {
	my ($key,$value) = col_val($d,$table,$n,$v);
	$desc->{$key} = $value;
      }
    }
    $desc=traverse_subtree($value,$desc,$opts) if $is_tree;
  } elsif ($decl_is == PML_CONTAINER_DECL) {
    my $midx;
    my @attrs = $decl->get_attributes;
    $desc = {
      '#table' => $table,
      '#idx' => ($is_tree ? new_tree($value,$desc) : $index),
      map {
	my $n = $_->get_name;
	my $v = $value->{$n};
	col_val($_->get_content_decl,$table,$n,$v)
      } @attrs
    };
    my $knit_content_decl = $decl->get_knit_content_decl;
    my $content_decl = $decl->get_content_decl;
    my $role = ($content_decl && $content_decl->get_role)||'';
    if (defined($content_decl) and $role ne '#CHILDNODES' and $role ne '#TREES') {
      if ($knit_content_decl and defined($value->{'#content'})) {
	if ($knit_content_decl->is_atomic) {
	  my ($key,$value) = col_val($knit_content_decl,$table,'#content',$value->{'#content'});
	  $desc->{$key} = $value;
	} else {
	  $desc->{'#content'} = data_index(traverse_data($knit_content_decl,$value->{'#content'}));
	}
      } else {
	$desc->{'#content'} = undef;
      }
    }
    $desc=traverse_subtree($value,$desc,$opts) if $is_tree;
  } elsif ($decl_is == PML_SEQUENCE_DECL) {
    my %midx;
    my @elems = $decl->get_elements;
    $desc = {
      '#table' => $table,
      '#idx'   => $index,
      map {
	my $n = $_->get_name;
	$n => ($midx{$n}=$idx++)
      } @elems
    };
    my %epos;
    my $i=0;
    for (@{$value->elements_list}) {
      my $n = $_->name;
      my $v = $_->value;
      my $e = $decl->get_element_by_name($n);
      traverse_data($e,$v,$midx{$n},{
	'#table'=>'#e_'.table_name($e->get_knit_content_decl),
	'#pos'=>$i++,
	'#elpos' => ($epos{$n}++||0),
      });
    }
  } elsif ($decl_is == PML_ELEMENT_DECL) {
    my $content_decl=$decl->get_knit_content_decl;
    my $compact = !defined($value) || $content_decl->is_atomic;
    $desc = {
      '#table'=> $table,
      '#idx', => $index,
      %$opts,
     };
    if ($compact) {
      my ($key,$value) = col_val($content_decl,$table,'#value',$value);
      $desc->{$key} = $value;
    } else {
      $desc->{'#value'} = data_index(traverse_data($content_decl,$value));
    }
  } elsif ($decl_is == PML_LIST_DECL || $decl_is == PML_ALT_DECL) {
    if ($decl_is == PML_ALT_DECL and !UNIVERSAL::DOES::does($value,'Treex::PML::Alt')) {
      $value=Treex::PML::Alt->new($value);
    }
    my $content_decl=$decl->get_knit_content_decl;
    my $atomic = $content_decl->is_atomic;
    my $ordered = ($decl_is == PML_LIST_DECL and $decl->is_ordered);
    my $i=0;
    $desc = [];
    if ($atomic) {
      for my $v ($value->values) {
	push @$desc, {
	  '#table'=>$table,
	  '#idx'=>$index,
	   col_val($content_decl,$table,'#value',$v),
	  ($ordered ? ('#pos'=>$i++) : ()),
	};
      }
    } else {
      for my $v ($value->values) {
	push @$desc, {
	  '#table'=>$table,
	  '#idx'=>$index,
	  '#value'=> defined($v) && data_index(traverse_data($content_decl,$v)),
	  ($ordered ? ('#pos'=>$i++) : ()),
	};
      }
    }
  } elsif ($decl_is == PML_CHOICE_DECL || $decl_is == PML_CONSTANT_DECL || $decl_is == PML_CDATA_DECL) {
    confess("traversing atomic type\n");
  } else {
    die "unhandled data type: $decl\n";
  }
#  print "$decl\n" unless defined $desc;
#  print Dumper($desc) if $desc;
  dump_data_desc($desc) unless $opts->{no_dump};
  return $desc;
}

sub data_index {
  my ($desc)=@_;
  $desc = $desc->[0] if ref($desc) eq 'ARRAY';
  return defined($desc) ? $desc->{'#idx'} : undef;
}

sub dump_data_desc {
  my ($desc)=@_;
  for my $desc_item (ref($desc) eq 'ARRAY' ? @$desc : $desc) {
    my %d = (%$desc_item);
    my $table = delete $d{'#table'};
    confess( "no #table:".Dumper(\%d) ) unless defined $table;
    my @columns = map $_->[0],@{$schema{$table}{colspec}};
    if (defined $fh{$table}) {
      $fh{$table}->print(mkdump(delete @d{@columns}));
      die "The following columns were left in a row for table $table: "
	.join(',',keys %d)."\n"
	  ."expected: ".join(',',@columns)."\n"
	    if keys %d;
    } else {
      die "Error: didn't find any filehandle for table $table\n";
    }
  }
}

sub new_tree {
  my ($node,$desc,$opts)=@_;
  my $idx = ++$node_idx;
  $node_idx=$idx + $node->descendants; # reserve a span in the node indexing sequence for this tree
  my $primary = (!defined($last_tree_no) || ($last_tree_no != $tree_no)) ? 1 : 0;
  $fh{'#FILE_TABLE'}->print(mkdump($idx,$filename,$tree_no,$primary)); # FIXME: wont work for bundles
  $last_tree_no = $tree_no;
  return $idx;
}

sub traverse_subtree {
  my ($node,$desc,$opts)=@_;
  my $idx=$desc->{'#idx'};
  my $root_idx = $idx;
  my $lvl=0;
  my %hash;
  my $tree=$node;
    while ($node) {
    my $parent = $node->parent;
    unless (defined $hash{$node}) {
      $hash{$node} = {};
      $hash{$node}{'#table'} = $node_table;
      $hash{$node}{'#data'} = $parent ?
	traverse_data($node->type,
		      $node,
		      ++$idx,
		      {%$opts,
		       no_dump => 1,
		       root_idx=>$root_idx})
	  : $desc;
      #$hash{$node}{'#ID'}=$node->get_id;
      $hash{$node}{'#idx'}=$hash{$node}{'#data'}{'#idx'};
      $hash{$node}{'#chld'}  = 0;
      my $name = $node->{'#name'};
      my $type = $hash{$node}{'#data'}{'#table'};
      if (defined($name) and length($name)) {
	val(undef,$node_table,'#name',$name);
	$hash{$node}{'#name'}  = val(undef,$type,'#name',$name);
      }
      val(undef,$node_table,'#type',table_name($node->type,1));
      $hash{$node}{'#type'}  = val(undef,$type,'#type',table_name($node->type,1));
      $hash{$node}{'#chord'} = $parent ? $hash{$parent}{'#chld'}++ : 0;
      $hash{$node}{'#lvl'}   = $parent ? $hash{$parent}{'#lvl'}+1 : 0;
      $hash{$node}{'#parent_idx'} = $parent ? $hash{$parent}{'#idx'} : undef ;
      $hash{$node}{'#root_idx'}  = $root_idx;
      $hash{$node}{'#min_ord'} = $hash{$node}{'#max_ord'} = $node->get_order;
      if ($node->firstson) {
	$node = $node->firstson;
	next;
      }
    }
    $hash{$node}{'#r'} = $idx;
    my ($min_ord,$max_ord)=@{$hash{$node}}{'#min_ord', '#max_ord'};
    if ($parent and defined($min_ord) and !defined($parent->get_order)) {
      my $hp=$hash{$parent};
      $hp->{'#min_ord'} = $min_ord
	if (!defined($hp->{'#min_ord'}) or $hp->{'#min_ord'} > $min_ord);
      $hp->{'#max_ord'} = $max_ord
	if (!defined($hp->{'#max_ord'}) or $hp->{'#max_ord'} < $max_ord);
    }
    if (ref $opts{for_each_node}) {
      $opts{for_each_node}->($node,\%hash,\%fh);
    }
    $node = $node->rbrother || $parent;
  }
  if (ref $opts{for_each_tree}) {
    $opts{for_each_tree}->($tree,\%hash,\%fh);
  }
  return [ map {
    my $h = $_->[1];
    my $data = delete $h->{'#data'};
    $opts{no_tree_table} ? { %$h, %$data } :
    $opts{hybrid}        ? ({ %$h, %$data }, $h)
                         : ($data, $h)
  } sort { $a->[0]<=>$b->[0] }
    map  { [$_->{'#idx'},$_] } values %hash
  ];
}

sub is_treex_document {
    my $fs = shift;
    return ($fs->metaData('schema') && $fs->metaData('schema')->get_root_name eq 'treex_document') ? 1:0;
}

sub fs2base {
  my ($fs,$opts)=@_;
  $opts||={};

  # prepare global option
  $opts{'data-dir'}=Cwd::abs_path($opts{'data-dir'}) if $opts{'data-dir'};
  $opts{for_each_tree} = $opts->{for_each_tree};
  $opts{for_each_node} = $opts->{for_each_node};

  ## little hack for treex files
  if (is_treex_document($fs)) {
      require Treex::Core::Document;
      Treex::Core::Document->new({pmldoc => $fs}); ## rebless all nodes
      $opts{is_treex}=1;
      print "Converting to Treex document\n";
  }

  if (!$schema) {
    convert_schema($fs->metaData('schema'),$opts);
    dump_typemap() unless $opts{'no-schema'};
  }
  my $f = $filename = $fs->filename;
  $filename = abs2rel($filename);

  convert_references($f,
		     $schema,
		     $fs->metaData('references'),
		     $fs->metaData('refnames'),
		     $fs->appData('ref'),
		     $opts);
  analyze_string($file_table,file => $f);
  my $trees_type =$fs->metaData('pml_trees_type');
  if ($trees_type->get_decl_type == PML_MEMBER_DECL) {
    $trees_type = $trees_type->get_content_decl;
  }
  traverse_data(
    $trees_type,
    $fs->metaData('pml_prolog'),
   ) if $fs->metaData('pml_prolog');
  traverse_data(
    $fs->metaData('schema')->get_root_type,
    $fs->metaData('pml_root'),
   ) if $fs->metaData('pml_root');

  $tree_no=0;
  for my $tree ($fs->trees) {
    traverse_data($tree->type, $tree,undef,$opts);
    $tree_no++;
  }
  traverse_data(
    $trees_type,
    $fs->metaData('pml_epilog'),
   ) if $fs->metaData('pml_epilog');
}

sub finish {
  if (defined $opts{'max-node-idx'} and $node_idx>$opts{'max-node-idx'}) {
    warn("NODE_IDX EXCEEDED LIMIT: next $node_idx, limit $opts{'max-node-idx'}");
  }
  if (defined $opts{'max-idx'} and $idx>$opts{'max-idx'}) {
    warn("DATA_IDX EXCEEDED LIMIT: next $idx, limit $opts{'max-idx'}");
  }
  if ($opts{incremental}) {
    if ($opts{syntax} eq 'postgres') {
      $fh{'#POST_SQL'}->print(qq{UPDATE "#PML" SET ("last_idx","last_node_idx")=($idx,$node_idx)}.
				qq{ WHERE "root"='$root_name';\n});
    } else {
      $fh{'#POST_SQL'}->print(qq{UPDATE "#PML" SET ("last_idx","last_node_idx")=(SELECT $idx,$node_idx FROM DUAL)}.
				qq{ WHERE "root"='$root_name';\n});
    }
  }
  if ($opts{'dump-rename-map'}) {
    open my $fh, '>:utf8', $opts{'dump-rename-map'};
    my ($k,$v);
    while (($k,$v)=each %{$opts{'rename-type'}}) {
      print $fh "$k\t$v\n";
    }
    close $fh;
  }

  my @tables = sort {($a->{'#decl_order'}||0)<=>($b->{'#decl_order'}||0)} values %schema;
  unless ($opts{'no-schema'}) {
    for my $desc (reverse @tables) {
      $fh{'#INIT_SQL'}->print(qq{CREATE TABLE "$desc->{table}" (\n    },
			      join(",\n    ",
				   map {
				     my ($c,$t)=@$_;
				     if ($t=~/STRING\(\)/i) {
				       my $l = $desc->{col}{$c}||=0;
				       my $non_ascii = $desc->{non_ascii}{$c}||=0;
				       warn ("length for $c in $desc->{table} is 0; changing to 1\n") if !$l;
				       $l||=1;
				       $t=~s/STRING\(\)/varchar($l,$non_ascii)/ieg;
				     }
				     $t=~s/ FOREIGN KEY.*$//;
				     qq{"$c" $t}
				   } @{$desc->{colspec}}
				  ), "\n);\n");
      for (@{$desc->{colspec}}) {
	if ($_->[2]) {
	  $fh{'#INIT_SQL'}->print(qq{CREATE INDEX "#i_${root_name}_$index_id" ON "$desc->{table}" ("$_->[0]");\n});
	  $index_id++;
	}
      }
    }
    for my $desc (@tables) {
      my $sugar = $opts{syntax} eq 'oracle' ? 'CONSTRAINTS' : '';
      $fh{'#DELETE_SQL'}->print(qq{DROP TABLE "$desc->{table}" CASCADE $sugar;\n});
    }
  }
  unless ($opts{'schema'}) {
    for my $desc (reverse @tables) {
      my $t = $desc->{table};
      my $dump = table2filename($t);
      my $ctl=table2filename($t,'ctl');
      open LOAD_SQL,'>',$ctl;
      my $replace = $opts{'no-schema'} ? "APPEND" : "REPLACE";
      if (lc($opts{syntax}) eq 'postgres') {
	my $cols = join ',', map { qq{"$_->[0]"} } @{$desc->{colspec}};
	print LOAD_SQL qq{\\echo Loading data to table "$t"\n};
	print LOAD_SQL qq{\\copy "$t" ($cols) from '$dump'\n};
      } elsif (lc($opts{syntax}) eq 'oracle') {
	my $cols = join ',', map { qq{"$_->[0]"}
				     .( $_->[1]=~/STRING/ ? q{CHAR(}.(($desc->{col}{$_->[0]}||0) || 1).q{)} : '')
				   }
	  @{$desc->{colspec}};
	my $bad = table2filename($t,'bad');
	my $rej = table2filename($t,'rej');
	print LOAD_SQL <<"EOF";
LOAD DATA CHARACTERSET UTF8 LENGTH SEMANTICS CHAR
INFILE '$dump'
BADFILE '$bad'
DISCARDFILE '$rej'
${replace}
INTO TABLE "$t"
FIELDS TERMINATED BY '\t'
TRAILING NULLCOLS
($cols)
EOF
      } elsif (lc($opts{syntax}) eq 'db2') {
	  print LOAD_SQL qq{IMPORT FROM '$dump' OF DEL MODIFIED BY COLDELX09 COMMITCOUNT 400 $replace INTO "$t";\n};
	}
      close LOAD_SQL;
      $fh{'#INIT_SH'}->print(mkdataload($ctl));
    }
  }
  if ($opts{'no-schema'}) {
    if ($opts{incremental}) {
      $fh{'#INIT_SH'}->print(mkload(to_filename("postprocess",'sql')));
    }
  } else {
    if ($opts{'schema'}  and !$opts{'incremental'}) {
      $fh{'#INIT_SH'}->print(q(elif [ "@${task}" = "@--finish" ]; then)."\n");
    }
    $fh{'#INIT_SH'}->print(mkload(to_filename("postprocess",'sql')));
    unless ($opts{incremental}) {
      for my $desc (values %schema) {
	for my $col (@{$desc->{colspec}}) {
	  my ($c,$t)=@$col;
	  if ($t = m/ (FOREIGN KEY) (.*)$/) {
	    $fh{'#POST_SQL'}->print(qq{ALTER TABLE "$desc->{table}" ADD $1("$c") $2;\n});
	  }
	}
      }
    }
    if ($opts{syntax} eq 'postgres') {
      for my $desc (values %schema) {
	$fh{'#POST_SQL'}->print(qq{VACUUM FULL ANALYZE "$desc->{table}";\n});
      }
    }
    if ($opts{syntax} eq 'oracle') {
      $fh{'#DELETE_SQL'}->print(qq{PURGE RECYCLEBIN;\n});
      $fh{'#POST_SQL'}->print(qq{EXECUTE DBMS_STATS.GATHER_SCHEMA_STATS(NULL,DBMS_STATS.AUTO_SAMPLE_SIZE);\n});
    }
    if ($opts{'schema'} and !$opts{'incremental'}) {
      $fh{'#INIT_SH'}->print(q(fi)."\n");
    }
  }
  $fh{'#INIT_SH'}->print(qq{\nfinish;\n});

  if ($opts{'dump-idx'}) {
    open my $fh, '>', $opts{'dump-idx'};
      print $fh "$idx\t$node_idx\n";
    close $fh;
  }
  if ($opts{'dump-col-info'}) {
    open my $fh, '>:utf8', $opts{'dump-col-info'};
    foreach my $table (keys %schema) {
      if ($schema{$table}{col}) {
	foreach my $column (keys %{$schema{$table}{col}}) {
	  my $length=$schema{$table}{col}{$column}||0;
	  my $non_ascii=$schema{$table}{non_ascii}{$column}||0;
	  print $fh "$table\t$column\t$length\t$non_ascii\n";
	}
      }
    }
  }

  close $_ for values %fh;

}





1; # End of PMLTQ::PML2BASE

__END__

=pod

=encoding UTF-8

=head1 NAME

PMLTQ::PML2BASE - Convert from PML to SQL

=head1 VERSION

version 0.8.3

=head1 DESCRIPTION

This module contans functions that generate SQL schema and data
loaders for a given set of PML documents that adher to
a common PML schema.

=head1 AUTHORS

=over 4

=item *

Petr Pajas <pajas@ufal.mff.cuni.cz>

=item *

Jan Štěpánek <stepanek@ufal.mff.cuni.cz>

=item *

Michal Sedlák <sedlak@ufal.mff.cuni.cz>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2014 by Institute of Formal and Applied Linguistics (http://ufal.mff.cuni.cz).

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
