AcePerl
view release on metacpan or search on metacpan
# Be very careful here. The key used for the memory cache is in the format
# db:class:name, but the key used for the file cache is in the format class:name.
# The difference is that the filecache has a built-in namespace but the memory
# cache doesn't.
sub memory_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ":",$self,$class,$name;
return unless defined $MEMORY_CACHE{$key};
carp "memory_cache hit on $class:$name"
if Ace->debug;
return $MEMORY_CACHE{$key};
}
sub memory_cache_store {
my $self = shift;
croak "Usage: memory_cache_store(\$obj)" unless @_ == 1;
my $obj = shift;
my $key = join ':',$obj->db,$obj->class,$obj->name;
return if exists $MEMORY_CACHE{$key};
carp "memory_cache store on ",$obj->class,":",$obj->name if Ace->debug;
weaken($MEMORY_CACHE{$key} = $obj);
}
sub memory_cache_clear {
my $self = shift;
%MEMORY_CACHE = ();
}
sub memory_cache_delete {
my $package = shift;
my $key = join ':',$class,$name;
my $cache = $self->cache or return;
my $obj = $cache->get($key);
if ($obj && !exists $obj->{'.root'}) { # consistency checks
require Data::Dumper;
warn "CACHE BUG! Discarding inconsistent object $obj\n";
warn Data::Dumper->Dump([$obj],['obj']);
$cache->remove($key);
return;
}
warn "cache ",$obj?'hit':'miss'," on '$key'\n" if Ace->debug;
$self->memory_cache_store($obj) if $obj;
$obj;
}
# call as
# $ace->file_cache_store($obj);
sub file_cache_store {
my $self = shift;
my $obj = shift;
return unless $obj->name;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
warn "caching $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
if ($key eq ':') { # something badly wrong
cluck "NULL OBJECT";
}
$cache->set($key,$obj);
}
sub file_cache_delete {
my $self = shift;
my $obj = shift;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
carp "deleting $key obj=",overload::StrVal($obj),"\n" if Ace->debug;
$cache->remove($key,$obj);
}
#### END: CACHE AND CARRY CODE ####
# Fetch one or a group of objects from the database
sub fetch {
my $self = shift;
my ($class,$pattern,$count,$offset,$query,$filled,$total,$filltag) =
$self->raw_query('save') if $self->auto_save;
foreach (keys %{$self->{iterators}}) {
$self->_unregister_iterator($_);
}
delete $self->{database};
}
sub DESTROY {
my $self = shift;
return if caller() =~ /^Cache\:\:/;
warn "$self->DESTROY at ", join ' ',caller() if Ace->debug;
$self->close;
}
#####################################################################
###################### private routines #############################
sub rearrange {
my($order,@param) = @_;
return unless @param;
my %param;
$today = Ace->date([$time]);
These convenience functions convert the UNIX timestamp given by $time
(seconds since the epoch) into a datetime string in the format that
ACEDB requires. date() will truncate the time portion.
If not provided, $time defaults to localtime().
=head1 OTHER METHODS
=head2 debug()
$debug_level = Ace->debug([$new_level])
This class method gets or sets the debug level. Higher integers
increase verbosity. 0 or undef turns off debug messages.
=head2 name2db()
$db = Ace->name2db($name [,$database])
This class method associates a database URL with an Ace database
object. This is used internally by the Ace::Object class in order to
discover what database they "belong" to.
=head2 cache()
Copyright (c) 1997-1998 Cold Spring Harbor Laboratory
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. See DISCLAIMER.txt for
disclaimers of warranty.
=cut
# -------------------- AUTOLOADED SUBS ------------------
sub debug {
my $package = shift;
my $d = $DEBUG_LEVEL;
$DEBUG_LEVEL = shift if @_;
$d;
}
# Return true if the database is still connected. This is oddly convoluted
# because there are numerous things that can go wrong, including:
# 1. server has gone away
# 2. server has timed out our connection! (grrrrr)
Ace/Local.pm view on Meta::CPAN
return bless {
'read' => $rdr,
'write' => $wtr,
'prompt' => $prompt,
'pid' => $pid,
'auto_save' => 1,
'status' => $nosync ? STATUS_PENDING : STATUS_WAITING, # initial stuff to read
},$class;
}
sub debug {
my $self = shift;
my $d = $self->{debug};
$self->{debug} = shift if @_;
$d;
}
sub DESTROY {
my $self = shift;
return unless kill 0,$self->{'pid'};
if ($self->auto_save) {
# save work for the user...
$self->query('save');
$self->synch;
Ace/Local.pm view on Meta::CPAN
}
sub error {
my $self = shift;
return $self->{'error'};
}
sub query {
my $self = shift;
my $query = shift;
warn "query($query)\n" if $self->debug;
if ($self->debug) {
my $msg = $query || '';
warn "\tquery($msg)";
}
return undef if $self->{'status'} == STATUS_ERROR;
do $self->read() until $self->{'status'} != STATUS_PENDING;
my $wtr = $self->{'write'};
print $wtr "$query\n";
$self->{'status'} = STATUS_PENDING;
}
Ace/Object.pm view on Meta::CPAN
sub DESTROY {
my $self = shift;
return unless defined $self->{class}; # avoid working with temp objects from a search()
return if caller() =~ /^(Cache\:\:|DB)/; # prevent recursion in FileCache code
my $db = $self->db or return;
return if $self->{'.nocache'};
return unless $self->isRoot;
if ($self->_dirty) {
warn "Destroy for ",overload::StrVal($self)," ",$self->class,':',$self->name if Ace->debug;
$self->_dirty(0);
$db->file_cache_store($self);
}
# remove our in-memory cache
# shouldn't be necessary with weakref
# $db->memory_cache_delete($self);
}
###################### object constructor #################
Ace/Object.pm view on Meta::CPAN
When a root Ace object instantiates its tree of tags and values, it
creates a hierarchical structure of Ace::Object objects. The
factory() method determines what class to bless these subsidiary
objects into. By default, they are Ace::Object objects, but you can
override this method in a child class in order to create more
specialized Ace::Object classes. The method should return a string
corresponding to the package to bless the object into. It receives
the current Ace::Object as its first argument.
=head2 debug() method
$object->debug(1);
Change the debugging mode. A zero turns off debugging messages.
Integer values produce debug messages on standard error. Higher
integers produce progressively more verbose messages. This actually
is just a front end to Ace->debug(), so the debugging level is global.
=head1 SEE ALSO
L<Ace>, L<Ace::Model>, L<Ace::Object>, L<Ace::Local>,
L<Ace::Sequence>,L<Ace::Sequence::Multi>
=head1 AUTHOR
Lincoln Stein <lstein@cshl.org> with extensive help from Jean
Thierry-Mieg <mieg@kaa.crbm.cnrs-mop.fr>
Ace/Object.pm view on Meta::CPAN
$name =~ s/([^a-zA-Z0-9_-])/\\$1/g;
return 1 unless exists $self->{'.update'} && $self->{'.update'};
$Ace::Error = '';
my $result = '';
# bad design alert: the following breaks encapsulation
if ($db->db->can('write')) { # new way for socket server
my $cmd = join "\n","$self->{'class'} : $name",@{$self->{'.update'}};
warn $cmd if $self->debug;
$result = $db->raw_query($cmd,0,'parse'); # sets Ace::Error for us
} else { # old way for RPC server and local
my $cmd = join('; ',"$self->{'class'} : $name",
@{$self->{'.update'}});
warn $cmd if $self->debug;
$result = $db->raw_query("parse = $cmd");
}
if (defined($result) and $result=~/write( or admin)? access/im) { # this keeps changing
$Ace::Error = "Write access denied";
} elsif (defined($result) and $result =~ /sorry|parse error/mi) {
$Ace::Error = $result;
}
return if $Ace::Error;
undef $self->{'.update'};
Ace/Object.pm view on Meta::CPAN
sub rollback {
my $self = shift;
undef $self->{'.update'};
# this will force object to be reloaded from database
# next time it is needed.
delete $self->{'.right'};
delete $self->{'.PATHS'};
1;
}
sub debug {
my $self = shift;
Ace->debug(@_);
}
### Get or set the date style (actually calls through to the database object) ###
sub date_style {
my $self = shift;
return unless $self->db;
return $self->db->date_style(@_);
}
sub _asHTML {
Ace/Sequence.pm view on Meta::CPAN
}
}
sub offset { $_[0]->{offset} }
sub p_offset { $_[0]->{p_offset} }
sub smapped { 1; }
sub type { 'Sequence' }
sub subtype { }
sub debug {
my $self = shift;
my $d = $self->{_debug};
$self->{_debug} = shift if @_;
$d;
}
# return the database this sequence is associated with
sub db {
return Ace->name2db($_[0]->{db} ||= $_[0]->source->db);
}
sub start {
my ($self,$abs) = @_;
Ace/Sequence.pm view on Meta::CPAN
}
# turn on absolute coordinates (relative to reference sequence)
sub absolute {
my $self = shift;
my $prev = $self->{absolute};
$self->{absolute} = $_[0] if defined $_[0];
return $prev;
}
# human readable string (for debugging)
sub asString {
my $self = shift;
if ($self->absolute) {
return join '',$self->parent,'/',$self->start,',',$self->end;
} elsif (my $ref = $self->refseq){
my $label = $ref->isa('Ace::Sequence::Feature') ? $ref->info : "$ref";
return join '',$label,'/',$self->start,',',$self->end;
} else {
join '',$self->source,'/',$self->start,',',$self->end;
Ace/Sequence.pm view on Meta::CPAN
sub gff {
my $self = shift;
my ($abs,$features) = rearrange([['ABS','ABSOLUTE'],'FEATURES'],@_);
$abs = $self->absolute unless defined $abs;
# can provide list of feature names, such as 'similarity', or 'all' to get 'em all
# !THIS IS BROKEN; IT SHOULD LOOK LIKE FEATURE()!
my $opt = $self->_feature_filter($features);
my $gff = $self->_gff($opt);
warn $gff if $self->debug;
$self->transformGFF(\$gff) unless $abs;
return $gff;
}
# return a GFF object using the optional GFF.pm module
sub GFF {
my $self = shift;
my ($filter,$converter) = @_; # anonymous subs
croak "GFF module not installed" unless require GFF;
Ace/Sequence.pm view on Meta::CPAN
($start,$end) = ($end,$start) if $start > $end; #flippity floppity
my $coord = "-coords $start $end";
# BAD BAD HACK ALERT - CHECKS THE QUERY THAT IS PASSED DOWN
# ALSO MAKES THINGS INCOMPATIBLE WITH PRIOR 4.9 servers.
# my $opt = $command =~ /seqfeatures/ ? '-nodna' : '';
my $opt = '-noclip';
my $query = "gif seqget $parent $opt $coord ; $command";
warn $query if $self->debug;
return $db->raw_query("gif seqget $parent $opt $coord ; $command");
}
# utility function -- reverse complement
sub _complement {
my $dna = shift;
$$dna =~ tr/GATCgatc/CTAGctag/;
$$dna = scalar reverse $$dna;
}
Ace/SocketServer.pm view on Meta::CPAN
sub encore { return shift->{encoring} }
sub status { shift->{status} }
sub error { $Ace::Error; }
sub query {
my $self = shift;
my ($request,$parse) = @_;
warn "query($request)" if Ace->debug;
unless ($self->_send_msg($request,$parse)) {
$self->{status} = STATUS_ERROR;
return _error("Write to socket server failed: $!");
}
$self->{status} = STATUS_PENDING;
$self->{encoring} = 0;
return 1;
}
sub read {
1.92 Tue Nov 11 11:43:17 EST 2008
1. Cache ignores objects that do not have a proper name.
1.91 Tue Oct 31 17:42:00 EST 2006
1. Updated AUTOLOAD style so that inheritance works again.
2. Removed dependency on WeakRef
1.90 Thu Mar 17 17:09:10 EST 2005
1. Fixed error in which the -fill argument wasn't being passed down to get() caching code.
2. Added a debug() method to Ace::SocketServer && Ace::Local.
1.89 Wed Mar 9 18:25:45 EST 2005
1. Added caching code.
2. Now requires ace binaries 4_9s or later.
3. Requires CACHE::CACHE and WeakRef for caching.
1.87 10/3/03
1. Fixed unreadable GIF images produced by recent versions of GifAceServer.
2. Fixed Ace::Model to handle #tags properly.
1.86 5/11/03
acelib/arraysub.c view on Meta::CPAN
void assDump (Associator a)
{ int i ;
void **in, **out ;
char *cp0 = 0 ;
if (!assExists(a)) return ;
i = 1 << a->m ;
in = a->in - 1 ; out = a->out - 1 ;
/* keep stderr here since it is for debugging */
fprintf (stderr,"Associator %lx : %d pairs\n",(unsigned long)a,a->n) ;
while (in++, out++, i--)
if (*in && *in != moins_un) /* not empty or deleted */
fprintf (stderr,"%lx - %lx\n",
(long)((char*)(*in) - cp0),(long)( (char *)(*out) - cp0)) ;
}
/************************ end of file ********************************/
/**********************************************************************/
acelib/messubs.c view on Meta::CPAN
* * Sep 24 16:47 1998 (edgrif): Remove references to ACEDB in messages,
* change messExit prefix to "EXIT: "
* * Sep 22 14:35 1998 (edgrif): Correct errors in buffer usage by message
* outputting routines and message formatting routines.
* * Sep 11 09:22 1998 (edgrif): Add messExit routine.
* * Sep 9 16:52 1998 (edgrif): Add a messErrorInit function to allow an
* application to register its name for use in crash messages.
* * Sep 3 11:32 1998 (edgrif): Rationalise strings used as prefixes for
* messages. Add support for new messcrash macro to replace
* messcrash routine, this includes file/line info. for
* debugging (see regular.h for macro def.) and a new
* uMessCrash routine.
* * Aug 25 14:51 1998 (edgrif): Made BUFSIZE enum (shows up in debugger).
* Rationalise the use of va_xx calls into a single macro/
* function and improve error checking on vsprintf.
* messdump was writing into messbuf half way up, I've stopped
* this and made two buffers of half the original size, one for
* messages and one for messdump.
* * Aug 21 13:43 1998 (rd): major changes to make clean from NON_GRAPHICS
* and ACEDB. Callbacks can be registered for essentially
* all functions. mess*() versions continue to centralise
* handling of ... via stdarg.
* * Aug 20 17:10 1998 (rd): moved memory handling to memsubs.c
acelib/messubs.c view on Meta::CPAN
#define CRASH_PREFIX_FORMAT "FATAL ERROR reported by %s at line %d: "
#define FULL_CRASH_PREFIX_FORMAT "FATAL ERROR reported by program %s, in file %s, at line %d: "
#if defined(MACINTOSH)
#define SYSERR_FORMAT "system error %d"
#else
#define SYSERR_FORMAT "system error %d - %s"
#endif
#define PROGNAME "The program"
/* messcrash now reports the file/line no. where the messcrash was issued */
/* as an aid to debugging. We do this using a static structure which holds */
/* the information and a macro version of messcrash (see regular.h), the */
/* structure elements are retrieved using access functions. */
typedef struct _MessErrorInfo
{
char *progname ; /* Name of executable reporting error. */
char *filename ; /* Filename where error reported */
int line_num ; /* Line number of file where error
reported. */
} MessErrorInfo ;
acelib/messubs.c view on Meta::CPAN
}
}
/* CHECK PERFORMANCE ISSUES....how is database dumped/logged. */
/* Fred has suggested that we could do a vprintf to /dev/null and see how */
/* many bytes that is then we could get away from a fixed internal buffer */
/* at all....but watch out, if messdump say is in a tight loop then this */
/* will kill performance... */
/* We could add a #define to allow a check to be included for debug code. */
/* */
/* Do the format. */
#ifdef SUN
{
char *return_str;
/* NOTE, that SUNs vsprintf returns a char* */
acelib/messubs.c view on Meta::CPAN
}
static int messGetErrorLine()
{
return messageG.line_num ;
}
/*****************************/
/* put "break invokeDebugger" in your favourite debugger init file */
UTIL_FUNC_DEF void invokeDebugger (void)
{
static BOOL reentrant = FALSE ;
if (!reentrant)
{ reentrant = TRUE ;
messalloccheck() ;
reentrant = FALSE ;
}
acelib/wh/array.h view on Meta::CPAN
#define assFindNext(ax,xin,pout) uAssFindNext((ax),(xin),(void**)(pout))
BOOL assInsert (Associator a, void* xin, void* xout) ;
/* if already there returns FALSE, else inserts and returns TRUE */
void assMultipleInsert(Associator a, void* xin, void* xout);
/* allow multiple Insertions */
BOOL assRemove (Associator a, void* xin) ;
/* if found, removes entry and returns TRUE, else returns FALSE */
BOOL assPairRemove (Associator a, void* xin, void* xout) ;
/* remove only if both fit */
void assDump (Associator a) ;
/* for debug - uses printf */
void assClear (Associator a) ;
BOOL uAssNext (Associator a, void* *pin, void* *pout) ;
#define assNext(ax,pin,pout) uAssNext((ax),(void**)(pin),(void**)pout)
/* convert an integer to a void * without generating a compiler warning */
#define assVoid(i) ((void *)(((char *)0) + (i)))
#define assInt(v) ((int)(((char *)v) - ((char *)0)))
#endif /* defined(DEF_ARRAY_H) */
/**************************** End of File ******************************/
acelib/wh/regular.h view on Meta::CPAN
* This file is part of the ACEDB genome database package, written by
* Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and
* Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
*
* HISTORY:
* Last edited: Aug 20 11:50 1997 (rbrusk)
* * Sep 9 16:54 1998 (edgrif): Add messErrorInit decl.
* * Sep 9 14:31 1998 (edgrif): Add filGetFilename decl.
* * Aug 20 11:50 1998 (rbrusk): AUL_FUNC_DCL
* * Sep 3 11:50 1998 (edgrif): Add macro version of messcrash to give
* file/line info for debugging.
* Created: 1991 (rd)
*-------------------------------------------------------------------
*/
#ifndef DEF_REGULAR_H
#define DEF_REGULAR_H
/* library EXPORT/IMPORT symbols */
#if defined (WIN32)
#include "win32libspec.h" /* must come before mystdlib.h...*/
acelib/wh/regular.h view on Meta::CPAN
typedef void (*Arg1Routine)(void *arg1) ;
/* magic_t : the type that all magic symbols are declared of.
They become magic (i.e. unique) by using the pointer
to that unique symbol, which has been placed somewhere
in the address space by the compiler */
/* type-magics and associator codes are defined at
magic_t MYTYPE_MAGIC = "MYTYPE";
The address of the string is then used as the unique
identifier (as type->magic or graphAssXxx-code), and the
string can be used during debugging */
typedef char* magic_t;
typedef struct freestruct
{ KEY key ;
char *text ;
} FREEOPT ;
acelib/wh/regular.h view on Meta::CPAN
/*******************************************************************/
/************* randsubs.c random number generator ******************/
UTIL_FUNC_DCL double randfloat (void) ;
UTIL_FUNC_DCL double randgauss (void) ;
UTIL_FUNC_DCL int randint (void) ;
UTIL_FUNC_DCL void randsave (int *arr) ;
UTIL_FUNC_DCL void randrestore (int *arr) ;
/* Unix debugging. */
/* put "break invokeDebugger" in your favourite debugger init file */
/* this function is empty, it is defined in messubs.c used in
messerror, messcrash and when ever you need it.
*/
UTIL_FUNC_DCL void invokeDebugger(void) ;
/*******************************************************************/
/************* some WIN32 debugging utilities **********************/
#if defined (WIN32)
#if defined(_DEBUG)
/* See win32util.cpp for these functions */
UTIL_FUNC_DCL const char *dbgPos( const char *caller, int lineno, const char *called ) ;
UTIL_FUNC_DCL void WinTrace(char *prompt, unsigned long code) ;
UTIL_FUNC_DCL void AceASSERT(int condition) ;
UTIL_FUNC_DCL void NoMemoryTracking() ;
#else /* !defined(_DEBUG) */
#define dbgPos(c,l,fil) (const char *)(fil)
docs/ACEDB.HOWTO view on Meta::CPAN
cause ACeDB binaries linked on one platform to behave differently on
another.
ACeDB distributions are available at:
ftp://ftp.wormbase.org/pub/wormbase/software/
ftp://ncbi.nlm.nih.gov/repository/acedb/
I recommend that you use the ftp.wormbase.org URL, as this contains
the latest stable snapshot of ACeDB that I use for testing and
debugging the current release of AcePerl.
COMPILING THE SOFTWARE
Unpack the software into its own directory:
1) mkdir acedb
2) gunzip -c acedb-latest.tar.gz | tar xvf -
Compile the software. The makefile requires that an environment
variable named ACEDB_MACHINE be defined. This environment variable is
examples/ace.pl view on Meta::CPAN
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);
}
}
}
examples/ace.pl view on Meta::CPAN
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
examples/ace.pl view on Meta::CPAN
}
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;
Cambridge CB10 1SA
U.K.
E_mail jes@sanger.ac.uk
Phone 1223-834244
1223-494958
Fax 1223-494919
};
my @args = (-host=>HOST,-port=>PORT,-timeout=>50);
push @args,(-cache=>{}
) if TEST_CACHE || $ENV{TEST_CACHE};
Ace->debug(0);
test(2,$db = Ace->connect(@args),"connection failure");
die "Couldn't establish connection to database. Aborting tests.\n" unless $db;
test(3,$obj = $db->fetch('Author','Sulston JE'),"fetch failure");
print STDERR "\n ...Failed to get test object. Wrong database?\n Expect more failures... "
unless $obj;
test(4,defined($obj) && $obj eq 'Sulston JE',"string overload failure");
test(5,@obj = $db->fetch('Author','Sulston*'),"wildcard failure");
test(6,@obj==2,"failed to recover two authors from Sulston*");
test(7,defined($obj) && $obj->right eq 'Also_known_as',"auto fill failure");
test(8,defined($obj) && $obj->Also_known_as eq 'John Sulston',"automatic method generation failure");
util/ace.PLS view on Meta::CPAN
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);
}
}
}
util/ace.PLS view on Meta::CPAN
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
util/ace.PLS view on Meta::CPAN
}
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;
( run in 1.360 second using v1.01-cache-2.11-cpan-49f99fa48dc )