CQL-Parser-1.13/0000755000175000017500000000000012222667773012615 5ustar bricasbricasCQL-Parser-1.13/Changes0000644000175000017500000000462512222667015014104 0ustar bricasbricasChange History 1.13 2013-10-01 - don't ship MYMETA (RT #89143) 1.12 2012-11-05 - new method parseSafe with error codes - Fix spelling mistake in pod (RT #70052) 1.10 2009-12-02 - new support for v1.1 style proximity (thanks Masao Takaku at the National Institute of Informatics) - remove use of UNIVERSAL->import 1.00 2006-11-27 - updated Lexer.pm and Parser.pm to allow 0 to be a valid term (thanks Ben Soares at Edinburgh University Data Library) - added unit tests to lexer.t and parser.t for 0 as a term 0.98 2006-02-13 - added 'within' and 'encloses' relations - added 'partial' relation qualifier - added tests for the above - thanks for the above to Sol Lederman - removed tabs 0.97 2006-01-27 - fixed bug not preserving the case of reserved words in search terms - added handling escaped double quotes in double quoted string - added relation modifiers word, string, isoDate, number, uri, masked, unmasked - added tests for these three to t/parser.t 0.96 2005-11-30 - reserved words are now case insensitive, thanks Wilbert - added test of case insensitivity to t/parser.t - added brian and wilbert to the list of authors 0.95 2005-11-22 - bug fix to Lexer.pm to recognize <> tokens! Thanks Wilbert Hengst at University of Amsterdam. 0.94 2005-10-04 - added fuzzy and proximity searching for toLucene() (thanks Xiaorong Xiang and Eric Lease Morgan of the ockham project) 0.93 2005-09-06 - removed Sub::Uplevel from PREREQs - fixed "uninitialized value" warnings on toXCQL (thanks Steven McDonald) 0.92 2005-09-01 - pod fixes - added pod test 0.91 2005-08-08 - added toLucene() 0.9 2005-08-05 - added whitespace fix so phrases with trailing "\n" will parse (thanks Mike Taylor) 0.8 2005-04-07 - added Class::Accessor to Makefile.PL (thanks Mike Taylor) 0.7 2005-02-21 - added namespace declaration to top element in XCQL output 0.6 2004-12-20 - forgot to add comments about this release :( 0.51 2004-12-16 - needed to make CQL::TermNode inherit from CQL::Node 0.5 2004-12-16 - added ability to clone a parse tree courtesy of Ray Finch's Clone 0.4 2004-12-14 - added CQL::Visitor for transforming parse trees 0.3 2004-12-05 - fixed bug in relation toXCQL() 0.2 2004-09-14 - add toXCQL() functionality 0.11 2004-09-14 - forgot to give mad props to Mike Taylor at IndexData who wrote cql-java which CQL is essentially a Perl port of. 0.1 2004-09-13 - initial release CQL-Parser-1.13/Makefile.PL0000644000175000017500000000066012045741603014555 0ustar bricasbricasuse inc::Module::Install 1.06; if ( -e 'MANIFEST.SKIP' ) { system( 'pod2text lib/CQL/Parser.pm > README' ); } perl_version '5.008'; name 'CQL-Parser'; all_from 'lib/CQL/Parser.pm'; requires 'String::Tokenizer' => '0.05'; requires 'Clone' => '0.15'; requires 'Class::Accessor' => '0.1'; test_requires 'Test::More'; test_requires 'Test::Exception'; repository "http://github.com/bricas/cql-parser"; WriteAll; CQL-Parser-1.13/inc/0000755000175000017500000000000012222667773013366 5ustar bricasbricasCQL-Parser-1.13/inc/Module/0000755000175000017500000000000012222667773014613 5ustar bricasbricasCQL-Parser-1.13/inc/Module/Install.pm0000644000175000017500000003013512222667723016554 0ustar bricasbricas#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. CQL-Parser-1.13/inc/Module/Install/0000755000175000017500000000000012222667773016221 5ustar bricasbricasCQL-Parser-1.13/inc/Module/Install/Can.pm0000644000175000017500000000615712222667725017266 0ustar bricasbricas#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 CQL-Parser-1.13/inc/Module/Install/Makefile.pm0000644000175000017500000002743712222667725020306 0ustar bricasbricas#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 CQL-Parser-1.13/inc/Module/Install/Base.pm0000644000175000017500000000214712222667725017432 0ustar bricasbricas#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 CQL-Parser-1.13/inc/Module/Install/Win32.pm0000644000175000017500000000340312222667725017456 0ustar bricasbricas#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; CQL-Parser-1.13/inc/Module/Install/Fetch.pm0000644000175000017500000000462712222667725017616 0ustar bricasbricas#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; CQL-Parser-1.13/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612222667725020307 0ustar bricasbricas#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; CQL-Parser-1.13/inc/Module/Install/Metadata.pm0000644000175000017500000004327712222667725020311 0ustar bricasbricas#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; CQL-Parser-1.13/META.yml0000644000175000017500000000124412222667726014065 0ustar bricasbricas--- abstract: 'compiles CQL strings into parse trees of Node subtypes.' author: - '=over 4' build_requires: ExtUtils::MakeMaker: 6.59 Test::Exception: 0 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: CQL-Parser no_index: directory: - inc - t requires: Class::Accessor: 0.1 Clone: 0.15 String::Tokenizer: 0.05 perl: 5.8.0 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/bricas/cql-parser version: 1.13 CQL-Parser-1.13/README0000644000175000017500000001006412222667725013473 0ustar bricasbricasNAME CQL::Parser - compiles CQL strings into parse trees of Node subtypes. SYNOPSIS use CQL::Parser; my $parser = CQL::Parser->new(); my $root = $parser->parse( $cql ); DESCRIPTION CQL::Parser provides a mechanism to parse Common Query Language (CQL) statements. The best description of CQL comes from the CQL homepage at the Library of Congress CQL is a formal language for representing queries to information retrieval systems such as web indexes, bibliographic catalogs and museum collection information. The CQL design objective is that queries be human readable and human writable, and that the language be intuitive while maintaining the expressiveness of more complex languages. A CQL statement can be as simple as a single keyword, or as complicated as a set of compoenents indicating search indexes, relations, relational modifiers, proximity clauses and boolean logic. CQL::Parser will parse CQL statements and return the root node for a tree of nodes which describes the CQL statement. This data structure can then be used by a client application to analyze the statement, and possibly turn it into a query for a local repository. Each CQL component in the tree inherits from CQL::Node and can be one of the following: CQL::AndNode, CQL::NotNode, CQL::OrNode, CQL::ProxNode, CQL::TermNode, CQL::PrefixNode. See the documentation for those modules for their respective APIs. Here are some examples of CQL statements: * george * dc.creator=george * dc.creator="George Clinton" * clinton and funk * clinton and parliament and funk * (clinton or bootsy) and funk * dc.creator="clinton" and dc.date="1976" METHODS new() parse( $query ) Pass in a CQL query and you'll get back the root node for the CQL parse tree. If the CQL is invalid an exception will be thrown. parseSafe( $query ) Pass in a CQL query and you'll get back the root node for the CQL parse tree. If the CQL is invalid, an error code from the SRU Diagnostics List will be returned. XCQL CQL has an XML representation which you can generate from a CQL parse tree. Just call the toXCQL() method on the root node you get back from a call to parse(). ERRORS AND DIAGNOSTICS As mentioned above, a CQL syntax error will result in an exception being thrown. So if you have any doubts about the CQL that you are parsing you should wrap the call to parse() in an eval block, and check $@ afterwards to make sure everything went ok. eval { my $node = $parser->parse( $cql ); }; if ( $@ ) { print "uhoh, exception $@\n"; } If you'd like to see blow by blow details while your CQL is being parsed set $CQL::DEBUG equal to 1, and you will get details on STDERR. This is useful if the parse tree is incorrect and you want to locate where things are going wrong. Hopefully this won't happen, but if it does please notify the author. TODO * toYourEngineHere() please feel free to add functionality and send in patches! THANKYOUS CQL::Parser is essentially a Perl port of Mike Taylor's cql-java package http://zing.z3950.org/cql/java/. Mike and IndexData were kind enough to allow the author to write this port, and to make it available under the terms of the Artistic License. Thanks Mike! The CQL::Lexer package relies heavily on Stevan Little's excellent String::Tokenizer. Thanks Stevan! CQL::Parser was developed as a component of the Ockham project, which is funded by the National Science Foundation. See http://www.ockham.org for more information about Ockham. AUTHOR * Ed Summers - ehs at pobox dot com * Brian Cassidy - bricas at cpan dot org * Wilbert Hengst - W.Hengst at uva dot nl COPYRIGHT AND LICENSE Copyright 2004-2009 by Ed Summers This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. CQL-Parser-1.13/t/0000755000175000017500000000000012222667773013060 5ustar bricasbricasCQL-Parser-1.13/t/changes.t0000644000175000017500000000020312045741350014633 0ustar bricasbricasuse Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); CQL-Parser-1.13/t/term.t0000644000175000017500000000266612045741350014211 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use_ok( "CQL::TermNode" ); use_ok( "CQL::Relation" ); NO_RELATION: { my $node = CQL::TermNode->new( term => 'george' ); isa_ok( $node, 'CQL::TermNode' ); is( $node->getTerm(), 'george', 'term()' ); is( $node->toCQL(), 'george', 'toCQL()' ); } QUALIFIER_AND_RELATION: { my $node = CQL::TermNode->new( qualifier => 'dc.creator', relation => CQL::Relation->new( '=' ), term => 'george' ); is( $node->getQualifier(), 'dc.creator', 'getQualifier()' ); is( $node->getRelation()->getBase(), '=', 'getRelation()' ); is( $node->getTerm(), 'george', 'getTerm()' ); is( $node->toCQL(), 'dc.creator = george', 'toCQL()' ); my $xcql = $node->toXCQL(0); $xcql =~ s/[\r\n]//g; $xcql =~ s/> +dc.creator=george), 'toXCQL()' ) } SPACES_IN_TERM: { my $node = CQL::TermNode->new( qualifier => 'dc.creator', relation => CQL::Relation->new( '>' ), term => 'george clinton' ); is( $node->getQualifier(), 'dc.creator', 'getQualifier()' ); is( $node->getRelation()->getBase(), '>', 'getRelation()' ); is( $node->getTerm(), 'george clinton', 'getTerm()' ); is( $node->toCQL(), 'dc.creator > "george clinton"', 'toCQL()' ); } CQL-Parser-1.13/t/boolean.t0000644000175000017500000000271612045741350014655 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use_ok( 'CQL::TermNode' ); use_ok( 'CQL::AndNode' ); use_ok( 'CQL::OrNode' ); use_ok( 'CQL::NotNode' ); use_ok( 'CQL::ProxNode' ); ## create a couple terms my $term1 = CQL::TermNode->new( term => 'foo' ); isa_ok( $term1, 'CQL::TermNode' ); my $term2 = CQL::TermNode->new( term => 'bar' ); isa_ok( $term2, 'CQL::TermNode' ); ## AND my $and = CQL::AndNode->new( left=>$term1, right=>$term2 ); isa_ok( $and, 'CQL::AndNode' ); is( $and->toCQL(), '(foo) and (bar)', 'and toCQL()' ); my $xcql = $and->toXCQL(0); $xcql =~ s/[\r\n]//g; $xcql =~ s/> +andfoobar), ,'toXCQL()' ); ## OR my $or = CQL::OrNode->new( left=>$term1, right=>$term2 ); isa_ok( $or, 'CQL::OrNode' ); is( $or->toCQL(), '(foo) or (bar)', 'or toCQL()' ); ## NOT my $not = CQL::NotNode->new( left=>$term1, right=>$term2 ); isa_ok( $not, 'CQL::NotNode' ); is( $not->toCQL(), '(foo) not (bar)', 'not toCQL()' ); ## PROX my $prox = CQL::ProxNode->new( $term1 ); $prox->addSecondTerm( $term2 ); $prox->addModifier( "relation", '>' ); $prox->addModifier( "distance", '2' ); isa_ok( $prox, 'CQL::ProxNode' ); is( $prox->toCQL(), '(foo) prox/distance>2 (bar)', 'prox toCQL()' ); CQL-Parser-1.13/t/prefix.t0000644000175000017500000000217112045741350014526 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use_ok( 'CQL::PrefixNode' ); use_ok( 'CQL::TermNode' ); use_ok( 'CQL::AndNode' ); my $subtree = CQL::AndNode->new( left => CQL::TermNode->new( term => 'foo' ), right => CQL::TermNode->new( term => 'bar' ) ); my $prefixNode = CQL::PrefixNode->new( name => 'dc', identifier => 'http://zthes.z3950.org/cql/1.0', subtree => $subtree ); isa_ok( $prefixNode, 'CQL::PrefixNode' ); my $prefix = $prefixNode->getPrefix(); isa_ok( $prefix, 'CQL::Prefix' ); is( $prefixNode->toCQL(), '>dc="http://zthes.z3950.org/cql/1.0" ((foo) and (bar))', 'toCQL()' ); my $xml = $prefixNode->toXCQL(); $xml =~ s/[\r\n]//g; $xml =~ s/> +/>/g; is( $xml, 'dchttp://zthes.z3950.org/cql/1.0andfoobar', 'toXCQL()' ); CQL-Parser-1.13/t/lucene.t0000644000175000017500000000362112045741350014505 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use Test::Exception; use_ok( 'CQL::Parser' ); my $parser = CQL::Parser->new(); my $node = $parser->parse( "origami" ); is( $node->toLucene(), 'origami', 'simple word search' ); $node = $parser->parse( "lexic*" ); is( $node->toLucene(), "lexic*", "right hand truncation" ); $node = $parser->parse( qq("library of congress") ); is( $node->toLucene(), qq("library of congress"), "phrase search" ); $node = $parser->parse( qq(librarians and "information scientists") ); is( $node->toLucene(), qq(librarians AND "information scientists"), 'boolean intersection' ); $node = $parser->parse( qq(origami or "paper folding") ); is( $node->toLucene(), qq(origami OR "paper folding"), 'boolean union' ); $node = $parser->parse( qq(Thanksgiving not Christmas) ); is( $node->toLucene(), qq(Thanksgiving NOT Christmas), 'boolean negation' ); $node = $parser->parse( qq(dc.creator="Thomas Jefferson") ); is( $node->toLucene(), qq(dc.creator:"Thomas Jefferson"), 'field searching' ); $node = $parser->parse( qq(("paper folding" or origami) and japanese) ); is( $node->toLucene(), qq(("paper folding" OR origami) AND japanese), 'nesting with parens' ); $node = $parser->parse(qq(author = /fuzzy tailor)); is( $node->toLucene(), qq(author:tailor~), 'relation modifier of fuzzy search'); $node = $parser->parse(qq(complete prox dinosaur)); is( $node->toLucene(), qq("complete dinosaur"~1), "proximity search"); #$node = $parser->parse(qq(ribs prox/>/5/paragraph chevrons)); $node = $parser->parse(qq(ribs prox/distance>=5/unit=paragraph chevrons)); is( $node->toLucene(), qq("ribs chevrons"~5), "proximity search, ignore unsupported parameters"); $node = $parser->parse( "title exact fish" ); throws_ok { $node->toLucene() } qr/Lucene doesn't support relations other than '='/, 'toLucene() fails on exact searches'; CQL-Parser-1.13/t/visitor.t0000644000175000017500000000154312045741350014732 0ustar bricasbricasuse strict; use warnings; use CQL::Parser; use CQL::Visitor; use Test::More tests=>2; # test the ability to visit term nodes and convert the dc # qualifiers my $parser = CQL::Parser->new(); my $node = $parser->parse( "(dc.title=foo or bar) and dc.creator=baz" ); is( $node->toCQL(), '((dc.title = foo) or (bar)) and (dc.creator = baz)', 'toCQL() prior to transformation' ); my $visitor = MyVisitor->new(); $visitor->visit($node); is( $node->toCQL(), '((title = foo) or (bar)) and (creator = baz)', 'visitor worked' ); ## test visitor class package MyVisitor; use base qw( CQL::Visitor ); sub term { my ($self,$node) = @_; # remove dc prefix from qualifier # bad OO, digging right into object # need set methods at some point if ( $node->{qualifier} ) { $node->{qualifier} =~ s/^dc\.//; } } 1; CQL-Parser-1.13/t/lexer.t0000644000175000017500000000676212045741350014362 0ustar bricasbricas#!/usr/bin/perl use strict; use warnings; use Test::More tests => 29; use CQL::Token; ## test the CQL Lexer use_ok( 'CQL::Lexer' ); ## test tokenizing my $lexer = CQL::Lexer->new(); isa_ok( $lexer, "CQL::Lexer" ); $lexer->tokenize( 'foo and bar' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], ['foo', 'and', 'bar' ], 'foo and bar' ); $lexer->tokenize( 'foo and bar and baz' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], ['foo', 'and', 'bar', 'and', 'baz' ], 'foo and bar and baz' ); $lexer->tokenize( 'foogetTokens() ) ], ['foo', '<', 'bar' ], 'footokenize( 'foo<=bar' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], ['foo','<=','bar'], 'foo<=bar' ); $lexer->tokenize( 'foo>bar' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], [ 'foo', '>', 'bar' ], 'foo>bar' ); $lexer->tokenize( 'foo>=bar' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], ['foo','>=','bar'], 'foo>=bar' ); $lexer->tokenize( 'foo=bar' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], ['foo', '=', 'bar' ], 'foo=bar' ); $lexer->tokenize( 'foo="bar bez"' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], ['foo', '=', 'bar bez' ], 'foo="bar bez"' ); $lexer->tokenize( '(foo<10) and (bar>bez)' ); is_deeply( [ getStrings( $lexer->getTokens() ) ], [ '(','foo','<','10',')','and','(','bar','>','bez',')' ], '(foo<10) and (bar>bez)' ); $lexer->tokenize( '(foo<10) and (bar>bez)' ); is_deeply( [ getTypes( $lexer->getTokens() ) ], [ CQL_LPAREN, CQL_WORD, CQL_LT, CQL_WORD, CQL_RPAREN, CQL_AND, CQL_LPAREN, CQL_WORD, CQL_GT, CQL_WORD, CQL_RPAREN ], 'token types for: (foo<10) and (bar>bez)' ); ## test iterator methods $lexer->tokenize( 'foo and bar' ); is( $lexer->nextToken()->getString(), 'foo', 'nextToken() foo' ); is( $lexer->nextToken()->getString(), 'and', 'nextToken() and' ); is( $lexer->nextToken()->getString(), 'bar', 'nextToken() bar' ); is( $lexer->nextToken()->getType(), CQL_EOF, 'nextToken() end of tokens' ); is( $lexer->nextToken()->getType(), CQL_EOF, 'nextToken() really the end!' ); is( $lexer->prevToken()->getString(), 'bar', 'prevToken() bar' ); is( $lexer->prevToken()->getString(), 'and', 'prevToken() and' ); is( $lexer->prevToken()->getString(), 'foo', 'prevToken() foo' ); is( $lexer->prevToken()->getType(),CQL_EOF,'prevToken() beginning of tokens()'); is( $lexer->prevToken()->getType(),CQL_EOF,'really is the beginning!' ); is( $lexer->nextToken()->getString(), 'foo', 'nextToken() starting over' ); $lexer->reset(); ## reset iterator is( $lexer->nextToken()->getString(), 'foo', 'nextToken() after reset()' ); ## modifiers $lexer->tokenize( "author = /fuzzy tailor" ); is_deeply( [ getTypes( $lexer->getTokens() ) ], [ CQL_WORD, CQL_EQ, CQL_MODIFIER, CQL_FUZZY, CQL_WORD ], 'token types for: author = /fuzzy tailor' ); ## make sure this works $lexer->tokenize('"http://www.yahoo.com"'); my @tokens = $lexer->getTokens(); is( @tokens, 1, 'got 1 token' ); is( $tokens[0]->getString(), 'http://www.yahoo.com', 'got quoted url' ); ## zero is a valid token $lexer->tokenize('0'); @tokens = $lexer->getTokens(); is( @tokens, 1, 'lexed one token' ); is( $tokens[0]->getString(), '0', 'able to lex 0' ); ## helper for returning a list of strings from a list of CQL::Token objects sub getStrings { return map { $_->getString() } @_; } sub getTypes { return map { $_->getType() } @_; } CQL-Parser-1.13/t/relation.t0000644000175000017500000000053312045741350015046 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use_ok( 'CQL::Relation' ); my $relation = CQL::Relation->new( 'exact' ); isa_ok( $relation, 'CQL::Relation' ); $relation->addModifier( 'stem' ); is( $relation->toCQL(), 'exact/stem', 'toCQL()' ); is_deeply( [ $relation->getModifiers() ], [ [ undef, 'stem' ] ], 'getModifiers()' ); CQL-Parser-1.13/t/token.t0000644000175000017500000000166012045741350014353 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); ## can't use_ok here since we need to export constants use CQL::Token; my $token = CQL::Token->new( 'foo' ); is( $token->getType(), CQL_WORD, 'getType()' ); is( $token->getString(), 'foo', 'getString()' ); $token = CQL::Token->new( '<' ); is( $token->getType(), CQL_LT, '<' ); $token = CQL::Token->new( '>' ); is( $token->getType(), CQL_GT, '>' ); $token = CQL::Token->new( '<>' ); is( $token->getType(), CQL_NE, '<>' ); $token = CQL::Token->new( '<=' ); is( $token->getType(), CQL_LE, '=' ); $token = CQL::Token->new( '"foo bar"' ); is( $token->getType(), CQL_WORD, '"foo bar" is a CQL_WORD' ); is( $token->getString(), 'foo bar', "surrounding quotes removed" ); $token = CQL::Token->new( 'word' ); is( $token->getType(), CQL_PWORD, 'reserved keyword no quotes' ); $token = CQL::Token->new( '"word"' ); is( $token->getType(), CQL_WORD, 'reserved word surrounded by quotes' ); CQL-Parser-1.13/t/swish.t0000644000175000017500000000255612045741350014375 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use Test::Exception; use_ok( 'CQL::Parser' ); my $parser = CQL::Parser->new(); my $node = $parser->parse( "origami" ); is( $node->toSwish(), 'origami', 'simple word search' ); $node = $parser->parse( "lexic*" ); is( $node->toSwish(), "lexic*", "right hand truncation" ); $node = $parser->parse( qq("library of congress") ); is( $node->toSwish(), qq("library of congress"), "phrase search" ); $node = $parser->parse( qq(librarians and "information scientists") ); is( $node->toSwish(), qq(librarians and "information scientists"), 'boolean intersection' ); $node = $parser->parse( qq(origami or "paper folding") ); is( $node->toSwish(), qq(origami or "paper folding"), 'boolean union' ); $node = $parser->parse( qq(Thanksgiving not Christmas) ); is( $node->toSwish(), qq(Thanksgiving not Christmas), 'boolean negation' ); $node = $parser->parse( qq(dc.creator="Thomas Jefferson") ); is( $node->toSwish(), qq(dc.creator = "Thomas Jefferson"), 'field searching' ); $node = $parser->parse( qq(("paper folding" or origami) and japanese) ); is( $node->toSwish(), qq(("paper folding" or origami) and japanese), 'nesting with parens' ); $node = $parser->parse( "title exact fish" ); throws_ok { $node->toSwish() } qr/Swish doesn't support relations other than = and not/, 'toSwish() fails on exact searches'; CQL-Parser-1.13/t/pod.t0000644000175000017500000000020312045741350014005 0ustar bricasbricasuse Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok();CQL-Parser-1.13/t/clone.t0000644000175000017500000000143112045741350014327 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use_ok( 'CQL::Parser' ); my $parser = CQL::Parser->new(); ## get a parse tree my $node = $parser->parse( 'foo and ( bar or baz )' ); ## make a clone from the root down my $clone = $node->clone(); is( $node->toCQL(), $clone->toCQL(), 'original and clone have same CQL' ); ## transform the copy and make sure original is still the same my $visitor = MyVisitor->new(); $visitor->visit($clone); is( $node->toCQL(), '(foo) and ((bar) or (baz))', 'original node unaltered' ); is( $clone->toCQL(), '(goo) and ((goo) or (goo))', 'clone altered' ); ## kind of bogus visitor that transforms all term nodes into ## 'goo' package MyVisitor; use base qw( CQL::Visitor ); sub term { my ($self,$term) = @_; $term->{term} = 'goo'; } 1; CQL-Parser-1.13/t/error.t0000644000175000017500000000101412045741350014355 0ustar bricasbricasuse strict; use warnings; use Test::More qw( no_plan ); use Test::Exception; use_ok( 'CQL::Parser' ); my $parser = CQL::Parser->new(); my %tests = ( 'foo and' => [ 27, qr/missing term/ ], 'foo !' => [ 19, qr/unknown first class relation/ ], ); ## TODO: should add more errors here foreach my $test (sort keys %tests) { my ($code,$regexp) = @{ $tests{$test} }; throws_ok { $parser->parse( $test ) } $regexp, $test; is $parser->parseSafe( $test ), $code, "code $code"; } CQL-Parser-1.13/t/parser.t0000644000175000017500000001426212045741350014531 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 67; use Test::Exception; use_ok( 'CQL::Parser' ); my $parser = CQL::Parser->new(); isa_ok( $parser, 'CQL::Parser' ); ## foo my $root = $parser->parse( 'foo' ); is( $root->toCQL(), 'foo', 'foo' ); isa_ok( $root, 'CQL::TermNode' ); ## "foo bar" $root = $parser->parse( '"foo bar"' ); is( $root->toCQL(), '"foo bar"', '"foo bar"' ); isa_ok( $root, 'CQL::TermNode' ); ## foo and bar $root = $parser->parse( 'foo and bar' ); is( $root->toCQL(), '(foo) and (bar)', 'foo and bar' ); isa_ok( $root, 'CQL::AndNode' ); ## foo bar throws_ok { $parser->parse('foo bar') } qr/unknown first class relation: bar/, 'foo bar : unknown first class relation bar'; ## (foo and bar) $root = $parser->parse('(foo or bar) and bez' ); is( $root->toCQL(), '((foo) or (bar)) and (bez)','(foo or bar) and bez' ); isa_ok( $root, 'CQL::AndNode' ); ## dc.title = foo $root = $parser->parse('dc.title = foo'); is( $root->toCQL(), 'dc.title = foo', 'dc.title = foo' ); isa_ok( $root, 'CQL::TermNode' ); ## dc.title=foo and dc.creator=bar $root = $parser->parse('dc.title=foo and dc.creator=bar' ); is( $root->toCQL(), '(dc.title = foo) and (dc.creator = bar)', 'dc.title=foo and dc.creator=bar' ); isa_ok( $root, 'CQL::AndNode' ); ## complete prox dinosaur $root = $parser->parse( 'complete prox dinosaur' ); is( $root->toCQL(), '(complete) prox (dinosaur)', 'complete prox dinosaur' ); isa_ok( $root, 'CQL::ProxNode' ); ## complete prox/<= dinosaur #$root = $parser->parse( 'complete prox/<= dinosaur' ); $root = $parser->parse( 'complete prox/distance<=1 dinosaur' ); is( $root->toCQL(), '(complete) prox/distance<=1 (dinosaur)', 'complete prox/<= dinosaur' ); isa_ok( $root, 'CQL::ProxNode' ); ## complete prox/bogus dinosaur throws_ok { $parser->parse( 'complete prox/bogus dinosaur') } qr/expected proximity parameter got bogus/, 'bad proximity parameter'; ## complete prox/<=/1 dinosaur $root = $parser->parse( 'complete prox/distance<=1 dinosaur'); is( $root->toCQL(), '(complete) prox/distance<=1 (dinosaur)', 'complete prox/<=/1 dinosaur' ); isa_ok( $root, 'CQL::ProxNode' ); ## complete prox/<=/bogus dinosaur throws_ok { $parser->parse( 'complete prox/distance<=bogus dinosaur') } qr/expected proximity distance got bogus/, 'bad proximity distance'; ## complete prox/<=/1/word dinosaur $root = $parser->parse( 'complete prox/distance<=1/unit=word dinosaur' ); is( $root->toCQL(), '(complete) prox/distance<=1/unit=word (dinosaur)', 'complete prox/<=/1 dinosaur/word' ); isa_ok( $root, 'CQL::ProxNode' ); ## complete prox/<=/1/bogus dinosaur throws_ok { $parser->parse( 'complete prox/distance<=bogus dinosaur') } qr/expected proximity distance got bogus/, 'bad proximity distance'; ## complete prox/<=/1/word/ordered dinosaur $root = $parser->parse( 'complete prox/distance<=1/unit=word/ordered dinosaur' ); is( $root->toCQL(), '(complete) prox/distance<=1/unit=word/ordered (dinosaur)', 'complete prox/<=/1 dinosaur/word/ordered' ); isa_ok( $root, 'CQL::ProxNode' ); ## complete prox/<=/1/word/bogus dinosaur throws_ok { $parser->parse( 'complete prox/distance<=1/unit=word/bogus dinosaur' ) } qr/expected proximity parameter got bogus/, 'expected proximity ordering got bogus'; ## some versions didn't handle <> $root = $parser->parse('dc.title <> app'); is( 'dc.title <> app', $root->toCQL(), '<> works' ); ## Foo oR bar $root = $parser->parse("Foo oR bar"); is( '(Foo) or (bar)', $root->toCQL(), 'keywords case insensitive' ); ## prefix $root = $parser->parse( '>dc="http://zthes.z3950.org/cql/1.0" foo and bar' ); isa_ok( $root, 'CQL::PrefixNode' ); is( $root->toCQL(), '>dc="http://zthes.z3950.org/cql/1.0" ((foo) and (bar))', 'toCQL()' ); ## oR, though a case insensitive keyword is also a valid search term ## and should preserve its case if it is a search term $root = $parser->parse( 'Or oR OR' ); is( $root->toCQL(), '(Or) or (OR)', 'preserve case for keywords in term' ); ## relation modifiers sub testModifier { my ($query, $modifier) = @_; $root = $parser->parse( $query ); isa_ok( $root, 'CQL::TermNode' ); my @modifiers = $root->getRelation()->getModifiers(); is($modifiers[0][1], $modifier, "relation modifier $modifier"); is( $root->toCQL(), $query, $query ); } testModifier('dc.title =/word "two words"', 'word'); testModifier('dc.title =/string "one string"', 'string'); testModifier('dc.date >=/isoDate 2006', 'isoDate'); testModifier('uba.price <=/number 1000', 'number'); testModifier('dc.ident =/uri "http://foo.bar"', 'uri'); testModifier('dc.title =/masked foo*', 'masked'); testModifier('dc.tilte =/unmasked foo*', 'unmasked'); ## Escaped double quote $root = $parser->parse( '"\""' ); isa_ok( $root, 'CQL::TermNode' ); is( $root->getTerm(), '"', 'double quote term'); is( $root->toCQL(), '"\""', 'toCQL() escaped double quote'); my $xcql = $root->toXCQL(0); ok( $xcql =~ /"<\/term>/g, 'toXCQL() should give only one bare " in term element'); ## Fix for syntax highlighting Epic Perl plugin for Eclipse: ' ## Preserve all other escapes and don't escape a double escaped double quote $root = $parser->parse( '"\n \\\\"' ); is( $root->toCQL(), '"\n \\\\"', 'Preserve all escapes'); ## triple escape in double quotes $root = $parser->parse( '"\\\\\\""' ); is( $root->toCQL(), '"\\\\\\""', 'triple escaped double quote in double quotes'); ## escape without double quotes $root = $parser->parse( 'without\quotes' ); is( $root->toCQL(), 'without\quotes', 'escape without double quotes'); ## new relations $root = $parser->parse('dc.date within/cql.isoDate "2004-04-06 2004-04-23"'); is('dc.date within/cql.isoDate "2004-04-06 2004-04-23"', $root->toCQL(), 'within'); $root = $parser->parse('xxx.dateRange encloses 2002'); is('xxx.dateRange encloses 2002', $root->toCQL(), 'encloses'); $root = $parser->parse('gils.bounds within/partial/nwse "36.5 -106.7 25.8 -93.5"'); is('gils.bounds within/partial/nwse "36.5 -106.7 25.8 -93.5"', $root->toCQL(), 'nwse'); $root = $parser->parse('gils.begdate <= /isoDate "20051201,20051231"'); is('gils.begdate <=/isoDate 20051201,20051231', $root->toCQL(), 'isoDate'); ## zero is a valid term $root = $parser->parse('dc.title=0'); is('dc.title = 0', $root->toCQL(), 'zero is a valid term'); CQL-Parser-1.13/t/whitespace.t0000644000175000017500000000042712045741350015367 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 1; use CQL::Parser; eval { my $parser = CQL::Parser->new(); my $node = $parser->parse( "title=dinosaur\n" ); }; if ( $@ ) { fail( "didn't ignore trailing whitespace" ); } else { pass( "ignored trailing whitespace" ); } CQL-Parser-1.13/MANIFEST0000644000175000017500000000142312222667746013746 0ustar bricasbricasChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/CQL/AndNode.pm lib/CQL/BooleanNode.pm lib/CQL/Lexer.pm lib/CQL/ModifierSet.pm lib/CQL/Node.pm lib/CQL/NotNode.pm lib/CQL/OrNode.pm lib/CQL/Parser.pm lib/CQL/Prefix.pm lib/CQL/PrefixNode.pm lib/CQL/ProxModifierSet.pm lib/CQL/ProxNode.pm lib/CQL/Relation.pm lib/CQL/TermNode.pm lib/CQL/Token.pm lib/CQL/Utils.pm lib/CQL/Visitor.pm Makefile.PL MANIFEST This list of files META.yml README t/boolean.t t/changes.t t/clone.t t/error.t t/lexer.t t/lucene.t t/parser.t t/pod.t t/prefix.t t/relation.t t/swish.t t/term.t t/token.t t/visitor.t t/whitespace.t CQL-Parser-1.13/lib/0000755000175000017500000000000012222667773013363 5ustar bricasbricasCQL-Parser-1.13/lib/CQL/0000755000175000017500000000000012222667773014002 5ustar bricasbricasCQL-Parser-1.13/lib/CQL/ProxNode.pm0000644000175000017500000000277312045741350016072 0ustar bricasbricaspackage CQL::ProxNode; use strict; use warnings; use base qw( CQL::BooleanNode ); use CQL::ProxModifierSet; =head1 NAME CQL::ProxNode - represents a PROX node in a CQL parse tree =head1 SYNOPSIS use CQL::ProxNode; my $node = CQL::ProxNode->new( left => $left ); $node->addSecondTerm( $right ); =head1 DESCRIPTION =head1 METHODS =head1 new() Creates a new, incomplete, proximity node with the specified left-hand side. No right-hand side is specified at this stage: that must be specified later, using the addSecondSubterm() method. (That may seem odd, but it's just easier to write the parser that way.) Proximity paramaters may be added at any time, before or after the right-hand-side sub-tree is added. my $prox = CQL::ProxNode->new( $term ); =cut sub new { my ($class,$left) = @_; my $self = $class->SUPER::new( left => $left, right => undef ); $self->{modifierSet} = CQL::ProxModifierSet->new( 'prox' ); return $self; } =head2 addSecondTerm() =cut sub addSecondTerm { my ($self,$term) = @_; $self->{right} = $term; } =head2 addModifier() =cut sub addModifier { my ($self,$type,$value) = @_; $self->{modifierSet}->addModifier( $type, $value ); } =head2 getModifiers() =cut sub getModifiers { return shift->{modifierSet}->getModifiers(); } =head2 op() =cut sub op { return shift->{modifierSet}->toCQL(); } =head2 opXCQL() =cut sub opXCQL { my ($self,$level) = @_; return $self->{modifierSet}->toXCQL( $level, 'boolean' ); } 1; CQL-Parser-1.13/lib/CQL/Visitor.pm0000644000175000017500000000322112045741350015760 0ustar bricasbricaspackage CQL::Visitor; use strict; use warnings; =head1 NAME CQL::Visitor - visit nodes in a CQL parse tree =head1 SYNOPSIS package MyVisitor; use base qw( CQL::Visitor ); sub term { my ($self,$node) = @_; # do something to the node } # later on my $parser = CQL::Parser->new(); my $root = $parser->parse($cql); my $visitor = MyVisitor->new(); $vistor->visit($root); =head1 DESCRIPTION CQL::Visitor provides a simple interface for visiting nodes in your parse tree. It could be useful if you want to do something like change a query like this: dc.title=foo and dc.creator=bar into title=foo and creator=bar Or some similar procedure. You simply create a new subclass of CQL::Visitor and override the appropriate method, such as term(). Every term that is encountered during the traversal will be handed off to your term() method. Note: at the moment only term() is supported because that's what was needed, but if you need other ones feel free to add them, or ask for them. =head1 METHODS =head2 new() =cut sub new { my $class = shift; return bless {}, ref($class) || $class; } =head2 visit() Call this to traverse your parse tree, starting at the root. =cut sub visit { my ($self,$node) = @_; if ( $node->isa( 'CQL::BooleanNode' ) ) { $self->visit( $node->left() ); $self->visit( $node->right() ); } elsif ( $node->isa( 'CQL::TermNode' ) ) { $self->term( $node ); } } =head2 term() Your subclass should override this, and do something meaningful with the CQL::TermNode object. =cut sub term { # subclasses should subclass } 1; CQL-Parser-1.13/lib/CQL/Relation.pm0000644000175000017500000000346312045741350016106 0ustar bricasbricaspackage CQL::Relation; use strict; use warnings; use Class::Accessor; use CQL::ModifierSet; use base qw( CQL::Node ); =head1 NAME CQL::Relation - object for CQL Relations =head1 SYNOPSIS =head1 DESCRIPTION CQL::Relation represents the common CQL relation operations ( =, E, E, any, all and exact. In addition modifiers may be applied (stem, relevant, fuzzy, phonetic). The operators are passed into the constructor as the base relation. =head1 METHODS =head2 new() Creates a new CQL::Relation object with the specified base relation. =cut sub new { my ($class,$base) = @_; my $ms = CQL::ModifierSet->new( $base ); return bless { modifierSet => $ms }, ref($class) || $class; } =head2 getBase() Returns the base relation with which the CQL::Relation object was originally created. =cut sub getBase { return shift->{modifierSet}->getBase(); } =head2 addModifier() Adds a new relation modifier to the specified CQLRelation. Typical relation modifiers include relevant, fuzzy stem and phonetic. On the whole, these modifiers have a meaningful interpretation only for the text relations. =cut sub addModifier { my ($self,$modifier) = @_; $self->{modifierSet}->addModifier( undef, $modifier ); } =head2 getModifiers() Returns a list of modifiers associated with a CQL relation. =cut sub getModifiers { return shift->{modifierSet}->getModifiers(); } =head2 toCQL() =cut sub toCQL { return shift->{modifierSet}->toCQL(); } =head2 toSwish() =cut sub toSwish { return shift->{modifierSet}->toSwish(); } =head2 toXCQL() =cut sub toXCQL { my ($self,$level) = @_; my $xml = $self->{modifierSet}->toXCQL( $level, "relation" ); return $self->addNamespace( $level, $xml ); } =head2 toLucene() =cut sub toLucene { return shift->{modifierSet}->toLucene(); } 1; CQL-Parser-1.13/lib/CQL/Prefix.pm0000644000175000017500000000233712045741350015565 0ustar bricasbricaspackage CQL::Prefix; use strict; use warnings; use Carp qw( croak ); =head1 NAME CQL::Prefix - represents a CQL prefix mapping =head1 SYNOPSIS use CQL::Prefix; =head1 DESCRIPTION Represents a CQL prefix mapping from short name to long identifier. =head1 METHODS =head2 new() You need to pass in the name and identifier parameters. The name is the short name of the prefix mapping. That is, the prefix itself, such as dc, as it might be used in a qualifier like dc.title. The identifier is the name of the prefix mapping. That is, typically, a URI permanently allocated to a specific qualifier set, such as http://zthes.z3950.org/cql/1.0. my $prefix = CQL::Prefix->new( name => 'dc', identifier => 'http://zthes.z3950.org/cql/1.0' ); =cut sub new { my ($class,%opts) = @_; croak( 'must supply name' ) if ! exists $opts{name}; croak( 'must supply identifier' ) if ! exists $opts{identifier}; my $self = { name => $opts{name}, identifier => $opts{identifier} }; return bless $self, ref($class) || $class; } =head2 getName() =cut sub getName { return shift->{name}; } =head2 getIdentifier() =cut sub getIdentifier { return shift->{identifier}; } 1; CQL-Parser-1.13/lib/CQL/PrefixNode.pm0000644000175000017500000000330112045741350016363 0ustar bricasbricaspackage CQL::PrefixNode; use strict; use warnings; use base qw( CQL::Node ); use CQL::Prefix; use Carp qw( croak ); =head1 NAME CQL::PrefixNode - represents a prefix node in a CQL parse tree =head1 SYNOPSIS use CQL::PrefixNode; my $prefix = CQL::PrefixNode->new( name => '', identifier => '', subtree => $node ); =head1 DESCRIPTION =head1 METHODS =head2 new() Creates a new CQL::PrefixNode inducing a mapping from the specified qualifier-set name to the specified identifier across the specified subtree. =cut sub new { my ($class,%opts) = @_; croak( 'must supply name' ) if ! exists $opts{name}; croak( 'must supply identifier' ) if ! exists $opts{identifier}; croak( 'must supply subtree' ) if ! exists $opts{subtree}; my $prefix = CQL::Prefix->new( name => $opts{name}, identifier => $opts{identifier} ); my $self = { prefix => $prefix, subtree => $opts{subtree} }; return bless $self, ref($class) || $class; } =head2 getPrefix() =cut sub getPrefix { return shift->{prefix}; } =head2 getSubtree() =cut sub getSubtree { return shift->{subtree}; } =head2 toCQL() =cut sub toCQL { my $self = shift; my $prefix = $self->getPrefix(); my $subtree = $self->getSubtree(); return ">" . $prefix->getName() . '="' . $prefix->getIdentifier() . '" ' . '(' . $subtree->toCQL() . ')'; } =head2 toXCQL() =cut sub toXCQL { my ($self,$level,@prefixes) = @_; $level = 0 if ! $level; push( @prefixes, $self->getPrefix() ); my $xml = $self->getSubtree()->toXCQL( $level, @prefixes ); return $self->addNamespace( $level, $xml ); } 1; CQL-Parser-1.13/lib/CQL/Lexer.pm0000644000175000017500000001503512045741350015406 0ustar bricasbricaspackage CQL::Lexer; use strict; use warnings; use Carp qw( croak ); use String::Tokenizer; use CQL::Token; =head1 NAME CQL::Lexer - a lexical analyzer for CQL =head1 SYNOPSIS my $lexer = CQL::Lexer->new(); $lexer->tokenize( 'foo and bar' ); my @tokens = $lexer->getTokens(); =head1 DESCRIPTION CQL::Lexer is lexical analyzer for a string of CQL. Once you've got a CQL::Lexer object you can tokenize a CQL string into CQL::Token objects. Ordinarily you'll never want to do this yourself since CQL::Parser calls CQL::Lexer for you. CQL::Lexer uses Stevan Little's lovely String::Tokenizer in the background, and does a bit of analysis afterwards to handle some peculiarities of CQL: double quoted strings, <, <=, etc. =head1 METHODS =head2 new() The constructor. =cut sub new { my $class = shift; my $self = { tokenizer => String::Tokenizer->new(), tokens => [], position => 0, }; return bless $self, ref($class) || $class; } =head2 tokenize() Pass in a string of CQL to tokenize. This initializes the lexer with data so that you can retrieve tokens. =cut sub tokenize { my ( $self, $string ) = @_; ## extract the String::Tokenizer object we will use my $tokenizer = $self->{tokenizer}; ## reset position parsing a new string of tokens $self->reset(); ## delegate to String::Tokenizer for basic tokenization debug( "tokenizing: $string" ); $tokenizer->tokenize( $string, '\/<>=()"', String::Tokenizer->RETAIN_WHITESPACE ); ## do a bit of lexical analysis on the results of basic debug( "lexical analysis on tokens" ); my @tokens = _analyze( $tokenizer ); $self->{tokens} = \@tokens; } =head2 getTokens() Returns a list of all the tokens. =cut sub getTokens { my $self = shift; return @{ $self->{tokens} }; } =head2 token() Returns the current token. =cut sub token { my $self = shift; return $self->{tokens}[ $self->{position} ]; } =head2 nextToken() Returns the next token, or undef if there are more tokens to retrieve from the lexer. =cut sub nextToken { my $self = shift; ## if we haven't gone over the end of our token list ## return the token at our current position while ## incrementing the position. if ( $self->{position} < @{ $self->{tokens} } ) { my $token = $self->{tokens}[ $self->{position}++ ]; return $token; } return CQL::Token->new( '' ); } =head2 prevToken() Returns the previous token, or undef if there are no tokens prior to the current token. =cut sub prevToken { my $self = shift; ## if we're not at the start of our list of tokens ## return the one previous to our current position ## while decrementing our position. if ( $self->{position} > 0 ) { my $token = $self->{tokens}[ --$self->{position} ]; return $token; } return CQL::Token->new( '' ); } =head2 reset() Resets the iterator to start reading tokens from the beginning. =cut sub reset { shift->{position} = 0; } ## Private sub used by _analyze for collecting a backslash escaped string terminated by " sub _getString { my $iterator = shift; my $string = '"'; my $escaping = 0; # loop through the tokens untill an unescaped " found while ($iterator->hasNextToken()) { my $token = $iterator->nextToken(); $string .= $token; if ($escaping) { $escaping = 0; } elsif ($token eq '"') { return $string; } elsif ($token eq "\\") { $escaping = 1; } } croak( 'unterminated string ' . $string); } ## Private sub used by _analyze to process \ outside double quotes. ## Because we tokenized on \ any \ outside double quotes (inside is handled by _getString) ## might need to be concatenated with a previous and or next CQL_WORD to form one CQL_WORD token sub _concatBackslash { my $tokensRef = shift; my $i = 0; while ($i < @$tokensRef) { my $token = $$tokensRef[$i]; if ($token->getString() eq "\\") { my $s = "\\"; my $replace = 0; if ($i > 0) { my $prevToken = $$tokensRef[$i - 1]; if (($prevToken->getType() == CQL_WORD) and !$prevToken->{terminated}) { # concatenate and delete the previous CQL_WORD token $s = $prevToken->getString() . $s; $i--; splice @$tokensRef, $i, 1; $replace = 1; } } if (!$token->{terminated} and ($i < $#$tokensRef)) { my $nextToken = $$tokensRef[$i + 1]; if ($nextToken->getType() == CQL_WORD) { # concatenate and delete the next CQL_WORD token $s .= $nextToken->getString(); splice @$tokensRef, $i + 1, 1; $replace = 1; } } if ($replace) { $$tokensRef[$i] = CQL::Token->new($s); } } $i++; } } sub _analyze { my $tokenizer = shift; my $iterator = $tokenizer->iterator(); my @tokens; while ( defined (my $token = $iterator->nextToken()) ) { ## <= if ( $token eq '<' and $iterator->lookAheadToken() eq '=' ) { push( @tokens, CQL::Token->new( '<=' ) ); $iterator->nextToken(); } ## <> elsif ( $token eq '<' and $iterator->lookAheadToken() eq '>' ) { push( @tokens, CQL::Token->new( '<>') ); $iterator->nextToken(); } ## >= elsif ( $token eq '>' and $iterator->lookAheadToken() eq '=' ) { push( @tokens, CQL::Token->new( '>=' ) ); $iterator->nextToken(); } ## "quoted strings" elsif ( $token eq '"' ) { my $cqlToken = CQL::Token->new( _getString($iterator) ); ## Mark this and the previous token as terminated to prevent concatenation with backslash $cqlToken->{terminated} = 1; if (@tokens) { $tokens[$#tokens]->{terminated} = 1; } push( @tokens, $cqlToken ); } ## if it's just whitespace we can zap it elsif ( $token =~ /\s+/ ) { ## Mark the previous token as terminated to prevent concatenation with backslash if (@tokens) { $tokens[$#tokens]->{terminated} = 1; } } ## otherwise it's fine the way it is else { push( @tokens, CQL::Token->new($token) ); } } # while ## Concatenate \ outside double quotes with a previous and or next CQL_WORD to form one CQL_WORD token _concatBackslash(\@tokens); return @tokens; } sub debug { return unless $CQL::DEBUG; print STDERR 'CQL::Lexer: ', shift, "\n"; } 1; CQL-Parser-1.13/lib/CQL/ProxModifierSet.pm0000644000175000017500000000153712045741350017414 0ustar bricasbricaspackage CQL::ProxModifierSet; use strict; use warnings; use base qw( CQL::ModifierSet ); use CQL::Utils qw( indent xq ); use Carp qw( croak ); use CQL::ModifierSet; =head1 NAME CQL::ProxModifierSet - represents a base string and modifier strings =head1 SYNOPSIS =head1 DESCRIPTION This class is used as a delegate by CQLProxNode based on ModifierSet data structure. =head1 METHODS =head2 toCQL() =cut sub toCQL { my $self = shift; my $cql = $self->{base}; my $distance = $self->modifier("distance"); my $relation = $self->modifier("relation"); my $unit = $self->modifier("unit"); my $ordering = $self->modifier("ordering"); $cql .= "/distance$relation$distance" if defined $distance and defined $relation; $cql .= "/unit=$unit" if defined $unit; $cql .= "/$ordering" if defined $ordering; return $cql; } 1; CQL-Parser-1.13/lib/CQL/OrNode.pm0000644000175000017500000000062212045741350015511 0ustar bricasbricaspackage CQL::OrNode; use strict; use warnings; use base qw( CQL::BooleanNode ); =head1 NAME CQL::OrNode - represents an OR node in a CQL parse tree =head1 SYNOPSIS use CQL::OrNode; my $node = CQL::OrNode->new( left => $left, right => $right ); =head1 DESCRIPTION CQL::OrNode inherits from CQL::BooleanNode, where you'll find most of the functionality. =cut sub op { return 'or'; } 1; CQL-Parser-1.13/lib/CQL/Node.pm0000644000175000017500000000264112045741350015213 0ustar bricasbricaspackage CQL::Node; use strict; use warnings; use base qw( Clone ); use Carp qw( croak ); =head1 NAME CQL::Node - base class for nodes in a CQL parse tree =head1 SYNOPSIS n/a =head1 DESCRIPTION All the CQL node classes inherit from CQL::Node. CQL::Node essentially gurantees that its children implements some methods. =head2 toCQL() =cut sub toCQL { my $self = shift; ## poor mans interface croak( ref($self) . " forgot to implement toCQL()!!!" ); } =head2 toXCQL() =cut sub toXCQL { my $self = shift; croak( ref($self) . " forgot to implement toXCQL()!!!" ); } =head2 toSwish() =cut sub toSwish { my $self = shift; ## poor mans interface croak( ref($self) . " forgot to implement toSwish()!!!" ); } =head2 toLucene() =cut sub toLucene { my $self = shift; croak( ref($self) . " forgot to implement toLucene()!!!" ); } =head2 clone() Creates a copy of a node, and it's children. Useful if you want to modify the tree but keep a copy of the original. =cut # internal method for adding namespace information to top level # elements in XCQL generated by children. sub addNamespace { my ($self,$level,$xml) = @_; # only add namespace to top level element return $xml if $level != 0; # kind of hackish way of adding namespace to the first # open tag we see $xml =~ s{^<([^ ]*?)>}{<$1 xmlns="http://www.loc.gov/zing/cql/xcql/">}; return $xml; } 1; CQL-Parser-1.13/lib/CQL/NotNode.pm0000644000175000017500000000063012045741350015670 0ustar bricasbricaspackage CQL::NotNode; use strict; use warnings; use base qw( CQL::BooleanNode ); =head1 NAME CQL::NotNode - represents a NOT node in a CQL parse tree =head1 SYNOPSIS use CQL::NotNode; my $node = CQL::NotNode->new( left => $left, right => $right ); =head1 DESCRIPTION CQL::NotNode inherits from CQL::BooleanNode, where you'll find most of the functionality. =cut sub op { return 'not'; } 1; CQL-Parser-1.13/lib/CQL/TermNode.pm0000644000175000017500000000672012045741350016045 0ustar bricasbricaspackage CQL::TermNode; use strict; use warnings; use base qw( CQL::Node ); use Carp qw( croak ); use CQL::Utils qw( indent xq renderPrefixes ); =head1 NAME CQL::TermNode - represents a terminal Node in a CQL Parse Tree =head1 SYNOPSIS =head1 DESCRIPTION CQL::TermNode represents a terminal in a CQL parse tree. A term node consists of the string itself with optional qualifier string and relation. Examples could include: =over 4 =item * george =item * dc.creator=george =back =head1 METHODS =head2 new() The constructor which has must have at least a term attribute, and can also include optional qualifier and modifier terms. =cut sub new { my ($class,%args) = @_; croak( "must supply term parameter" ) if ! exists( $args{term} ); return bless \%args, ref($class) || $class; } =head2 getQualifier() Get the qualifier in the terminal. =cut sub getQualifier { return shift->{qualifier}; } =head2 getRelation() Get the relation in the terminal. =cut sub getRelation { return shift->{relation}; } =head2 getTerm() Get the actual term string in the terminal. =cut sub getTerm { return shift->{term}; } =head2 toCQL() Returns a CQL representation of the terminal node. =cut sub toCQL { my $self = shift; my $qualifier = maybeQuote( $self->getQualifier() ); my $term = maybeQuote( $self->getTerm() ); my $relation = $self->getRelation(); my $cql; if ( $qualifier and $qualifier !~ /srw\.serverChoice/i ) { $cql = join( ' ', $qualifier, $relation->toCQL(), $term); } else { $cql = $term; } return $cql; } =head2 toSwish() =cut sub toSwish { my $self = shift; my $qualifier = maybeQuote( $self->getQualifier() ); my $term = maybeQuote( $self->getTerm() ); my $relation = $self->getRelation(); my $swish; if ( $qualifier and $qualifier !~ /srw\.serverChoice/i ) { $swish = join( ' ', $qualifier, $relation->toSwish(), $term ); } else { $swish = $term; } return $swish; } =head2 toXCQL() =cut sub toXCQL { my ($self,$level,@prefixes) = @_; $level = 0 unless $level; my $xml = indent($level) . "\n" . renderPrefixes($level+1,@prefixes) . indent($level+1) . "".xq($self->getQualifier())."\n"; if ( $self->getRelation() ) { $xml .= $self->getRelation()->toXCQL($level+1); } $xml .= indent($level+1) . "" . xq($self->getTerm()) . "\n" . indent($level) . "\n"; return $self->addNamespace( $level, $xml ); } =head2 toLucene() =cut sub toLucene { my $self = shift; my $qualifier = maybeQuote( $self->getQualifier() ); my $term = maybeQuote( $self->getTerm() ); my $relation = $self->getRelation(); my $query; if ( $qualifier and $qualifier !~ /srw\.serverChoice/i ) { my $base = $relation->getBase(); my @modifiers = $relation->getModifiers(); foreach my $m ( @modifiers ) { if( $m->[ 1 ] eq 'fuzzy' ) { $term = "$term~"; } } if( $base eq '=' ) { $base = ':'; } else { croak( "Lucene doesn't support relations other than '='" ); } return "$qualifier$base$term"; } else { return $term; } } sub maybeQuote { my $str = shift; return if ! defined $str; if ( $str =~ m|[" \t=<>/()]| ) { $str =~ s/"/\\"/g; $str = qq("$str"); } return $str; } 1; CQL-Parser-1.13/lib/CQL/AndNode.pm0000644000175000017500000000063312045741350015635 0ustar bricasbricaspackage CQL::AndNode; use strict; use warnings; use base qw( CQL::BooleanNode ); =head1 NAME CQL::AndNode - represents an AND node in a CQL parse tree =head1 SYNOPSIS use CQL::AndNode; my $node = CQL::AndNode->new( left => $left, right => $right ); =head1 DESCRIPTION CQL::AndNode inherits from CQL::BooleanNode, where you will find most of the functionality. =cut sub op { return 'and'; } 1; CQL-Parser-1.13/lib/CQL/ModifierSet.pm0000644000175000017500000000545412045741350016545 0ustar bricasbricaspackage CQL::ModifierSet; use strict; use warnings; use CQL::Utils qw( indent xq ); use Carp qw( croak ); =head1 NAME CQL::ModifierSet - represents a base string and modifier strings =head1 SYNOPSIS =head1 DESCRIPTION This class is used as a delegate by both CQLRelation and CQLProxNode - two functionally very separate classes that happen to require similar data structures and functionality. A ModifierSet consists of a ``base'' string together with a set of zero or more type=value pairs, where both type and value are strings. Types may be null, values may not. =head1 METHODS =head2 new() Creates a new modifier set with the specified base. =cut sub new { my ($class,$base) = @_; my $self = { base => $base, modifiers => [] }; return bless $self, ref($class) || $class; } =head2 getBase() Returns the base string with which the modifier set was created. =cut sub getBase { return shift->{base}; } =head2 addModifier() Adds a modifier of the specified type and value to a modifier set. =cut sub addModifier { my ($self,$type,$value) = @_; push( @{ $self->{modifiers} }, [ $type => $value ] ); } =head2 modifier() Returns a modifier with a given type, or null if a modifier of that type isn't present. =cut sub modifier { my ($self,$type) = @_; foreach my $pair ( @{ $self->{modifiers} } ) { if ( $pair->[0] eq $type ) { return $pair->[1]; } } return undef; } =head2 getModifiers() Returns a list of modifiers each represented by a 2 element array ref. =cut sub getModifiers { my $self = shift; return @{ $self->{modifiers} }; } =head2 toCQL() =cut sub toCQL { my $self = shift; my $cql = $self->{base}; foreach ( @{ $self->{modifiers} } ) { $cql .= "/" . $_->[1]; } return $cql; } =head2 toSwish() =cut sub toSwish { my $self = shift; croak( "Swish does not support relational modifiers" ) if @{ $self->{modifiers} } > 0; my $base = $self->getBase(); return $base if $base eq "=" or $base eq "not"; croak( "Swish doesn't support relations other than = and not" ); } =head2 toXCQL() =cut sub toXCQL { my ($self, $level, $topLevelElement) = @_; my $buffer = indent($level).'<'.$topLevelElement.">\n". indent($level+1)."".xq($self->{base})."\n"; my @modifiers = $self->getModifiers(); if ( @modifiers > 0 ) { $buffer .= indent($level+1)."\n"; foreach my $m ( @modifiers ) { $buffer .= indent($level+2).""; $buffer .= "".xq($m->[0])."" if $m->[0]; $buffer .= "".xq($m->[1])."\n" } $buffer .= indent($level+1)."\n"; } $buffer .= indent($level).'\n"; return $buffer; } 1; CQL-Parser-1.13/lib/CQL/Token.pm0000644000175000017500000001412612045741350015407 0ustar bricasbricaspackage CQL::Token; use strict; use warnings; use base qw( Exporter ); =head1 NAME CQL::Token - class for token objects returned by CQL::Lexer =head1 SYNOPSIS my $token = $lexer->nextToken(); if ( $token->type() == CQL_WORD ) { print "the token is a word with value=", $token->string(), "\n"; } =head1 DESCRIPTION Ordinarily you won't really care about the tokens returned by the CQL::Lexer since the lexer is used behind the scenes by CQL::Parser. =head1 METHODS =head2 new() my $token = CQL::Token->new( '=' ); =cut ## CQL keyword types use constant CQL_LT => 100; ## The "<" relation use constant CQL_GT => 101; ## The ">" relation use constant CQL_EQ => 102; ## The "=" relation use constant CQL_LE => 103; ## The "<=" relation use constant CQL_GE => 104; ## The ">=" relation use constant CQL_NE => 105; ## The "<>" relation use constant CQL_AND => 106; ## The "and" boolean use constant CQL_OR => 107; ## The "or" boolean use constant CQL_NOT => 108; ## The "not" boolean use constant CQL_PROX => 109; ## The "prox" boolean use constant CQL_ANY => 110; ## The "any" relation use constant CQL_ALL => 111; ## The "all" relation use constant CQL_EXACT => 112; ## The "exact" relation use constant CQL_WITHIN => 113; ## The "within" relation use constant CQL_ENCLOSES => 114; ## The "encloses" relation use constant CQL_PARTIAL => 115; ## The "partial" relation use constant CQL_PWORD => 116; ## The "word" proximity unit and the "word" relation modifier use constant CQL_SENTENCE => 117; ## The "sentence" proximity unit use constant CQL_PARAGRAPH => 118; ## The "paragraph" proximity unit use constant CQL_ELEMENT => 119; ## The "element" proximity unit use constant CQL_ORDERED => 120; ## The "ordered" proximity ordering use constant CQL_UNORDERED => 121; ## The "unordered" proximity ordering use constant CQL_RELEVANT => 122; ## The "relevant" relation modifier use constant CQL_FUZZY => 123; ## The "fuzzy" relation modifier use constant CQL_STEM => 124; ## The "stem" relation modifier use constant CQL_SCR => 125; ## The server choice relation use constant CQL_PHONETIC => 126; ## The "phonetic" relation modifier use constant CQL_WORD => 127; ## A general word (not an operator) use constant CQL_LPAREN => 128; ## A left paren use constant CQL_RPAREN => 129; ## A right paren use constant CQL_EOF => 130; ## End of query use constant CQL_MODIFIER => 131; ## Start of modifier '/' use constant CQL_STRING => 132; ## The "string" relation modifier use constant CQL_ISODATE => 133; ## The "isoDate" relation modifier use constant CQL_NUMBER => 134; ## The "number" relation modifier use constant CQL_URI => 135; ## The "uri" relation modifier use constant CQL_MASKED => 137; ## The "masked" relation modifier use constant CQL_UNMASKED => 138; ## The "unmasked" relation modifier use constant CQL_NWSE => 139; ## The "nwse" relation modifier use constant CQL_DISTANCE => 140; ## The "distance" proximity modifier use constant CQL_UNIT => 141; ## The "unit" proximity modifier ## lookup table for easily determining token type our %lookupTable = ( '<' => CQL_LT, '>' => CQL_GT, '=' => CQL_EQ, '<=' => CQL_LE, '>=' => CQL_GE, '<>' => CQL_NE, 'and' => CQL_AND, 'or' => CQL_OR, 'not' => CQL_NOT, 'prox' => CQL_PROX, 'any' => CQL_ANY, 'within' => CQL_WITHIN, 'encloses' => CQL_ENCLOSES, 'partial' => CQL_PARTIAL, 'all' => CQL_ALL, 'exact' => CQL_EXACT, 'word' => CQL_PWORD, 'sentence' => CQL_SENTENCE, 'paragraph' => CQL_PARAGRAPH, 'element' => CQL_ELEMENT, 'ordered' => CQL_ORDERED, 'unordered' => CQL_UNORDERED, 'relevant' => CQL_RELEVANT, 'fuzzy' => CQL_FUZZY, 'stem' => CQL_STEM, 'phonetic' => CQL_PHONETIC, '(' => CQL_LPAREN, ')' => CQL_RPAREN, '/' => CQL_MODIFIER, '' => CQL_EOF, 'string' => CQL_STRING, 'isodate' => CQL_ISODATE, 'number' => CQL_NUMBER, 'uri' => CQL_URI, 'masked' => CQL_MASKED, 'unmasked' => CQL_UNMASKED, 'nwse' => CQL_NWSE, 'distance' => CQL_DISTANCE, 'unit' => CQL_UNIT, ); ## constants available for folks to use when looking at ## token types our @EXPORT = qw( CQL_LT CQL_GT CQL_EQ CQL_LE CQL_GE CQL_NE CQL_AND CQL_OR CQL_NOT CQL_PROX CQL_ANY CQL_ALL CQL_EXACT CQL_PWORD CQL_SENTENCE CQL_PARAGRAPH CQL_ELEMENT CQL_ORDERED CQL_UNORDERED CQL_RELEVANT CQL_FUZZY CQL_STEM CQL_SCR CQL_PHONETIC CQL_RPAREN CQL_LPAREN CQL_WORD CQL_PHRASE CQL_EOF CQL_MODIFIER CQL_STRING CQL_ISODATE CQL_NUMBER CQL_URI CQL_MASKED CQL_UNMASKED CQL_WITHIN CQL_PARTIAL CQL_ENCLOSES CQL_NWSE CQL_DISTANCE CQL_UNIT ); =head2 new() =cut sub new { my ($class,$string) = @_; my $type; # see if it's a reserved word, which are case insensitive my $normalString = lc($string); if ( exists($lookupTable{$normalString}) ) { $type = $lookupTable{$normalString}; } else { $type = CQL_WORD; # remove outer quotes if present if ($string =~ m/^"(.*)"$/g) { $string = $1; # replace escaped double quote with double quote. # Is save this way cause the string is assumed to be syntactically correct $string =~ s/\\"/"/g; } } return bless { string=>$string, type=>$type }, ref($class) || $class; } =head2 getType() Returns the token type which will be available as one of the constants that CQL::Token exports. See internals for a list of available constants. =cut sub getType { return shift->{type}; } =head2 getString() Retruns the string equivalent of the token. Particularly useful when you only know it's a CQL_WORD. =cut sub getString { return shift->{string}; } 1; CQL-Parser-1.13/lib/CQL/Parser.pm0000644000175000017500000003410212222667045015564 0ustar bricasbricaspackage CQL::Parser; use strict; use warnings; use CQL::Lexer; use CQL::Relation; use CQL::Token; use CQL::TermNode; use CQL::AndNode; use CQL::OrNode; use CQL::NotNode; use CQL::PrefixNode; use CQL::ProxNode; use Carp qw( croak ); our $VERSION = '1.13'; my $lexer; my $token; =head1 NAME CQL::Parser - compiles CQL strings into parse trees of Node subtypes. =head1 SYNOPSIS use CQL::Parser; my $parser = CQL::Parser->new(); my $root = $parser->parse( $cql ); =head1 DESCRIPTION CQL::Parser provides a mechanism to parse Common Query Language (CQL) statements. The best description of CQL comes from the CQL homepage at the Library of Congress L CQL is a formal language for representing queries to information retrieval systems such as web indexes, bibliographic catalogs and museum collection information. The CQL design objective is that queries be human readable and human writable, and that the language be intuitive while maintaining the expressiveness of more complex languages. A CQL statement can be as simple as a single keyword, or as complicated as a set of compoenents indicating search indexes, relations, relational modifiers, proximity clauses and boolean logic. CQL::Parser will parse CQL statements and return the root node for a tree of nodes which describes the CQL statement. This data structure can then be used by a client application to analyze the statement, and possibly turn it into a query for a local repository. Each CQL component in the tree inherits from L and can be one of the following: L, L, L, L, L, L. See the documentation for those modules for their respective APIs. Here are some examples of CQL statements: =over 4 =item * george =item * dc.creator=george =item * dc.creator="George Clinton" =item * clinton and funk =item * clinton and parliament and funk =item * (clinton or bootsy) and funk =item * dc.creator="clinton" and dc.date="1976" =back =head1 METHODS =head2 new() =cut ## for convenience the lexer is located at the package level ## just need to be sure to reinitialize it in very call to parse() sub new { my ( $class, $debug ) = @_; $CQL::DEBUG = $debug ? 1 : 0; return bless { }, ref($class) || $class; } =head2 parse( $query ) Pass in a CQL query and you'll get back the root node for the CQL parse tree. If the CQL is invalid an exception will be thrown. =cut sub parse { my ($self,$query) = @_; ## initialize lexer $lexer = CQL::Lexer->new(); debug( "about to parse query: $query" ); ## create the lexer and get the first token $lexer->tokenize( $query ); $token = $lexer->nextToken(); my $root = parseQuery( 'srw.ServerChoice', CQL::Relation->new( 'scr' ) ); if ( $token->getType() != CQL_EOF ) { croak( "junk after end ".$token->getString() ); } return $root; } =head2 parseSafe( $query ) Pass in a CQL query and you'll get back the root node for the CQL parse tree. If the CQL is invalid, an error code from the SRU Diagnostics List will be returned. =cut my @cql_errors = ( { regex => qr/does not support relational modifiers/, code => 20 }, { regex => qr/expected boolean got /, code => 37 }, { regex => qr/expected relation modifier got /, code => 20 }, { regex => qr/unknown first-class relation modifier: /, code => 20 }, { regex => qr/missing term/, code => 27 }, { regex => qr/expected proximity relation got /, code => 40 }, { regex => qr/expected proximity distance got /, code => 41 }, { regex => qr/expected proximity unit got/, code => 42 }, { regex => qr/expected proximity ordering got /, code => 43 }, { regex => qr/unknown first class relation: /, code => 19 }, { regex => qr/must supply name/, code => 15 }, { regex => qr/must supply identifier/, code => 15 }, { regex => qr/must supply subtree/, code => 15 }, { regex => qr/must supply term parameter/, code => 27 }, { regex => qr/doesn\'t support relations other than/, code => 20 }, ); sub parseSafe { my ($self,$query) = @_; my $root = eval { $self->parse( $query ); }; if ( my $error = $@ ) { my $code = 10; for( @cql_errors ) { $code = $_->{ code } if $error =~ $_->{ regex }; } return $code; } return $root; } sub parseQuery { my ( $qualifier, $relation ) = @_; debug( "in parseQuery() with term=" . $token->getString() ); my $term = parseTerm( $qualifier, $relation ); my $type = $token->getType(); while ( $type != CQL_EOF and $type != CQL_RPAREN ) { if ( $type == CQL_AND ) { match($token); my $term2 = parseTerm( $qualifier, $relation ); $term = CQL::AndNode->new( left=>$term, right=>$term2 ); } elsif ( $type == CQL_OR ) { match($token); my $term2 = parseTerm( $qualifier, $relation ); $term = CQL::OrNode->new( left=>$term, right=>$term2 ); } elsif ( $type == CQL_NOT ) { match($token); my $term2 = parseTerm( $qualifier, $relation ); $term = CQL::NotNode->new( left=>$term, right=>$term2 ); } elsif ( $type == CQL_PROX ) { match($token); my $proxNode = CQL::ProxNode->new( $term ); gatherProxParameters( $proxNode ); my $term2 = parseTerm( $qualifier, $relation ); $proxNode->addSecondTerm( $term2 ); $term = $proxNode; } else { croak( "expected boolean got ".$token->getString() ); } $type = $token->getType(); } debug( "no more ops" ); return( $term ); } sub parseTerm { my ( $qualifier, $relation ) = @_; debug( "in parseTerm()" ); my $word; while ( 1 ) { if ( $token->getType() == CQL_LPAREN ) { debug( "parenthesized term" ); match( CQL::Token->new('(') ); my $expr = parseQuery( $qualifier, $relation ); match( CQL::Token->new(')') ); return $expr; } elsif ( $token->getType() == CQL_GT ) { match( $token ); return parsePrefix( $qualifier, $relation ); } debug( "non-parenthesised term" ); $word = matchSymbol( "qualifier or term" ); last if ! isBaseRelation(); $qualifier = $word; debug( "creating relation with word=$word" ); $relation = CQL::Relation->new( $token->getString() ); match( $token ); while ($token->getType() == CQL_MODIFIER ) { match( $token ); if ( !isRelationModifier() ) { croak( "expected relation modifier got " . $token->getString() ); } $relation->addModifier( $token->getString() ); match( $token ); } } debug( "qualifier=$qualifier relation=$relation term=$word" ); croak( "missing term" ) if ! defined($word) or $word eq ''; my $node = CQL::TermNode->new( qualifier => $qualifier, relation => $relation, term => $word ); debug( "made term node: ".$node->toCQL() ); return $node; } sub parsePrefix { my ( $qualifier, $relation ) = @_; debug( "prefix mapping" ); my $name = undef; my $identifier = matchSymbol( "prefix name" ); if ( $token->getType() == CQL_EQ ) { match( $token ); $name = $identifier; $identifier = matchSymbol( "prefix identifier" ); } my $node = parseQuery( $qualifier, $relation ); return CQL::PrefixNode->new( name => $name, identifier => $identifier, subtree => $node ); } sub gatherProxParameters { my $node = shift; if (0) { # CQL 1.0 (obsolete) for (my $i=0; $i<4; $i++ ) { if ( $token->getType() != CQL_MODIFIER ) { ## end of proximity parameters return; } match($token); if ( $token->getType() != CQL_MODIFIER ) { if ( $i==0 ) { gatherProxRelation($node); } elsif ( $i==1 ) { gatherProxDistance($node); } elsif ( $i==2 ) { gatherProxUnit($node); } elsif ( $i==3 ) { gatherProxOrdering($node); } } } } else { while ( $token->getType() == CQL_MODIFIER ) { match( $token ); if ( $token->getType() == CQL_DISTANCE ) { match( $token ); gatherProxRelation( $node ); gatherProxDistance( $node ); } elsif ( $token->getType() == CQL_UNIT ) { match( $token ); if ( $token->getType() != CQL_EQ ) { croak( "expected proximity unit parameter got ".$token->getString() ); } match( $token ); gatherProxUnit( $node ); } elsif ( $token->getType() == CQL_ORDERED || $token->getType() == CQL_UNORDERED ) { gatherProxOrdering( $node ); } else { croak( "expected proximity parameter got ". $token->getString() ."(". $token->getType() .")" ); } } } } sub gatherProxRelation { my $node = shift; if ( ! isProxRelation() ) { croak( "expected proximity relation got ".$token->getString() ); } $node->addModifier( "relation", $token->getString() ); match( $token ); debug( "gatherProxRelation matched ".$token->getString() ); } sub gatherProxDistance { my $node = shift; if ( $token->getString() !~ /^\d+$/ ) { croak( "expected proximity distance got ".$token->getString() ); } $node->addModifier( "distance", $token->getString() ); match( $token ); debug( "gatherProxDistance matched ".$token->getString() ); } sub gatherProxUnit { my $node = shift; my $type = $token->getType(); if( $type != CQL_PWORD and $type != CQL_SENTENCE and $type != CQL_PARAGRAPH and $type != CQL_ELEMENT ) { croak( "expected proximity unit got ".$token->getString() ); } $node->addModifier( "unit", $token->getString() ); match( $token ); debug( "gatherProxUnit matched ".$token->getString() ); } sub gatherProxOrdering { my $node = shift; my $type = $token->getType(); if ( $type != CQL_ORDERED and $type != CQL_UNORDERED ) { croak( "expected proximity ordering got ".$token->getString() ); } $node->addModifier( "ordering", $token->getString() ); match( $token ); } sub isBaseRelation { debug( "inside base relation: checking ttype=".$token->getType()." sval=". $token->getString() ); if( $token->getType() == CQL_WORD and $token->getString() !~ /\./ ) { croak( "unknown first class relation: ".$token->getString() ); } my $type = $token->getType(); return( isProxRelation() or $type==CQL_ANY or $type==CQL_ALL or $type==CQL_EXACT or $type==CQL_SCR or $type==CQL_WORD or $type==CQL_WITHIN or $type==CQL_ENCLOSES); } sub isProxRelation { debug( "isProxRelation: checking ttype=".$token->getType()." sval=". $token->getString() ); my $type = $token->getType(); return( $type==CQL_LT or $type==CQL_GT or $type==CQL_EQ or $type==CQL_LE or $type==CQL_GE or $type==CQL_NE ); } sub isRelationModifier { my $type = $token->getType(); if ($type == CQL_WORD) { return $token->getString() =~ /\./; } return ($type==CQL_RELEVANT or $type==CQL_FUZZY or $type==CQL_STEM or $type==CQL_PHONETIC or $type==CQL_PWORD or $type==CQL_STRING or $type==CQL_ISODATE or $type==CQL_NUMBER or $type==CQL_URI or $type==CQL_PARTIAL or $type==CQL_MASKED or $type==CQL_UNMASKED or $type==CQL_NWSE); } sub match { my $expected = shift; debug( "in match(".$expected->getString().")" ); if ( $token->getType() != $expected->getType() ) { croak( "expected ".$expected->getString() . " but got " . $token->getString() ); } $token = $lexer->nextToken(); debug( "got token type=".$token->getType()." string=".$token->getString() ); } sub matchSymbol { debug( "in match symbol" ); my $return = $token->getString(); match( $token ); return $return; } sub debug { return unless $CQL::DEBUG; print STDERR "CQL::Parser: ", shift, "\n"; } =head1 XCQL CQL has an XML representation which you can generate from a CQL parse tree. Just call the toXCQL() method on the root node you get back from a call to parse(). =head1 ERRORS AND DIAGNOSTICS As mentioned above, a CQL syntax error will result in an exception being thrown. So if you have any doubts about the CQL that you are parsing you should wrap the call to parse() in an eval block, and check $@ afterwards to make sure everything went ok. eval { my $node = $parser->parse( $cql ); }; if ( $@ ) { print "uhoh, exception $@\n"; } If you'd like to see blow by blow details while your CQL is being parsed set $CQL::DEBUG equal to 1, and you will get details on STDERR. This is useful if the parse tree is incorrect and you want to locate where things are going wrong. Hopefully this won't happen, but if it does please notify the author. =head1 TODO =over 4 =item * toYourEngineHere() please feel free to add functionality and send in patches! =back =head1 THANKYOUS CQL::Parser is essentially a Perl port of Mike Taylor's cql-java package http://zing.z3950.org/cql/java/. Mike and IndexData were kind enough to allow the author to write this port, and to make it available under the terms of the Artistic License. Thanks Mike! The CQL::Lexer package relies heavily on Stevan Little's excellent String::Tokenizer. Thanks Stevan! CQL::Parser was developed as a component of the Ockham project, which is funded by the National Science Foundation. See http://www.ockham.org for more information about Ockham. =head1 AUTHOR =over 4 =item * Ed Summers - ehs at pobox dot com =item * Brian Cassidy - bricas at cpan dot org =item * Wilbert Hengst - W.Hengst at uva dot nl =back =head1 COPYRIGHT AND LICENSE Copyright 2004-2009 by Ed Summers This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; CQL-Parser-1.13/lib/CQL/Utils.pm0000644000175000017500000000162512045741350015427 0ustar bricasbricaspackage CQL::Utils; use strict; use warnings; use base qw( Exporter ); our @EXPORT_OK = qw( indent xq renderPrefixes ); ## not for public consumption sub indent { my $level = shift || 0; return " " x $level; } sub xq { my $string = shift || ''; $string =~ s/&/&/g; $string =~ s//>/g; return $string; } sub renderPrefixes { my ($level, @prefixes) = @_; return '' if @prefixes == 0; my $buffer = indent($level)."\n"; for my $prefix (@prefixes) { $buffer .= indent($level+1)."\n"; $buffer .= indent($level+2)."".$prefix->getName()."\n" if $prefix->getName(); $buffer .= indent($level+2)."".$prefix->getIdentifier(). "\n"; $buffer .= indent($level+1)."\n"; } $buffer .= indent($level)."\n"; } 1; CQL-Parser-1.13/lib/CQL/BooleanNode.pm0000644000175000017500000000555212045741350016517 0ustar bricasbricaspackage CQL::BooleanNode; use strict; use warnings; use base qw( CQL::Node ); use CQL::Utils qw( indent xq renderPrefixes ); =head1 NAME CQL::BooleanNode - represents a boolean node in a CQL parse tree =head1 SYNOPSIS n/a =head1 DESCRIPTION Base class for boolean nodes in a CQL parse tree. See CQL::AndNode and CQL::OrNode. CQL::BooleanNode inherits from CQL::Node. Typically you'll want to use CQL::AndNode or CQL::OrNode to instantiate the object. =head1 METHODS =head2 new() You must pass in both a left and right parameter, which should be CQL::Node objects. =cut sub new { my ( $class, %args ) = @_; return bless { left => $args{left}, right => $args{right} }, ref($class) || $class; } =head2 left() =cut sub left { return shift->{left}; } =head2 right() =cut sub right { return shift->{right}; } =head2 toCQL() =cut sub toCQL { my $self = shift; my $left = $self->left(); my $right = $self->right(); ## return: (left) op (right) return '(' . $left->toCQL() . ') ' . $self->op() . ' (' . $right->toCQL() . ')'; } =head2 toSwish() =cut sub toSwish { my $self = shift; my $left = $self->left(); my $right = $self->right(); my $leftStr = $left->isa('CQL::TermNode') ? $left->toSwish() : '('.$left->toSwish().')'; my $rightStr = $right->isa('CQL::TermNode') ? $right->toSwish() : '('.$right->toSwish().')'; return $leftStr . " " . $self->op() . " " . $rightStr; } =head2 toXCQL() =cut sub toXCQL { my ($self,$level,@prefixes) = @_; $level = 0 if ! $level; my $left = $self->left(); my $right = $self->right(); my $xml = indent($level)."\n". renderPrefixes($level+1,@prefixes). $self->opXCQL($level+1). indent($level+1)."\n". $left->toXCQL($level+2). indent($level+1)."\n". indent($level+1)."\n". $right->toXCQL($level+2). indent($level+1)."\n". indent($level)."\n"; return $self->addNamespace( $level, $xml ); } =head2 toLucene() =cut sub toLucene { my $self = shift; my $left = $self->left(); my $right = $self->right(); my $leftStr = $left->isa('CQL::TermNode') ? $left->toLucene() : '('.$left->toLucene().')'; my $rightStr = $right->isa('CQL::TermNode') ? $right->toLucene() : '('.$right->toLucene().')'; return join( ' ', $leftStr, uc $self->op(), $rightStr ) if $self->op() !~ /prox/; my $distance = 1; $distance = $1 if $self->op() =~ /\/distance[=><]{1,2}(\d+)/; return "\"$leftStr $rightStr\"~$distance"; } sub opXCQL { my ($self,$level) = @_; return indent($level)."\n". indent($level+1)."".xq($self->op())."\n". indent($level)."\n"; } 1;