The Perlography script code

#!perl
##  Version 2.0.1    
##  Laurence R. Taylor  taylor.2@nd.edu www.nd.edu/~taylor
##  Copyright (C) 2000
##  Freely distributed under the standard GNU Copyleft agreement


my($pst_folder,$dot_folder,$dotbibfile,@dotbibs,@files,$preambleString);

my(@bibentry, %bib_entry,$citelist,$tmpS,$citeall,%stringHash);

####  Make sure $pst_folder is set correctly.
####  This code works in MacOS if the .pst files are in a folder
####  in the same folder as the Perlography Droplet and if that
####  folder is called "pst files". This will not work in UNIX.
####  Just set $pst_folder to a complete path to the desired directory.

$pst_folder=`pwd`;chomp($pst_folder);$pst_folder.=':pst files:';

$citeall=0;
$preambleString="";
foreach $xx (@ARGV) {
  $uu=rindex($xx,':');
  if($uu<0) {$dot_folder=`pwd`;chomp($dot_folder);$dot_folder.=':';}
  else {$dot_folder=substr($xx,0,$uu+1);}
  $dotbibfile="";
  $dotpstfile="";
  $citelist="";
  $tmpS="";
  if($xx=~m/.aux$/) {
    if( open(IN,$xx) ) {
      @lines=;
      close(IN);
      for($ii=0;$ii<=$#lines;$ii++) {
        if($lines[$ii]=~m/\\bibdata/) {
          $dotbibfile=$lines[$ii];chomp($dotbibfile);
          $dotbibfile=~s/^.*\{//;
          $dotbibfile=~s/\}.*$//;
          if($dotbibfile eq "*" ) {
            if( opendir(DIR,':') ){
              @files=readdir(DIR);
              closedir(DIR);chomp(@files);
              foreach $tmpS (@files) {
                if($tmpS=~m/\.bib$/) {push(@dotbibs,$tmpS);}
                }
              }
            }
          else{
            if($dotbibfile!~m/.bib/){$dotbibfile.='.bib';}
            if( -f $dotbibfile) {push( @dotbibs,$dot_folder.$dotbibfile);}
            }
          }
        elsif($lines[$ii]=~m/\\bibstyle/) {
          $dotpstfile=$lines[$ii];chomp($dotpstfile);
          $dotpstfile=~s/^.*\{//;
          $dotpstfile=~s/\}.*$//;
          $dotpstfile=~s/\.bst$/\.pst/; # if it's a .bst make it a .pst
          if($dotpstfile!~m/.pst/){$dotpstfile.='.pst';}
          $dotpstfile=$pst_folder.$dotpstfile;
          }
        elsif($lines[$ii]=~m/\\citation/) {
          $tmpS=$lines[$ii];chomp($tmpS);
          $tmpS=~s/^.*\{//;$tmpS=~s/\}.*$//;
          if( $citeall==0 && $tmpS ne "*"){$citelist.='Ą'.$tmpS.'Ą';}
          elsif( $tmpS eq "*"){$citeall=1;$citelist="";}
          }
        }
      }
    }
  elsif($xx=~m/.bib$/) {
   $dotbibfile=$xx;
    if(open(IN,$xx) ) {
      push(@dotbibs,$dotbibfile);
      $dotpstfile=;
      close(IN);
      chomp($dotpstfile);
      $dotpstfile=~s/\t//g;
      $dotpstfile=~s/ *//g;
      if($dotpstfile!~m/.pst/){$dotpstfile.='.pst';}
      $dotpstfile=$pst_folder.$dotpstfile;
      }
    }
  if( -f $dotpstfile ) {$AOK=0;}
  else{ print "$dotpstfile not an acceptable pst file.\n";$AOK=1;}
  if($AOK==0) {
    foreach $dotbibfile (@dotbibs) {
      undef(@bibentry);undef(%bib_entry);
      if( -f $dotbibfile ) {&do_one_file($dotbibfile,$dotpstfile,$citelist);}
      else{ print "$dotbibfile not an acceptable data file.\n";}
      $dotpstfile="";
      }
    }
  }
exit(0);


sub do_one_file {
my($file,$dotpstfile,$tag,$citelist,@lines,$data,$entryNumber,$lastentry,$outfile);
$entryNumber=1;
$file=shift(@_);
$dotpstfile=shift(@_);
$citelist=shift(@_);
$data="";
undef(@lines);undef(@bibentry);undef(%bib_entry);
##  Read in routines to do the formating ONCE
{{ package Perlography;
if( -f $dotpstfile) {
  open(IN,$dotpstfile) or die($!);
  @lines=;
  close(IN);
  $xx=join("\n",@lines);
  if(!eval($xx) ) {print $@;}
  }
}}
###
if( open(IN,$file) ) {
  @lines=;
  close(IN);
  chomp(@lines);
  $data=join(' ',@lines);
  $data=~s/[\000-\024]/ /g; # kill low value ASCII's
  $data=~s/\t/ /g;$data=~s/ +/ /g; # kill tabs and double spaces
## escaped braces and double quotes can cause problems so get rid of them for now.
  $data=~s/\\\\/\004/g; # first kill escaped \'s so we really see escaped quotes and braces.
  $data=~s/\\\{/\001/g;
  $data=~s/\\\}/\002/g;
  $data=~s/\\\"/\003/g;
  $xx=index($data,'@');
  while($xx>=0) { # collect the entries 
    $data=substr($data,$xx);
    $yy=close_brace($data);
    $entry=substr($data,0,$yy);
    $data=substr($data,$yy+1);
    &collect_entry($entry,$citelist);
    $xx=index($data,'@',);
    }
  }
undef($entry);
##
## loop through the format subroutines
for($ii=0;$ii<=$#bibentry;$ii++) {
  foreach $xx (keys(%{$bibentry[$ii]})) {
    $subroutine="Perlography::format_".$xx;
    if( defined(&{$subroutine}) ) { &{$subroutine}(\$bibentry[$ii]);}
    }
  }
## compute sort hash
&hash_sort(\@bibentry);
$entryNumber=0;
foreach $xx (sort(keys(%bib_entry))) {
  ${$bib_entry{$xx}}{"read_in"}=$entryNumber++." ".$#bibentry;
  }
## sort the records and output the data.
$outfile=$file;
if( defined(&Perlography::BBL) ){$outfile=&Perlography::BBL($outfile);} else {$outfile=~s/\.bib//;$outfile.='.bbl';}
if( open(OUT,">$outfile") ) {
  if( defined(&Perlography::Prolog) ) {&Perlography::Prolog($file);}
  if( $preambleString ne "" ) {print OUT $preambleString;}
  $lastentry="";
  foreach $xx (sort(keys(%bib_entry))) {
    if( defined(&Perlography::EachEntry) ) {&Perlography::EachEntry($bib_entry{$xx},$bib_entry{$lastentry});}
    $subroutine="Perlography::output_".${$bib_entry{$xx}}{"KOE"};
    if( defined(&{$subroutine}) ) {&{$subroutine}($bib_entry{$xx});}
    $lastentry=$xx;
    }
  if( defined(&Perlography::Epilog) ) {&Perlography::Epilog($file);}
  close(OUT);
   if( defined(&MacPerl::SetFileInfo) ){&MacPerl::SetFileInfo('R*ch','TEXT',$outfile);}
  }
}

sub do_String{
my($entry,$type,$value);
$entry=shift(@_);
if($entry=~m/=/){$type=$`;$value=$';
  $type=~s/^ +//;$type=~s/ +$//;
  $type=uc($type);
  $value=~s/^ +//;$value=~s/ +$//;
  $value=~s/^\{//;$value=~s/^\"//;
  $value=~s/\}$//;$value=~s/\"$//;
  if($type=~m/(\{|\()/) {$type=$';}
  $type=~s/^ +//;$type=~s/ +$//;
  $stringHash{$type}=$value;
  }
}

sub do_Preamble{
my($entry,$zz,$rr,$start,$fld_lngth,$field_type,$comma);
$entry=shift(@_);
if($entry=~m/(\(|\{)/) {
  $entry=$';$entry=~s/^ +//;$entry=~s/ +$//;
  $zz="";$rr=0;
  while($rr>=0) {
    ($start,$fld_lngth,$field_type,$comma)=&next_string($entry,$rr);
    if( $field_type==1 || $field_type==2 ) {
      $zz.=substr($entry,$start,$fld_lngth);
      }
    else {
      $zz.=$stringHash{uc(substr($entry,$start,$fld_lngth))};
      }
    if( substr($entry,$comma,1) eq "#") {$rr=$comma+1;}
    elsif( substr($entry,$comma,1) eq "," || $comma>length($entry) ) {$rr=-1;}
    else{print"Entry ",$this_one{"bib_entry"}," has formatting problems.\n",$entry,"\n";}
    }
  }
$preambleString.=$zz;
}

sub next_string{
my($inputStr,$start,$rr,$field_bdy,$field_type,$bcount,$comma_char);
($inputStr,$start)=@_;
while( (substr($inputStr,$start,1) eq " ") && ($rr<=length($inputStr)) ) {$start++;}
$rr=$start;
if( substr($inputStr,$rr,1) eq "\"" ) {# look for closing "
  $rr++;$start++;
  while( (substr($inputStr,$rr,1)!~m/\"/) && ($rr<=length($inputStr)) ) {$rr++;}
  $field_bdy=$rr; #points to closing quote
  $field_type=1;
  }
elsif( substr($inputStr,$rr,1) eq "\{" ) {# look for closing }
  $rr++;$start++;
  $bcount=1;
  while($bcount>0 && $rr<=length($inputStr) ){
    if(substr($inputStr,$rr,1) eq "{") {$bcount++;}
    elsif(substr($inputStr,$rr,1) eq "}") {$bcount--;}
    $rr++;
    }
  $field_bdy=$rr; # points to closing brace
  $field_type=1;
  }
elsif( substr($inputStr,$rr,1)=~m/[0-9]/ ) {# should be number string to next whitespace or comma
  while( (substr($inputStr,$rr,1)=~m/[0-9]/) && ($rr<=length($inputStr)) ) {$rr++;}
  $field_bdy=$rr; #points to last digit+1
  $field_type=2;
  }
elsif( substr($inputStr,$rr,1)=~m/[A-Za-z]/ ) {# should be @string to next whitespace or comma
  while( (substr($inputStr,$rr,1)!~m/( |,)/) && ($rr<=length($inputStr)) ) {$rr++;}
  $field_bdy=$rr; #points to last character in our string+1
  $field_type=3;
  }
if($field_type==1) {$comma_char=$field_bdy+1;}
elsif($field_type==2) {$comma_char=$field_bdy;}
elsif($field_type==3) {$comma_char=$field_bdy;}
while( substr($inputStr,$comma_char,1) eq " ") {$comma_char++;}
return($start,$field_bdy-$start,$field_type,$comma_char);
}

sub collect_entry{
my($entry,%this_one,$xx,$yy,$zz,$ii,@lines,$field_bdy,$bcount,$rr,$citelist,$comma_char);
my($start,$fld_lngth,$field_type,$comma);
undef(%this_one);
$entry=shift(@_);
$citelist=shift(@_);
if($entry eq "") {return;}
if( $entry=~m/\} *$/) {$entry=$`;}
if($entry eq "") {return;}
$entry=~m/(\{| |\()/;
$this_one{"KOE"}=substr(uc($`),1); # KOE = kind of entry - ARTICLE, BOOK whatever - forced upper case
## if it's an @string process it here and return
if( $this_one{"KOE"} eq "STRING" ) {
  do_String($entry);
  return;
  }
if( $this_one{"KOE"} eq "PREAMBLE" ) {
  do_Preamble($entry);
  return;
  }
$entry=~m/(\{|\()/;$entry=$';$entry=~s/^ +//g;
$entry=~m/,/;
$this_one{"bib_entry"}=$`;
$zz="Perlography::output_".$this_one{"KOE"};
if( !defined(&{$zz}) ) {
  $rr=rindex($dotpstfile,':');
  print "Have an entry type of \"",$this_one{"KOE"},"\" which \"",substr($dotpstfile,$rr+1),"\" is not equipped to handle.\nSkipping ",$this_one{"bib_entry"},".\n\n";
  return;
  }
## $entry is now stuff after first comma.
$entry=$';$entry=~s/^ +//;
while( $entry ne "" ) {
## find the closing comma. There are no escaped braces or escaped quotes
## look for first equal sign
  $rr=index($entry,"=")+1;
  if($rr>0) {
    if( $entry=~m/=/) {
      $type=$`;$type=~s/^ +//g;
      $type=~s/ +$//g;$type=lc($type);
      }
    $zz="";
    while($rr>0) {
      ($start,$fld_lngth,$field_type,$comma)=&next_string($entry,$rr);
      if( $field_type==1 || $field_type==2 ) {
        $zz.=substr($entry,$start,$fld_lngth);
        }
      else {
        $zz.=$stringHash{uc(substr($entry,$start,$fld_lngth))};
        }
      if( substr($entry,$comma,1) eq "#") {$rr=$comma+1;}
      elsif( substr($entry,$comma,1) eq ",") {$rr=-1;}
      else{print"Entry ",$this_one{"bib_entry"}," has formatting problems.\n",$entry,"\n";}
      }
    ## restore escaped braces and double quotes.
    $zz=~s/\001/\\\{/g;
    $zz=~s/\002/\\\}/g;
    $zz=~s/\003/\\\"/g;
    $zz=~s/\004/\\\\/g;
    $this_one{$type}=$zz;
    $entry=substr($entry,$comma+1);
    }
  else{
    $entry="";
    }
  }
$zz='Ą'.$this_one{bib_entry}.'Ą';
if($citelist eq "" || $citelist=~m/$zz/) {push(@bibentry,\%this_one);}
}


sub close_brace{
my($str,$xx,$ll,$bcount,$fb,$bb);
$str=shift(@_);
if($str!~m/(\{|\()/) {return -1;}
$fb=$1;if($fb eq "{") {$bb="}";} else {$bb=")";}
$xx=index($str,$fb)+1;$bcount=1;
$ll=length($str);
while($bcount>0 && $xx<=$ll ) {
  if( substr($str,$xx,1)  eq $fb  ) {$bcount++;}
  elsif( substr($str,$xx,1)  eq $bb ) {$bcount--;}
  $xx++;
  }
if($xx>$ll) {print"Braces not balanced - no closing brace starting with,\n",$str,"\n";exit;}
return ($xx-1);
}

sub hash_sort {
my($bibentry,$ii,$xx,$key,$kk);
undef($bibentry);undef(%bib_entry);
$bibentry=shift(@_);
if(defined(&Perlography::compute_sort_hash) ) {
  for($ii=0;$ii<=$#$bibentry;$ii++) {
    $key=&Perlography::compute_sort_hash(\${$bibentry}[$ii],$ii);
    if( defined($bib_entry{$key}) ){
      print"\n********************************\n";
      print"Hash key \"$key\" already defined  - clobber the following:\n";
      foreach $xx (keys(%{$$bibentry[$ii]})) { print $xx,"--",${$$bibentry[$ii]}{$xx},"\n";}
      print"\nEnd of clobber for hash key \"$key\".";
      print"\n********************************\n";
      }
    $bib_entry{$key}=$$bibentry[$ii];
    }
  }
else {
  $key=10000;
  for($ii=0;$ii<=$#$bibentry;$ii++) { # no hash - use input order
    $bib_entry{$key}=$$bibentry[$ii];
    $key++;
    }
  }
}

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

sub crack_name{
# count commas 
# 0 = first von last
# 1 = first von last, IX or von last, first
# 2 = von last, Jr., first
my($name,$last,$first,$von,$ii,@words,$fc,$jr,$sc,$jj,$bcount,$jjr);
$name=shift(@_);
$name=~s/^ +//g;$name=~s/ +$//g;
$jj=($name=~s/,/,/g);
$jr="";
if($jj==2) {
  @words=split(',',$name);
  $name=$words[2].' '.$words[0].' '.$words[1];
  $name=~s/ +/ /g;$name=~s/^ +//;$name=~s/ +$//;
  }
elsif($jj==1) {
  @words=split(',',$name);
  $jjr=lc($words[1]);$jjr=~s/(i|v|x|\.| )//g;
  if( $jjr eq "jr" || $jjr eq "" ) {
    $jr=$words[1];
    $name=$words[0];
    $name=~s/ +/ /g;$name=~s/^ +//;$name=~s/ +$//;
    }
  else {
    $name=$words[1].' '.$words[0];
   }
  }
## string now in standard order first von last or first von last, XII
$first="";$last="";$von="";
if($name=~m/,/) {$jr=$`;$name=$';$name=~s/^ +//;$jr=~s/ +$//;}
@words=split(' ',$name);
$first=$words[0];
for($jj=1;$jj<$#words;$jj++) {
  if($words[$jj]=~m/[A-Z]/) {$first.=' '.$words[$jj];} else {last;}
  }
if($jj<$#words) {
  $von=$words[$jj];
  for($jj++;$jj<$#words;$jj++) {
    if($words[$jj]=~m/[a-z]/) {$von.=' '.$words[$jj];} else {last;}
    }
  }
$last=$words[$jj];
for($jj++;$jj<=$#words;$jj++) {
  $last.=' '.$words[$jj];
  }
return($first."\t".$von."\t".$last."\t".$jr);
}

sub string_name_field{
my(@namestrings,$moose,$ii,$bcount,$initialize);
undef(@namestrings);
$xx=shift(@_);$initialize=shift(@_);
###   if the author string has braces in it, hide all spaces and commas occurring inside a brace pair
###   outer brace pair is removed so chunks of the name begin with space-letter (or letter for first)
if($$xx=~m/{/) {
  $bcount=0;
  for($ii=0;$ii<=length($$xx);$ii++) {
    if( substr($$xx,$ii,1)  eq "{" ){
      $bcount++;
      if($bcount=1) {substr($$xx,$ii,1)='';}
      }
    elsif( substr($$xx,$ii,1)  eq "}" ){
      $bcount--;
      if($bcount==0) {substr($$xx,$ii,1)='';}
      }
        ###    hide spaces and commas inside brace pairs
    elsif( (substr($$xx,$ii,1)  eq " ") && $bcount>0 ){ substr($$xx,$ii,1)="\010";}
    elsif( (substr($$xx,$ii,1)  eq ",") && $bcount>0 ){ substr($$xx,$ii,1)="\007";}
    }
  }
@namestrings=split(' and ',$$xx);
$moose="";
for($ii=0;$ii<$#namestrings;$ii++) {
  $moose.=&crack_name($namestrings[$ii])."\t";
  }
$moose.=&crack_name($namestrings[$ii]);
undef(@namestrings);
$moose=~s/\010/ /g;$moose=~s/\007/,/g; ## restore spaces and commas inside brace pairs
@namestrings=split("\t",$moose);
if($initialize eq "Y") {
  for($ii=0;$ii<=$#namestrings;$ii+=4) {
    $namestrings[$ii]=&names_to_initials($namestrings[$ii]);
    }
  }
$$xx=\@namestrings;
}

sub reverse_input_hash{
my($ii);
$ii=shift(@_);
$ii=shift(@_);
return(999999-$ii);
}

sub names_to_initials{
my($first);
  $first=shift(@_);
  $first=~s/[a-z]//g;
  $first.=' ';
  $first=~s/ +/ /g;
  $first=~s/ /\. /g;
  $first=~s/-/\.-/g;
  $first=~s/\.\./\./g;
  $first=~s/ $//;
  $first=~s/\. /\.~/g;
  return($first);
}

sub standard_hash{
my($entry_address,$ii,@names,$key,%entry_hash);
($entry_address,$ii)=@_;
%entry_hash=%{$$entry_address};
@names=@{$entry_hash{"author"}};
$key="";
for($ii=0;$ii<=$#names;$ii+=4) {
  $key.=$names[$ii+2].$names[$ii+1].$names[$ii+3].$names[$ii];
  }
$key.=$entry_hash{"year"}.$entry_hash{"bib_entry"};
return($key);
}