# jinx.pl -- Copyright (c) 1990, Henk P. Penning.
# You may distribute under the terms of the GNU General Public License
# as specified in the README file that comes with the Jinx 2.0 kit.

sub addlog { ; }

sub min
  { return(undef) if $#_ < 0 ;
    local($res) = shift ;
    for ( @_ )
      { $res = $_ if $_ < $res ; }
    return($res) ;
  }

sub max
  { return(undef) if $#_ < 0 ;
    local($res) = shift ;
    for ( @_ )
      { $res = $_ if $_ > $res ; }
    return($res) ;
  }

sub maxStrlen
  { local(*row,$from,$to) = @_ ;
    local($res,$len,$i) ;
    $to = &min($to,$#row) ;
    for ($i=$from ; $i <= $to ; $i++ )
      { $len = length($row[$i]) ;
        $res = $len if $len > $res ;
      }
    return($res) ;
  }

sub tailstr
  { local($str,$from) = @_ ;
    local($l) = length($str) ;
    if ( $from > $l - 1)
      { return('') ; }
    else
      { return(substr($str,$from,$l-$from)) ; }
  }

sub extint
  { local($_) = @_ ;
    local($res,$pref) ;
    while ( /!(.)/ )
      { $pref = $` ;
	{ $pref =~ s/:/$;/g ; }
        $res .= ( $pref . $1 ) ;
	$_ = $' ;
      }
    s/:/$;/g ;
    $res .= $_ ;
    return $res ;
  }

sub intext
  { local($_) = @_ ;
    s/!/!!/g ;
    s/:/!:/g ;
    s/$;/:/g ;
    return $_ ;
  }

sub getInfo
  { local(*info,$db,$suff) = @_ ;
    local($_) ;
    if ( open(INFO,"$db.$suff") )
      { &addlog("opened $db.$suff") ; }
    else
      { return(0) ; }
    @info = () ;
    while ($_ = <INFO>)
      { chop ;
        push(@info,&extint($_)) ;
      }
    close(INFO) ;
    &addlog("closed $db.$suff") ;
    return(1) ;
  }

sub putInfo
  { local(*info,$db,$suff) = @_ ;
    local($_,$save) = 0 ;

    $save = -e "$db.$suff" ;

    return(0,"no write permission for $db.$suff")
      if $save && ! -w "$db.$suff" ;

    if ( $save && ! rename("$db.$suff","$db.$suff.save") )
      {  return(0,"cannot rename $db.$suff") ; }

    if ( ! open(DATA,">$db.$suff") )
      { if ( $save && ! rename("$db.$suff.save","$db.$suff") )
          { return(0,"error but old $suff in $db.$suff.save") ; }
        return(0,"cannot open $db.$suff for writing") ;
      }

    for ( @info )
      { if ( ! print DATA &intext($_), "\n" )
          { close(DATA) ;
            if ( $save && ! rename("$db.$suff.save","$db.$suff") )
              { return(0,"error but old $suff in $db.$suff.save") ; }
            return(0,"cannot write everything to $db.$suff") ;
          }
      }
    close(DATA) ;

    &addlog("saved $db.$suff") ;
    return(1, "$db.$suff " . ($save ? "saved" : "created") ) ;
  }

sub emptyRecord
  { local($size) = @_ ;
    local(@res) ;
    for (local($i) ; $i<=$size ; $i++ )
      { push(@res,'') ; }
    return @res ;
  }

sub addFieldNP
  { local(*descr,*name,$nam,*cpat,$pat) = @_ ;
    push(@descr,"name$;" . ( $#name + 2 ) . "$;$nam") ;
    push(@descr,"cpat$;" . ( $#cpat + 2 ) . "$;$pat") ;
    push(@name,$nam) ;
    push(@cpat,$pat) ;
  }

sub mkDescr
  { local(*descr,*name,*cpat) = @_ ;
    local($i) = 1 ;
    @descr =  () ;
    for ( @name )
      { push(@descr,"name$;$i$;" . $name[$i-1]) ;
        push(@descr,"cpat$;$i$;" . $cpat[$i-1]) ;
	$i++ ;
      }
  }

sub splitDescr
  { local(*descr,*name,*cpat) = @_ ;
    local(@tmp,$d) ;
    @name = () ;
    @cpat = () ;
    for $d ( @descr )
      { @tmp = split(/$;/,$d,3) ;
	if ( $tmp[0] eq 'name' )
          { $name[$tmp[1]-1] = $tmp[2] ; }
	elsif ( $tmp[0] eq 'cpat' )
	  { $cpat[$tmp[1]-1] = $tmp[2] ; }
      }
   $#cpat = $#name ;
  }

sub splitNewDescr
  { local(*descr,*name,*cpat) = @_ ;
    local(@errors,@tmp,$d) ;
    @name = () ;
    @cpat = () ;
    for $d ( @descr )
      { @tmp = split(/$;/,$d) ;
	if ( $#tmp < 1 )
	  { push(@errors,"wrong number of fields in " . &intext($d) ) ; }
	elsif ( $tmp[1] !~ /^[1-9][0-9]*$/ )
	  { push(@errors,"no field number in " . &intext($d) ) ; }
	elsif ( $tmp[0] eq 'name' )
          { $name[$tmp[1]-1] = $tmp[2] ; }
	elsif ( $tmp[0] eq 'cpat' )
	  { $cpat[$tmp[1]-1] = $tmp[2] ; }
      }
    return @errors ;
  }

sub checkDescrName
  { local(*name) = @_ ;
    local(@res,$key,%names,$_) ;
    for ( @name )
      { $names{$_}++ ; }
    for (keys %names)
      { if ( $names{$_} != 1 )
          { push(@res,"name $_ used $names{$_} times") ; }
	if ( $_ eq '' )
          { push(@res,"empty name used $names{$_} time(s)") ; }
	if ( $_ !~ /$namePat/ )
          { push(@res,"$names{$_} not alpha-numeric") ; }
      }
    return @res  ;
  }

sub checkDescr
  { local(*name,*pat) = @_ ;
    local(@res) = &checkDescrName(*name) ;
    local($i,$pat) ;
    for $pat ( @pat )
      { if ( ! &testPat($pat) )
          { push(@res,"$@ for $name[$i]") ; }
	$i++ ;
      }
    push(@res,'more patterns than names') if $#pat > $#name ;
    while ( $#pat < $#name ) { push(@pat,'') ; }
    return @res ;
  }

sub cleanData
  { local(*data,$size) = @_ ;
    local($d,@values) ;
    for $d (@data)
      { @values = split(/$;/,$d) ;
        push(@values,'') while $#values < $size ;
        pop(@values)     while $#values > $size ;
        $d = join($;,@values) ;
      }
  }

sub openDb
  { local($str,*descr,*data,*name,*pat) = @_ ;

    local(@errors,@tmpDescr,@tmpName,@tmpPat,@tmpData) ;

    return(4,'no name ; no change') if $str eq '' ;

    if ( ! &getInfo(*tmpDescr,$str,'des') )
      { return 3, "cannot open $str.des ; no change" ; }

    @errors = &splitNewDescr(*tmpDescr,*tmpName,*tmpPat) ;
    if ( $#errors >= 0 )
      { return(2,"syn errors in $str.des",@errors,'no change') ; }
    @errors = &checkDescr(*tmpName,*tmpPat) ;
    if ( $#errors >= 0 )
      { return(2,"sem errors in $str.des",@errors,'no change') ; }

    if ( ! &getInfo(*tmpData,$str,'dat') )
      { return(1,"cannot open $str.dat ; no change") ; }

    @descr = @tmpDescr ;
    @name  = @tmpName ;
    @pat   = @tmpPat ;
    @data  = @tmpData ;

    &cleanData(*data,$#name) ;
    return(0,"opened $str") ;
}

sub openCurrDb
  { local($str) = @_ ;
    local($res,@errors) ;

    ($res,@errors) = &openDb($str,*descr,*data,*name,*pat) ;
    return(0,@errors) if $res > 1 ;

    $db = $str ;
    return(1,@errors) ;
}

sub testPat
  { local($pat) = shift ;
    eval("/\$pat/;") ;
    if ( $@ )
      { $@ =~ s/regexp at.*/pattern/ ;
        $@ =~ s/(.*) in file.*/$1/ ;
        chop $@ while $@ =~ /\n$/ ;
        return(0);
      }
    return(1);
  }

sub testExpr
  { local($expr) = shift ;
    local(@errors) ;
    eval("package aap ; do { $expr ; }\n") ;
    if ( $@ )
      { $@ = (split(/\n/,$@))[0] ;
        return(0);
      }
    return(1);
  }

sub mkInvert
  { local(*row) = @_ ;
    local($i,$_) ;
    %row = undef ;
    $i = '0' ;
    for (@row)
      { $row{$_} = $i++ ; }
  }

sub doTest
  { local(*record,*pat) = @_ ;
    local($_,@res,$i) ;
    for ( @record )
      { if ( $pat[$i] && ! /$pat[$i]/ )
	  { push(@res,$i) ; } ;
	$i++ ;
      }
    return @res ;
  }

sub byNum { $a - $b ; }

sub multiSort
  { local(*data,*sortKey) = @_ ;
    local($i,%msort,$_) = 0 ;
    for ( @data ) { $msort{join($;,(split(/$;/))[@sortKey])} .= $i++ . ',' ; }
    @data = @data[split(/,/,join('',@msort{sort keys %msort}))] ;
  }

sub doSort
  { local(*data,*sortKey) = @_ ;
    return 1, 'db already sorted' if $#data <= 0 ;
    if ( $#sortKey < 0 )
      { @data = sort @data ; }
    else
      { &multiSort(*data,*sortKey) ; }
    return 1, 'new jinx db' ;
  }

sub doProjectData
  { local(*data1,*projKey) = @_ ;
    local($_) ;

    for ( @data1 )
      { $_ = join($;,(split(/$;/))[@projKey]) ; }
  }

sub doProject
  { local(*descr1,*name1,*pat1,*data1,*projKey) = @_ ;
    local($_,@tmpName,@tmpPat) ;

    return(0,'empty selector ; no change') if $#projKey < 0 ;

    @tmpName = @name1 ;
    @tmpPat  = @pat1 ;
    @descr1 = () ;
    @name1 = () ;
    @pat1 = () ;
    for ( @projKey )
      { &addFieldNP(*descr1,*name1,$tmpName[$_],*pat1,$tmpPat[$_]) ; }

    &doProjectData(*data1,*projKey) ;
    return(1,'new jinx db') ;
  }

sub doJoin
  { local(*descr1,*data1,*descr2,*data2,$ccNo,$ccMulti) = @_ ;
    local(@name1,@name2) ;
    local(%name1,%name2) ;
    local($name1,$name2) ;
    local(@pat1,@pat2) ;
    local(@joinKey1,@joinKey2,@dataKey2,%dataKey2) ;
    local(@values,$value) ;
    local(@val,$val) ;
    local(@vals,$vals,@nvals) ;
    local(%key,$key) ;
    local(@resDescr,@resName,@resPat,@resData) ;
    local($curr,$i,$_,@errors) ;

    &splitDescr(*descr1,*name1,*pat1) ;
    &mkInvert(*name1) ;
    &splitDescr(*descr2,*name2,*pat2) ;
    &mkInvert(*name2) ;

    for $name1 (@name1)
      { if ( defined $name2{$name1} )
          { push(@joinKey1,$name1{$name1}) ;
            push(@joinKey2,$name2{$name1}) ;
          }
      }
    for $name2 (@name2)
      { push(@dataKey2,$name2{$name2}) if ! defined $name1{$name2} ; }
    
    return(0,"no fields in common ; no change") if $#joinKey1 < 0 ;
    return(0,"no data to add ; no change")      if $#dataKey2 < 0 ;

    $emptyData2 = join($;,&emptyRecord($#dataKey2)) ;

    $i = 0 ;
    for $value (@data2)
      { @value = split(/$;/,$value) ;
        $key = join($;,@value[@joinKey2]) ;
        $val = join($;,@value[@dataKey2]) ;
	push(@val,$val) ;
        if ( defined $key{$key} )
          { $key{$key} .= ( ',' . $i++ ) ; }
        else
          { $key{$key} = $i++ ; }
      }

    @resDescr = @descr1 ;
    @resName = @name1 ;
    @resPat  = @pat1 ;
    for ( @dataKey2 )
      { &addFieldNP(*resDescr,*resName,$name2[$_],*resPat,$pat2[$_]) ; }

    $curr = 0 ;
    for $value (@data1)
      { @value = split(/$;/,$value) ;
        $key = join($;,@value[@joinKey1]) ;
        if ( defined $key{$key} )
          { if ( $key{$key} !~ /,/ )
	      { push(@resData, $value . $; . $val[$key{$key}]) ; }
	    else
	      { @vals = split(/,/,$key{$key}) ;
		if ( $ccMulti !~ /[AD]/ )
		  { while (1)
		      { &showData(*data1) ;
		        &showStatusBeep($#vals+1 . ' things to join with') ;
		        $ccMulti = &showChoice(*multiKeyMenu,'q') ;
                        if ( $ccMulti eq 's' ) 
	                  { ($ccMulti,@nvals) =
			      &selectFrom('join info',*name2,*data2,@vals) ;
			    redo if $ccMulti eq 'q' ;
		            @vals = @nvals ;
		          }
			last ;
		      }
		  }
		elsif ( ! $inJinx )
                  { print STDERR $#vals+1, " records join with\n" ;
		    print STDERR &intext($value), "\n" ;
		    for $val ( @vals )
		      { print STDERR "$val ", &intext($data2[$val]), "\n" ; }
		    print STDERR "added all ", $#vals+1, "\n--------------\n" ;
		  }
		if ( $ccMulti eq 'q' )
                  { return(0,'no change') ; }
                elsif ( $ccMulti =~ /[Aa]/ ) 
	          { for $val ( @vals )
		      { push(@resData, $value . $; . $val[$val]) ; }
		  }
	      }
	  }
        else
          { if ( $ccNo !~ /[AD]/ )
              { &showStatusBeep("no record to join with") ;
                &showData(*data1) ;
                $ccNo = &showChoice(*noKeyMenu,'q') ;
                return(0,'no change') if $ccNo eq 'q' ;
              }
	    elsif ( ! $inJinx )
              { print STDERR "no record joined with\n" ;
		print STDERR &intext($value), "\n" ;
		print STDERR "added empty fields\n--------------\n" ;
	      }
            if ( $ccNo =~ /[aA]/ )
              { push(@resData, $value . $; . $emptyData2) ; }
          }
        $curr++ ;
      }

    @descr1 = @resDescr ;
    @data1  = @resData ;

    return(1,'new jinx db') ;
  }

sub doSelect
  { local(*data,*re,*sub) = @_ ;
    local(@values,@poi,$poi,$i,$re) ;
    for $re ( @re )
      { push(@poi,$i) if $re ne '' ;
        $i++ ;
      }
    return grep( do { @values = split(/$;/,$data[$_],$#re+1) ;
		      $i = 0 ;
		      grep(/$re[$poi[$i++]]/,@values[@poi]) ;
		    }
	       , @sub
	       ) ;
  }

sub doAddMark
  { local(*data,*re,*marked,*sub) = @_ ;
    local($res,$res1) ;
    return(0,'empty selector ; no change') if grep(/./,@re) == 0 ;
    for $res ( &doSelect(*data,*re,*sub) )
      { $res1++ ; $marked{$res} = 1 ; }
    return 1, $res1 ;
  }

sub doDelMark
  { local(*data,*re,*marked,*sub) = @_ ;
    local($res,$res1) ;
    return(0,'empty selector ; no change') if grep(/./,@re) == 0 ;
    for $res ( &doSelect(*data,*re,*sub) )
      { $res1++ ; delete $marked{$res} ; }
    return 1, $res1 ;
  }

sub doGuessDescr
  { local($num,*newDescr) = @_ ;
    local($i) ;
    @newDescr = () ;
    for ( $i = 1 ; $i <= $num ; $i++ )
      { push(@newDescr,"name$;$i$;field$i") ;
        push(@newDescr,"cpat$;$i$;.*") ;
      }
  }

sub doGuessData
  { local($filename,$sep,*newData) = @_ ;
    local($_,@guess,@rec,$rec,$res) ;

    return 0, $@ if ! &testPat($sep) ;
    @newData = () ;
    open(GUESS,$filename) || return 0, "can't open $filename ; no change" ;
    while  ( $_ = <GUESS> )
      { chop ; 
	@rec = split(/$sep/,$_) ;
	$res = &max($res,$#rec) ;
	$rec = join($;,@rec) ;
        $rec =~ s/\t/ /g ;
	push(@newData,$rec) ;
      }
    close(GUESS) ;
    &cleanData(*newData,$res) ;
    return $res+1, 'new db' ;
  }

sub doCompute
  { local(*name,*record,*data,*ddata) = @_ ;
    local($i,$tmp,$expr,$doit,$namelist,$elem,@rec,@hasExpr) ;
    
    $namelist = '($' . join(',$',@name) . ')' ;

    $doit = '' ;
    $loop = '' ;
    $loop .= "  { \@main'rec = split(/\$;/,\$main'elem) ;\n" ;
    $loop .= "    $namelist = \@main'rec ;\n" ;
    $i = 0 ;
    for $expr ( @record )
      { if ( $expr )
	  { $loop .= "    \$main'tmp = do { $expr ; } ;\n" ;
	    $loop .= "    \$main'tmp =~ s/\$;/\\\$;/g ;\n" ;
	    $loop .= "    \$main'rec[$i] = \$main'tmp ;\n" ;
	    push(@hasExpr,$i) ;
	  }
	$i++ ;
      }
    $loop .= "    \$main'elem = join(\$;,\@main'rec) ;\n" ;
    $loop .= "    \$__RECNUM__++ ;\n" ;
    $loop .= "  }\n" ;
    $doit .= "package aap ;\n" ;
    $doit .= "# reset('a-z') ;\n" ;
    $doit .= "\$__RECNUM__ = 1 ;\n" ;
    $doit .= "for \$main'elem ( \@main'data )\n" ;
    $doit .= $loop ;
    $doit .= "for \$main'elem ( \@main'ddata )\n" ;
    $doit .= $loop ;
    &addlog($doit) ;
    eval $doit ;
    &addlog($@) ;
    if ( $@ )
      { $@ = (split(/\n/,$@))[0] ;
        return $@ ;
      }
    return 'new values for ' . join(',',@name[@hasExpr]) ;
  }

$namePat = '^\w+$' ;
$inJinx = 0 ;

1 ;