
# 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.1 kit.

# addlog()
# is redefined in jinx to do something useful
sub addlog { ; }

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

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

# maxStrlen(*row,$from,$to)
# returns length of longest string in @row[$from..$to]
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) ;
  }

# tailstr($str,$from)
# returns substr($str,$from)
# still here for compatibility with pre pl41 perls
sub tailstr
  { local($str,$from) = @_ ;
    local($l) = length($str) ;
    if ( $from > $l - 1)
      { return('') ; }
    else
      { return(substr($str,$from,$l-$from)) ; }
  }

# extint($str)
# translates $str from EXTernal to INTernal format
# substitutes $; for ":" except for the escaped ":" 
# removes escapes for ":" and "!" in user data
sub extint
  { local($_) = @_ ;
    local($res,$pref) ;
    while ( /!(.)/ )
      { $pref = $` ;
	{ $pref =~ s/:/$;/g ; }
        $res .= ( $pref . $1 ) ;
	$_ = $' ;
      }
    s/:/$;/g ;
    $res .= $_ ;
    return $res ;
  }

# intext($str)
# translates $str from INTernal to EXTernal format
# escapes ":" and "!" in user data
# substitutes ":" for $;
sub intext
  { local($_) = @_ ;
    s/!/!!/g ;
    s/:/!:/g ;
    s/$;/:/g ;
    return $_ ;
  }

# getInfo(*info,$db,$suff)
# reads file "$db.$suff" into @info in internal format
# returns 1 iff sucsesful
sub getInfo
  { local(*info,$db,$suff) = @_ ;
    local($_) ;
    if ( open(INFO,"$db.$suff") )
      { &addlog("opened $db.$suff") ; }
    else
      { return(0) ; }
    @info = <INFO> ;
    chop @info ;
    for ( @info )
      { $_ = &extint($_) ; }
    close(INFO) ;
    &addlog("closed $db.$suff") ;
    return(1) ;
  }

# putInfo(*info,$db,$suff)
# moves file "$db.$suff" (if any) to "$db.$suff.save" 
# writes file "$db.$suff" with contents of @info in external format
# returns pair (1 iff successful, some-informative-message)
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") ) ;
  }

# emptyRecord($size)
# returns an array @res such that $#a == $size
# I guess I don't trust fooling around with $# too much
sub emptyRecord
  { local($size) = @_ ;
    local(@res) ;
    for (local($i) ; $i<=$size ; $i++ )
      { push(@res,'') ; }
    return @res ;
  }

# addFieldNP(*descr,*name,$nam,*cpat,$pat)
# adds a fieldname $name and pattern $pat to a descriptor @descr,
# and name- and pattern-list
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) ;
  }

# mkDescr(*descr,*name,*cpat)
# creates a descriptor @descriptor from a name- and pattern-list
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++ ;
      }
  }

# splitDescr(*descr,*name,*cpat)
# assumes a correct descriptor in @descriptor
# creates a name- and pattern-list from a @descriptor
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 ;
  }

# splitNewDescr(*descr,*name,*cpat)
# creates a name- and pattern-list from a @descriptor
# assumes nothing, returns a list of errors found
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 ;
  }

# checkDescrName(*name)
# checks if a name list @name is correct, that is
# all names are unique, none-empty, alphanumeric strings
# assumes nothing, returns a list of errors found
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  ;
  }

# checkDescr(*name)
# checks if a name- and pattern-list are correct, that is
# all names are unique, none-empty, alphanumeric strings
# all patterns are valid regexp's, no more patterns than names
# assumes nothing, returns a list of errors found
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 ;
  }

# cleanData()
# makes sure all strings in @data, if split on $;,
# produce an array with $# == $size
# clobbers excess data, sorry
sub cleanData
  { local(*data,$size) = @_ ;
    local($d,@values) ;
    for $d ( @data )
      { @values = split(/$;/,$d,$size+2) ;
        if ( $#values == $size )
          { next ; }
        elsif ( $#values < $size )
          { $values[$size] = '' ; }
        else # ( $#values > $size )
          { $#values = $size ; }
        $d = join($;,@values) ;
      }
  }

# openDb($str,*descr,*data,*name,*pat)
# opens database $str
# sets descriptor @descr and data @data
# sets namelist @name and patternlist @pat
# returns pair (status,some-informative-message)
# success : status == 0
# fail    : status == 1 implies descriptor found but no data-file
# fail    : status == 2 implies semantic errors in descriptor
# fail    : status == 3 implies syntactic errors in descriptor
# fail    : status == 4 implies $str eq ''
# doesn't clobber arguments if some error is found
# makes sure each record in @data contains the right number of fields
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") ;
}

# openCurrDb($str)
# jinx-private
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) ;
}

# testPat($pat)
# returns 1 iff $pat is a valid regexp
# modifies $@ a little if an error is found
sub testPat
  { local($pat) = shift ;
    eval("/\$pat/;") ;
    if ( $@ )
      { $@ =~ s/regexp at.*/pattern/ ;
        $@ =~ s/(.*) in file.*/$1/ ;
        chop $@ while $@ =~ /\n$/ ;
        return(0);
      }
    return(1);
  }

# testExpr($expr)
# returns 1 iff $expr is a valid perl expression
# modifies $@ a little if an error is found
sub testExpr
  { local($expr) = shift ;
    local(@errors) ;
    eval("package AAP ; do { $expr ; }\n") ;
    if ( $@ )
      { $@ = (split(/\n/,$@))[0] ;
        return(0);
      }
    return(1);
  }

# mkInvert(*row)
# uses @row (index->value) to create the inverse %row (value->index)
# such that: @row{@row} = 0..$#row
# all values in @row should be uniq (for instance a namelist)
sub mkInvert
  { local(*row) = @_ ;
    local($i,$_) ;
    %row = undef ;
    $i = '0' ;
    for ( @row )
      { $row{$_} = $i++ ; }
  }

# doTest(*record,*pat)
# tests for all $i in 0..$#record : $record[$i] matches $pat[$i]
# returns the list of indexes for which a mismatch was found
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 ; }

# multiSort(*data,*sortKey)
# each element of @data is a $;-separated list of fields
# @sortKey is a non-empty list of sortKeys
# sorts @data such that
# field sortKey[0] is used as primary key,
# field sortKey[1] is used as secundary key etc
# sorts keys as strings
sub multiSort
  { local(*data,*sortKey) = @_ ;
    local($i,%msort,$_) = 0 ;
    for ( @data ) { $msort{join($;,(split(/$;/))[@sortKey])} .= $i++ . ',' ; }
    @data = @data[split(/,/,join('',@msort{sort keys %msort}))] ;
  }

# doSort(*data,*sortKey)
# same as multiSort above except that @sortKey may be empty
# in which case a 'plain' sort is done
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' ;
  }

# doProjectData(*data1,*projKey)
# projects @data1 on fields @projKey
sub doProjectData
  { local(*data1,*projKey) = @_ ;
    local($_) ;

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

# doProject(*descr1,*name1,*pat1,*data1,*projKey)
# projects a database on fields @projKey
# undates @descr1, @name1, @pat1, @data1
# returns status, some-informative-message
# status == 0 iff @projKey is empty
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') ;
  }

# doJoin(*descr1,*data1,*descr2,*data2,$ccNo,$ccMulti)
# joins databases (@descr1,@data1) and (@descr2,@data2)
# $ccNo eq 'A'    : all records in db1 without a companion in db2
#                   are padded with empty data
# $ccNo eq 'D'    : all records in db1 without a companion in db2
#                   are deleted from the join
# $ccMulti eq 'A' : all records in db1 with more than 1 companion in db2
#                   are joined with all companions in db2
# $ccMulti eq 'D' : all records in db1 with more than 1 companion in db2
#                   are deleted from the join
# returns status, some-informative-message
# prints warnings on STDOUT (sorry)
# status == 0 iff db1 and db2 have all or no fields in common
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,'x') ;
                        if ( $ccMulti eq 's' ) 
	                  { ($ccMulti,@nvals) =
			      &selectFrom('join info',*name2,*data2,@vals) ;
			    redo if $ccMulti eq 'x' ;
		            @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 'x' )
                  { 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,'x') ;
                return(0,'no change') if $ccNo eq 'x' ;
              }
	    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') ;
  }

# jinx-private
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
	       ) ;
  }

# jinx-private
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 ;
  }

# jinx-private
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 ;
  }

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

# jinx-private
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' ;
  }

# jinx-private
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) ; &curFlush ;
    eval $doit ;
    &addlog('$@: ' . $@) ;
    if ( $@ )
      { $@ = (split(/\n/,$@))[0] ;
        return $@ ;
      }
    return 'new values for ' . join(',',@name[@hasExpr]) ;
  }

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

1 ;
