#!/usr/bin/perl
#
#!/usr/local/bin/perl
#
# mk_tcl_syntax - create a supplementary syntax file based on the
# user's proc's.  If the procs file(s) use the Synopsys
# define_proc_attributes method, options will be picked up as well.
# For tips on using the define_proc_attributes method, see
# "My Favorite DC/PT Shell Tricks" on www.zimmerdesignservices.com

$| = 1;  # force immediate output

# default format
$me = "me=e";
$he = "he=e-1";
$start = "\"\\\"\\\\<\${cmd}\\\\>\\\"\"" ;
$end = "\"]\\|[^\\\\]\$\"" ;
$contains="\"\\\@\${prefix}containscluster\"";
$group = "tcltkCommand";
$link = "Special";

# Parse the command line
#
&process_options;

foreach $procdir (@procdirs) {
  if (-d $procdir) {
    push(@procs,<$procdir/*>);
  } else {
    print STDERR "procdir $procdir was specified, but isn't a directory!\n";
    exit;
  }
}
print STDERR "procs is now @procs\n" if ($debug);

# Header stuff
print "
\" Define the default highlighting.
\" For version 5.7 and earlier: only when not done already
\" For version 5.8 and later: only when an item doesn't have highlighting yet
if exists(\"did_pt_syntax_inits\")
  command! -nargs=+ HiLink let i = 1
elseif version < 508
  let did_pt_syntax_inits = 1
  command! -nargs=+ HiLink hi link <args>
else
  command! -nargs=+ HiLink hi def link <args>
endif

";

print "
set iskeyword+=-,_,&  \" - _ and & need to be allowed in keywords
\n";

print "
\"Create a cluster for the std contains items to save space
syn cluster ${prefix}containscluster contains=tclLineContinue,tclNumber,tclVarRef,tclString,tcltkCommand,tclComment

\n";

# Now do the automatic generation
# First show (in comments) the files used
print "
\" The rest is generated by a perl script running over:
";
foreach $proc (@procs) { 
  print "\"    procedures file $proc\n";
}
print "\n\n";

# Processing of user procs files
foreach $proc (@procs) {
  $cmd = "";
  $items = "";
  open(PROC,"< $proc") || die "Error: Cannot open file $proc\n";
  while (<PROC>) {

    print STDERR "Main loop looking at line $_\n" if ($verbose);
    
    # When a proc command is found, save previous command (if it
    # exists), then set up for next.
    if (/^\s*proc\s+(\S+)/) {
      # save previous
      if ($cmd) {
        print STDERR "Found new cmd, saving cmd $cmd\n" if ($verbose);
        &save_command($cmd,$items,$start,$end,$contains,$group,$link,""); 
      }

      # init for next
      $cmd = $1;
      $items = "";
    }

    # Look for define_proc_attributes command and parse it
    if (/^\s*&?define_proc_attributes\s+(\S+)/) {
      # found - grab command and init brace counting vars
      $cmd = $1;
      $opens = 0;
      $closes = 0;
      print STDERR "Found define_proc_attributes for $cmd\n" if ($verbose);

      # pull until unescaped end of line and pairs of quotes
      while(/\\$/ || ((@quotes = /"/g)%2)) {
        $_ .= <PROC>;
      }
      print STDERR "define_proc_atts line is: $_\n" if ($verbose);

      if (/-define_args/) {
        # Now get rid of define_args and everything ahead of it
        s/.*-define_args//;
  
        # Keep pulling until we have at least one opening brace 
        # and equal numbers of opening and closing braces
        while(!(eof PROC) && ($opens eq 0) || ($opens ne $closes)) {
          $_ .= <PROC>;
          $opens = scalar(@temp = m/\{/g);
          $closes = scalar(@temp = m/\}/g);
        }
        # Clean out escapes and newlines
        s:\\?\n::g;
        # We now have the complete -define_args argument (I hope...)
  
        # Extract "-" options (must be preceeded by {\s* or they could be
        # part of a comment)
        $items = " " . join(" ",m/\{\s*(-\S+)/g);
      }

      # Go ahead and do the save.  This will cause duplicates (they were found
      # by proc code already), but duplicate cleanup code will handle that.
      &save_command($cmd,$items,$start,$end,$contains,$group,$link,""); 
    }

    # If an alias command appears, use the alias capability.
    # Doesn't handle multi-line...
    if (/[^;]\s*alias\s+(\S+)\s+(\S+)/) {
      # save previous
      if ($cmd) {
        &save_command($cmd,$items,$start,$end,$contains,$group,$link,""); 
      }

      $items = "";
      ($cmd = $1) =~ s/[\}\{]//g;
      ($alias = $2) =~ s/[\}\{]//g;
      # save the alias
      &save_command($cmd,$items,$start,$end,$contains,$group,$link,$alias); 

      # init for next
      $cmd = $1;
    }
  }
  &save_command($cmd,$items,$start,$end,$contains,$group,$link,"");  # do last
}

# Print out all the commands
foreach $cmd (sort keys %commands) {
  #print STDERR "command is $cmd\n";
  &print_command($cmd);
}

print "
delcommand HiLink
if exists(\"i\")
  unlet i
endif
";

#########################################################################
#
# Subroutines
#
#########################################################################

# save_command 
# Parse the new command into the data structure, fixing dups as necessary
sub save_command {
  my ($cmd,$items,$start,$end,$contains,$group,$link,$alias) = @_;
  print STDERR "in save, cmd is $cmd with items \"$items\"\n" if ($debug);
  print STDERR "Creating entry for command $cmd with items $items\n" if ($debug);
  if (exists $commands{$cmd}{"items"}) {
    print STDERR "\nWarning: duplicate entry for command $cmd\n" if ($verbose);
    $items = &resolve_dups($items,$commands{$cmd}{"items"});
  }
  $commands{$cmd}{"items"} = $items;
  $commands{$cmd}{"start"} = $start;
  $commands{$cmd}{"end"} = $end;
  $commands{$cmd}{"contains"} = $contains;
  $commands{$cmd}{"group"} = $group;
  $commands{$cmd}{"link"} = $link;
  $commands{$cmd}{"alias"} = $alias;
}

# resolve_dups 
# Resolve duplicate commands.
# This means returning an item list that is a superset of the duplicates
sub resolve_dups {
  my ($newitems,$olditems) = @_;
  my $items;
  my %temp_array;

  foreach $item (split(/\s+/,"$newitems $olditems")) {
    $temp_array{$item} = 1;
  }

  foreach $item (keys %temp_array) {
    $items .= " $item";
  }

  print STDERR "  Resolving duplicates...\n" if ($verbose);
  print STDERR "  newitems is $newitems\n" if ($verbose);
  print STDERR "  olditems is $olditems\n" if ($verbose);
  print STDERR "  resolved items is $items\n" if ($verbose);

  return $items;

}

# print_command 
# Do the actual output.
sub print_command {
  my ($cmd) = @_;
  my ($alias,$start,$end,$contains,$link);

  if ($commands{$cmd}{"alias"}) {
    $alias = $commands{$cmd}{"alias"};
    print STDERR "Found command $cmd aliased to $alias\n";
    $items = $commands{$alias}{"items"};
  } else {
    $items = $commands{$cmd}{"items"};
  }
  $start = $commands{$cmd}{"start"};
  $end = $commands{$cmd}{"end"};
  $contains = $commands{$cmd}{"contains"};
  $group = $commands{$cmd}{"group"};
  $link = $commands{$cmd}{"link"};
  eval "\$start = $start ;" ;
  eval "\$contains = $contains ;" ;
  foreach $reserved_word ("NONE", "ALL", "ALLBUT", "contains", "contained") {
     if ($items =~ s/\s+$reserved_word\s+/ /) {
       print STDERR "Warning: Command $cmd contained a reserved word - reserved word deleted from items list\n";
    }
  }
  print DICTFILE "$cmd $items\n" unless (!$dictfile);
  $items = &get_abbreviations($items);
  print STDERR "Printing entry for command $cmd with items $items\n" if ($verbose);

  # Only create keyword and link it if items exists (per Bram's request)
  if ($items) {
    # Remove special characters to get rid of W18 warnings
    ($cmd_clean = $cmd) =~ s/\&//g ; # & not allowed
    $cmd_clean  =~ s/:+/__/g; # :: not allowed
    
    print "syn keyword ${prefix}${cmd_clean} contained $items\n";

    print "HiLink ${prefix}${cmd_clean} ${link}\n";
    $contains .= ",${prefix}${cmd_clean}" ;
  }

  print "syn region ${group} matchgroup=tcltkCommandColor start=${start} matchgroup=NONE skip=\"^\\s*\$\" end=${end}${me},${he} contains=${contains}\n\n";
}

# get_abbreviations
# Figure out minimum abbreviations for a list of items
sub get_abbreviations {
  my ($items) = @_;
  my (@list,@list1);
  my ($i,$j,$k);
  my ($item,$otheritem,$match,$othermatch,$newitem,$newitems,$uniqchar);
  
  if ($abv) {
    $items =~ s/^\s*//;
    @list = reverse sort split(/\s+/,$items);
  
    # Go through the list one by one
    for ($i=0 ; $i <= $#list ; $i++) {
      $item = $list[$i];
  
      # Create list without this entry
      @list1 = @list;
      splice (@list1,$i,1);
  
      # March through the char's of the current item until nothing matches
      $len = length($item);
      $uniqchar = 0;
      for ($j=0; $j <= $len-1; $j++) {
        $match = substr($item,0,$j+1);
        foreach $otheritem (@list1) {
          $othermatch = substr($otheritem,0,$j+1);
          if ($othermatch eq $match) {
            $uniqchar = $j+1;
          }
        }
      }
      # if the item starts with "-", and this is the unique match, move down
      # one character
      if (($item =~ /^-/) && $uniqchar == 0) {
        $uniqchar = 1;
      }
      
      $newitem = substr($item,0,$uniqchar+1);
      $newitem .= "[";
      $newitem .= substr($item,$uniqchar+1);
      $newitem .= "]";
      $newitems = "$newitem $newitems";
    }
  
    return $newitems;
  } else {
    print STDERR "Skipping abbreviations because \$abv is not set!\n";
  }
}

sub process_options {

  use Getopt::Long;
  
  # default variables
  $prefix = "mypt"; # Shouldn't conflict with std file (pt or dctl)
  $abv = 1;  # default abv's on

  die unless GetOptions(
    "help" => \$help,
    "verbose" => \$verbose,
    "debug" => \$debug,
    "proc=s" => \@procs,
    "procdir=s" => \@procdirs,
    "prefix=s" => \$prefix,
    "abv!" => \$abv,
    "dictionary=s" => \$dictfile,
    );
  
  if ($help) {
    &show_help;
    exit;
  }

  if ($dictfile) {
    open(DICTFILE,"> $dictfile") || die "Could not open dictionary file $dictfile\n";
  }
}

sub show_help {
 print "Syntax:
    mk_tcl_syntax.pl [options]

  options:
  -debug	Turn on debug messages
  -verbose	Be chatty
  -proc file	Use procs file \"file\" (can be invoked multiple times).
  -prefix prefix Use \"prefix\" 
  -procdir dir	Use all files in  \"dir\" (can be invoked multiple times).
  -abv		Generate all valid abbreviations for command options.
                (Defaults ON, use -noabv to shut it off)
  -dict file	Create dictionary file \"file\" as dictionary output

  Common example:
    mk_tcl_syntax.pl -proc myprocs.dctl -proc groupprocs.dctl > mydctl.vim

  \n";
}

# when doing require or use we must return 1
1