view release on metacpan or  search on metacpan

examples/ace.pl  view on Meta::CPAN

	   'password:s' => \$PASS,
	   'save'   => \$AUTOSAVE,
	   'exec=s' => \@EXEC,
	  ) || die <<USAGE;
Usage: $0 [options] [URL]
Interactive Perl client for ACEDB

Options (can be abbreviated):
       -host <hostname>  Server host (localhost)
       -port <port>      Server port (200005)
       -path <db path>   Local database path (no default)
       -url  <url>       Server URL (see below
       -login <user>     Username
       -pass <pass>      Password
       -tcsh             Use T-shell completion mode
       -save             Save database updates automatically
       -exec <command>   Run a command and quit

Respects the environment variables \$ACEDB_HOST and \$ACEDB_PORT, if present.
You can edit the command line using the cursor keys and emacs style
key bindings.  Use up and down arrows (or ^P, ^N) to access the history.
The tab key completes partial commands.  In tcsh mode, the tab key cycles 
among the completions, otherwise pressing the tab key a second time lists 
all the possibilities.

You may use multiple -exec switches to run a sequence of commands, or
separate multiple commands in a single string by semicolons:

    ace.pl -e 'find Author Thierry-Mieg*' -e 'show'
    ace.pl -e 'find Author Thierry-Mieg*; show'

Server URLs:
  rpcace://hostname:port   RPC server
  sace://hostname:port     Socket server
  tace:/path/to/database   Local database
  /path/to/database        Local database

  Usernames can be provided as sace://user\@hostname:port
USAGE
;
				   
$HOST ||= $ENV{ACEDB_HOST} || 'localhost';
$PORT ||= $ENV{ACEDB_PORT} || 200005;
$URL  = shift if $ARGV[0] =~ /^(rpcace|sace|tace):/;

my $PROMPT = "aceperl> ";

$USER ||= $1 if $URL && $URL=~ m!//(\w+)\@!;
$PASS ||= get_passwd($USER) if $USER;

my $DB = $URL ? Ace->connect(-url=>$URL,-user=>$USER,-pass=>$PASS) 
              : $PATH ? Ace->connect(-path=>$PATH) 
                      : Ace->connect(-host=>$HOST,-port=>$PORT,-user=>$USER,-pass=>$PASS);

$DB ||  die "Connection failure: ",Ace->error,"\n";
$DB->auto_save($AUTOSAVE);

if (@EXEC) {
  foreach (@EXEC) { 
    foreach (split (';'))
      { evaluate($_); }
  }
  exit 0;
}

# read_top_material() if $PATH;

if (@ARGV || !-t STDIN) {

  while (<>) {
    chomp;
    evaluate($_);
  }
} elsif (eval "require Term::ReadLine") {
  my $term = setup_readline();
  while (defined($_ = $term->readline($PROMPT)) ) {
    evaluate($_);
  }

} else {
  $| = 1;
  print $PROMPT;
  while (<>) {
    chomp;
    evaluate($_);
  } continue {
    print $PROMPT;
  }
}
quit();

sub quit {
  undef $DB;
  print "\n// A bientot!\n";
  exit 0;
}

sub evaluate {
  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);
  }