view release on metacpan or  search on metacpan

examples/ace.pl  view on Meta::CPAN

  my $query = shift;
  my @commands;
  if ($query=~/^(quit|exit)/i) {
    quit();
    exit 0;
  }
  if ($query =~ /^(p?parse) (?!=)(.*)/i) {
    push (@commands,setup_parse($1,$2));
  } else {
    push (@commands,$query);
  }

  foreach (@commands) {
    print "$_\n" if @commands > 1;

    $_ = setup_remote_parse($_) if /^parse (?!=)/ && !$PATH;

    $DB->db->query($_) || return undef;
    die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR;

    while ($DB->db->status == STATUS_PENDING) {
      my $h = $DB->db->read;
      $h=~s/\0+\Z//; # get rid of nulls in data stream!
      print $h;
      print "\n" unless $h =~ /\n\Z/;
    }

    die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR;
  }
}

sub setup_readline {
  my $term = new Term::ReadLine 'aceperl';
  my (@commands) = qw/quit help classes model find follow grep longgrep list 
           show is remove query where table-maker biblio dna peptide keyset-read
           spush spop swap sand sor sxor sminus parse pparse write edit 
	   eedit shutdown who data_version kill status date time_stamps
	   count clear save undo wspec/;
  eval {
    readline::rl_basic_commands(@commands);
    readline::rl_set('TcshCompleteMode', 'On') if $TCSH;
    $readline::rl_special_prefixes='"';
    $readline::rl_completion_function=\&complete;
  };
  $term;
}

# This is a big function for command completion/guessing.
sub complete {
  my($txt,$line,$start) = @_;
  return ('"') if $txt eq '"';  # to fix wierdness

  # Examine current word in the context of the two previous ones
  $line = substr($line,0,$start+length($txt)); # truncate
  $line .= '"' if $line=~tr/"/"/ % 2;  # correct odd quote parity errors
  my(@tokens) = quotewords(' ',0,$line);
  push(@tokens,$txt) unless $txt || $line=~/\"$/;
  my $old = $txt;
  $txt = $tokens[$#tokens]; 

  debug ("\n",join(':',@tokens)," (text = $txt, start = $start, old=$old)");
  
  if (lc($tokens[$#tokens-2]) eq 'find') {
    my $count = $DB->count($tokens[$#tokens-1],"$txt*");
    if ($count > 250) {
      warn "\r\n($count possibilities -- too many to display)\n";
      $readline::force_redraw++;
      readline::redisplay();
      return;
    } else {
      my @obj = $DB->list($tokens[$#tokens-1],"$txt*");
      debug("list(",$tokens[$#tokens-1],',',"$txt*",") :",scalar(@obj)," objects retrieved");
      if ($txt=~/(.+\s+)\S*$/) {
	my $common_prefix = $1;
	return map { "$_\"" } 
	       map { substr($_,index($_,$common_prefix)+length($common_prefix))  }
	       grep(/^$txt/i,@obj);
      } else {
	return map { $_=~/\s/ ? "\"$_\"" : $_ } grep(/^$txt/i,@obj);
      }
    }
  }

  if (lc($tokens[$#tokens-1]) =~/^(find|model)/) {
    @CLASSES = $DB->classes() unless @CLASSES;
    return grep(/^$txt/i,@CLASSES);
  }

  if ($tokens[$#tokens-1] =~ /^list|show/i) {
    if ($line=~/-f\s+\S*$/) {
      return readline::rl_filename_list($txt);
    } 
    return grep (/^$txt/i,qw/-h -a -p -j -T -b -c -f/);
  }

  if ($tokens[$#tokens-1] =~ /^help/i) {
    @HELP_TOPICS = get_help_topics() unless @HELP_TOPICS;
    return grep(/^$txt/i,'query_syntax',@HELP_TOPICS);
  }

  debug(join(':',@_));

  return grep(/^$txt/i,@readline::rl_basic_commands);
}

# This handles the
sub setup_parse {
  my ($command,$file) = @_;
  my (@files) = glob($file);

  # if we're local, then we just create a series 
  # of parse commands and let tace take care of reading
  # the file
  return map {"parse $_"} @files if $PATH;

  # if we're talking to a remote server, we create a series of parse 
  # commands and stop at the first file that we find
  my @c;
  local(*F);
  local($/) = undef;  # file slurp
  foreach (@files) {
    open (F,$_) || die "Couldn't open $_: $!";
    print "parse $_\n";
    my $result = $DB->raw_query(scalar(<F>),1);
    print $result;
    return if $result=~/error|sorry/i and $command ne 'pparse';
    close F;
  }
  return ();
}

sub get_help_topics {
  return () unless $DB;
  my $result = $DB->raw_query('help topics');
  return grep(/^About/../^nohelp/,split(' ',$result));
}

sub debug {
  return unless DEBUG;
  my @text = @_;
  warn "\n",@text,"\n";
  $readline::force_redraw++;
  readline::redisplay();
}

sub read_top_material {
  while ($DB->db->status == STATUS_PENDING) {
    my $h = $DB->db->low_read;
    $h=~s/\A\s+\*\*\*.+\.\n\n//s;
    $h=~s!\n// Type.*\n!!s;
    $h=~s/acedb> \Z//;
    $h=~s/\0+\Z//; # get rid of nulls in data stream!
    print $h;
  }
}

sub get_passwd {
  my $user = shift;
  local $| = 1;
  chomp(my $settings = `stty -g </dev/tty`);
  system "stty -echo </dev/tty";
  print $ENV{EMACS} ? "password: " : "$user password: ";
  chomp(my $password = <STDIN>);
  print "\n";
  system "stty $settings </dev/tty";
  return $password;
}