This is an automated email from the git hooks/post-receive script. kanashiro-guest pushed a commit to branch master in repository libnet-dict-perl.
commit 40a98ea245e1046585c820886e9c45b1d9bf445f Author: Lucas Kanashiro <kanashiro.dua...@gmail.com> Date: Sun Jul 19 12:23:34 2015 -0300 Import original source of Net-Dict 2.19 --- Changes | 222 ++++++++++++ MANIFEST | 19 ++ META.json | 55 +++ META.yml | 32 ++ Makefile.PL | 53 +++ README | 47 +++ TODO.md | 7 + dict | 527 ++++++++++++++++++++++++++++ examples/portuguese.pl | 69 ++++ examples/simple.pl | 83 +++++ lib/Net/Dict.pm | 473 +++++++++++++++++++++++++ lib/Net/Dict.pod | 394 +++++++++++++++++++++ t/auth.test | 211 ++++++++++++ t/connection.t | 293 ++++++++++++++++ t/database.t | 290 ++++++++++++++++ t/define.t | 454 ++++++++++++++++++++++++ t/lib/Net/Dict/TestConfig.pm | 10 + t/match.t | 537 +++++++++++++++++++++++++++++ tkdict | 795 +++++++++++++++++++++++++++++++++++++++++++ 19 files changed, 4571 insertions(+) diff --git a/Changes b/Changes new file mode 100644 index 0000000..e782591 --- /dev/null +++ b/Changes @@ -0,0 +1,222 @@ +Revision history for Perl module Net::Dict + +2.19 2014-12-17 + - Fixed failing tests - caused by updated dictionaries on dict.org + - Added a TODO.md file with the things I want to get around to doing. + +2.18 2014-06-26 + - Some of the dict.org databases have been updated, needing updates + to databases. Reported by RJBS. + - Converted tests to use eq_or_diff() from Test::Differences, + also suggested by RJBS. + +2.17 2014-04-25 + - Converted all remaining tests to use Test::More + - Tidied up SEE ALSO, including fixing of broken links + - Tidied up code snippets in the doc + - Reformatted code according to my current conventions, + and got rid of a few rogue tab characters + +2.16 2014-04-20 + - Test server config in Net::Dict::TestConfig in t/lib. + We no longer prompt for test config -- it hasn't changed in years. + - Refactored t/connection.t to use Test::More + +2.15 2014-04-04 + - tkdict script had a very site-specific #! path. Changed to use env. + RT#92184 + +2.14 2014-03-28 + - We weren't correctly handling dictionary db names containing a '-'. + Fix from RJBS. + +2.13 2013-12-23 + - Added "use warnings" to Net::Dict + - Specified min perl version as 5.006 in Makefile.PL + +2.12 2013-11-18 + + - Corrected the dependency I meant to add in the previous release. + I added a dependency on Net::Dict (ie itself) instead. + +2.11 2013-11-15 + + - Added missing dependency (AppConfig::Std) to Makefile.PL + +2.10 2013-07-20 + + - Reformatted this file according to CPAN::Changes::Spec + - Repository details added to metadata (Makefile.PL) and pod + - License type added to metadata (Makefile.PL) + +2.09 2011-12-18 + + - Fixed tests that started breaking due to changes in the dict.org server + - Renamed ChangeLog to Changes & tweaked formatting to CPAN::Changes::Spec + +2.08 2011-08-02 + + - updated testsuite to refer to dict.org, as test.dict.org no longer exists + - updated testsuite to reflect the much longer list of databases now hosted on dict.org + +2.07 2003-05-06 + + - updated testsuite to refer to test.dict.org, + and to reflect changes in the databases. + +2.06 2002-03-23 + + - imported into my home machine's CVS repository + - updated email address + +2.05 2001-04-25 + + - moved the inline documentation to a separate file Dict.pod + - added examples/portuguese.pl which illustrates accessing + an english-portuguese dictionary. + Example from Jose Joao Dias de Almeida <j...@di.uminho.pt>. + +2.04 2001-04-23 + + - tidied up the code for auth(), removing debugging statements, etc. + - added documentation for the auth() method. + - renamed auth.t to auth.test - don't want this run as + part of "make test": it needs my local config for testing. + Do something about that later. + +2.03 2001-04-23 + + - Added code which parses the welcome banner, to get msg id and + optional capabilities. + - Added capabilities() method which returns a list of + supported optional capabilities. + - Added has_capability() method for checking whether a + capability is supported by the server. + - msg_id() method which returns the msg id from the server. + This is used in the auth() method. + - Added auth() method, which uses Digest::MD5. + - Created a testsuite for auth - auth.t + + +2.02 2001-04-03 + + - Oops - forgot to add documentation for the status() method. + +2.01 2001-04-03 + + - Added status() method to Net::Dict - returns the string + returned by the DICT server when STATUS command is sent. + Couple of test cases in t/connection.t + + - When using the sample dict client, if no definition was + found, then it will use Levenshtein or Soundex matching + to look for close words. If the server doesn't support + either strategy, then it just gives a basic error message. + + - Updated the testsuite - new databases on dict.org meant + that certain tests failed (eg where the date is included + in the title of a database). + +2.00 2001-04-01 + + - up'd the major version number - this will be the first public + release version since changing the API for the constructor. + - updated dict and tkdict to use the new method name + + - Various documentation updates, including: + - adding more to the descriptive section of the documentation. + - reformatting the METHODS section + + - strats() method renamed to strategies(). The old name is + retained for backwards compatibility. + + - Put a hack in the match.t test to supress unwanted output + from _print_isa function in Net::Cmd. + + - Removed the dependence on Net::Config from Makefile.PL + + +1.09 2001-03-26 + + - Send the CLIENT command to identify us before any other command + is sent. + + - Don't need to "use Net::Config" now + + - dbTitle() checks whether the given DB name is valid. + If it isn't, and debug is set to non-zero, then we now carp. + + - Fixed a bug in define() - couldn't handle multi-word entries, eg: + $dict->define("oboe d'amore"); + didn't work as it should. The private _DEFINE method now quotes + all arguments before passing them on, since having everything + quoted is ok by RFC 2229. + + - Fixed the same bug in match() method. + + - Finished first pass at testsuite for define() method. + +1.08 2001-03-22 + + - first version of testsuite - not the full set, but enough + to get a few people to test and find out if it's sensible. + - Makefile.PL updated to get hostname and port for test server, + it builds a config file in t/ + + - dbInfo now returns a string rather than an array of lines. + This means it now matches the documentation! + + - dbTitle() returns undef if you request a title of a + non-existent database. + + - Now checks for legality of arg names passed to constructor + - constructor requires hostname as first argument + - don't look for default list of hosts to try from Net::Config + - updated checking of arguments to constructor and error messages + - changed all self variables from $obj to $self + - improved wording of error messages when checking method arg lists + - private method _CLIENT now takes arg, rather than hard-coding + reference to package variable $CLIENT_INFO + - Removed references in to the doc to ConfigFile and HTML + arguments - they weren't actually supported - now mention + this in the LIMITATIONS section + - Put an example of use of constructor with all arguments + in the doc + +1.07 2001-03-04 + + - Updated the one-line description in the NAME pod section. + Previous one was a bit terse - that's what shows up + on search.cpan.org, and similar places. + +1.06 2001-03-04 + + - created tkdict, first cut at a Perl/Tk DICT client. + The interface is currently very DICT protocol centric. + - added dbTitle() method, which is used to query the title + string for a specific database. + - the description strings returned by dbs() and strats() were + quoted with double strings (if that's what the server returned). + Similarly every word returned by match() was quoted. + Now the quotation marks are removed. + +1.05 2001-03-01 + + - added "dict", a sample client script + - strats() method was including a newline in the description + of each strategy, unlike dbs(), which chomp()s the description. + strats() now chomps as well! + - added Client option to Net::Dict, for CLIENT identifier string + - added AUTHOR and ABSTRACT_FROM keys to Makefile.PL + +1.04 2001-02-22 + + - First version under maintenance of Neil Bowers + - Added Makefile.PL, README, MANIFEST. + - Added examples/simple.pl, based on example submitted + by Jose Joao Dias de Almeida <j...@di.uminho.pt> + - Modified in constructor for default port number, + also from Jose. + - previous versions released by Dmitry Rubinstein + <dim...@wisdom.weizmann.ac.il> + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..e3f5f65 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,19 @@ +README +MANIFEST +Makefile.PL +Changes +lib/Net/Dict.pm +lib/Net/Dict.pod +dict +tkdict +examples/simple.pl +examples/portuguese.pl +t/connection.t +t/database.t +t/define.t +t/match.t +t/auth.test +t/lib/Net/Dict/TestConfig.pm +TODO.md +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/META.json b/META.json new file mode 100644 index 0000000..3878681 --- /dev/null +++ b/META.json @@ -0,0 +1,55 @@ +{ + "abstract" : "client API for accessing dictionary servers (RFC 2229)", + "author" : [ + "Neil Bowers <n...@bowers.com>" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 7.02, CPAN::Meta::Converter version 2.143240", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Net-Dict", + "no_index" : { + "directory" : [ + "t", + "inc" + ], + "package" : [ + "Net::Dict::TestConfig" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0", + "Test::Differences" : "0.62", + "Test::More" : "0.88" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "AppConfig::Std" : "0", + "Carp" : "0", + "IO::Socket" : "0", + "Net::Cmd" : "0", + "perl" : "5.006" + } + } + }, + "release_status" : "stable", + "resources" : { + "repository" : { + "url" : "https://github.com/neilbowers/Net-Dict" + } + }, + "version" : "2.19" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..ef3cc7b --- /dev/null +++ b/META.yml @@ -0,0 +1,32 @@ +--- +abstract: 'client API for accessing dictionary servers (RFC 2229)' +author: + - 'Neil Bowers <n...@bowers.com>' +build_requires: + ExtUtils::MakeMaker: '0' + Test::Differences: '0.62' + Test::More: '0.88' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 7.02, CPAN::Meta::Converter version 2.143240' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Net-Dict +no_index: + directory: + - t + - inc + package: + - Net::Dict::TestConfig +requires: + AppConfig::Std: '0' + Carp: '0' + IO::Socket: '0' + Net::Cmd: '0' + perl: '5.006' +resources: + repository: https://github.com/neilbowers/Net-Dict +version: '2.19' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..bdc0a44 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,53 @@ +# +# Makefile.PL for Net-Dict +# +# $Id: Makefile.PL,v 1.2 2003/05/05 23:56:17 neilb Exp $ +# + +use ExtUtils::MakeMaker; + +my $mm_ver = $ExtUtils::MakeMaker::VERSION; +if ($mm_ver =~ /_/) { # dev version + $mm_ver = eval $mm_ver; + die $@ if $@; +} + +&WriteMakefile( + NAME => 'Net::Dict', + DISTNAME => 'Net-Dict', + VERSION_FROM => 'lib/Net/Dict.pm', + PREREQ_PM => { + 'IO::Socket' => 0, + 'Net::Cmd' => 0, + 'Carp' => 0, + 'AppConfig::Std' => 0, + }, + EXE_FILES => [qw(dict tkdict)], + AUTHOR => 'Neil Bowers <n...@bowers.com>', + ABSTRACT_FROM => 'lib/Net/Dict.pod', + META_MERGE => { + resources => { + repository => 'https://github.com/neilbowers/Net-Dict', + }, + no_index => { + package => ['Net::Dict::TestConfig'], + } + }, + LICENSE => 'perl', + dist => {COMPRESS => 'gzip', SUFFIX => 'gz'}, + + ($mm_ver >= 6.48 + ? (MIN_PERL_VERSION => 5.006) + : () + ), + + ($mm_ver >= 6.64 + ? (TEST_REQUIRES => { + 'Test::More' => 0.88, + 'Test::Differences' => 0.62, + }) + : () + ), + +); + diff --git a/README b/README new file mode 100644 index 0000000..099a69b --- /dev/null +++ b/README @@ -0,0 +1,47 @@ + + Net::Dict + +This distribution contains the Net::Dict module for Perl. +Net::Dict is a class implementing a simple client API +for the DICT protocol defined in RFC2229. + +To install this module, you should just have to run the following: + + % perl Makefile.PL + % make + % make test + % make install + +When you run "perl Makefile.PL" you'll be asked for the hostname +and port for the DICT server used when testing. If you're not +going to run "make install", then just press return. You should +be able to just press return on the two questions anyway. + +This module now supports the AUTH optional capability. To use this +you will need the Digest::MD5 module, available from CPAN. + +The module is documented using pod. When you "make install", you +will get a man-page Net::Dict. You can also generate HTML using pod2html: + + % pod2html lib/Net/Dict.pm + +Three sample clients are included in this distribution. +Any additional modules required are noted, and available from CPAN. + + dict + A basic command-line client, based on the C dict client + by Rik Faith. + Requires: AppConfig, AppConfig::Std + + tkdict + A first cut at a Perl/Tk client. This is pretty rough; + any suggestions or patches are welcome! + Requires: AppConfig, AppConfig::Std, Tk, Tk::Dialog + + examples/simple.pl + Illustrates basic use of Net::Dict. + +Net::Dict was written by Dmitry Rubinstein, but is now maintained by me. + + +Neil Bowers <n...@bowers.com> diff --git a/TODO.md b/TODO.md new file mode 100644 index 0000000..93cf641 --- /dev/null +++ b/TODO.md @@ -0,0 +1,7 @@ +* Move all live dict.org tests to xt/release +* Come up with some sensible tests for t/ + that don't require a remote DICT server +* Full test coverage +* Change t/define.t to use Test::Differences +* Better OO design +* Switch to Dist::Zilla diff --git a/dict b/dict new file mode 100755 index 0000000..7f91346 --- /dev/null +++ b/dict @@ -0,0 +1,527 @@ +#!/usr/bin/env perl +# +# dict - perl DICT client (for accessing network dictionary servers) +# +# $Id: dict,v 1.2 2003/05/05 23:55:00 neilb Exp $ +# + +use strict; +use warnings; +use Net::Dict; +use AppConfig::Std; + +use vars qw($VERSION); +$VERSION = sprintf("%d.%d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/); + +#----------------------------------------------------------------------- +# Global variables +#----------------------------------------------------------------------- +my $PROGRAM; # The name we're running as, minus path +my $config; # Config object (AppConfig::Std) +my $dict; # Dictionary object (Net::Dict) + +initialise(); + +#----------------------------------------------------------------------- +# Deal with any informational options +#----------------------------------------------------------------------- +print $dict->serverInfo(), "\n" if $config->serverinfo; +show_db_info($config->info) if $config->info; +list_databases() if $config->dbs; +list_strategies() if $config->strats; +$dict->setDicts($config->database) if $config->database; + +#----------------------------------------------------------------------- +# Perform define or match, if a word or pattern was given +#----------------------------------------------------------------------- +if (@ARGV > 0) +{ + if ($config->match) + { + match_word(shift @ARGV); + } + else + { + define_word(shift @ARGV); + } +} + +exit 0; + + +#======================================================================= +# +# define_word() +# +# Look up definition(s) for the specified word. +# +#======================================================================= +sub define_word +{ + my $word = shift; + my $eref; + my $entry; + my ($db, $def); + + + $eref = $dict->define($word); + + if (@$eref == 0) + { + _no_definitions($word); + } + else + { + foreach $entry (@$eref) + { + ($db, $def) = @$entry; + print "--- [from $db] ---\n", $def, "\n"; + } + } +} + +#======================================================================= +# +# _no_definitions() +# +# Called when no definitions were found for the given word. +# We use either 'lev' or 'soundex' matching to look for words +# which are "close" to the given word, in-case they've mis-spelled +# it, etc. +# +#======================================================================= +sub _no_definitions +{ + my $word = shift; + + my %strategies; + my %words; + my $strategy; + + + %strategies = $dict->strategies; + if (!exists($strategies{'lev'}) && !exists($strategies{'soundex'})) + { + print " no definition found for \"$word\"\n"; + return; + } + + $strategy = exists $strategies{'lev'} ? 'lev' : 'soundex'; + foreach my $entry (@{ $dict->match($word, $strategy) }) + { + $words{$entry->[1]}++; + } + if (keys %words == 0) + { + print " no definition found for \"$word\", ", + "and no similar words found\n"; + } + else + { + print " no definition found for \"$word\" - perhaps you meant:\n"; + print " ", join(', ', keys %words), "\n"; + } +} + +#======================================================================= +# +# match_word() +# +# Look for matches of the given word, using the strategy specified +# with the -strategy switch. +# +#======================================================================= +sub match_word +{ + my $word = shift; + my $eref; + my $entry; + my ($db, $match); + + + unless ($config->strategy) + { + die "you must specify -strategy when using -match\n"; + } + $eref = $dict->match($word, $config->strategy); + + if (@$eref == 0) + { + print " no matches for \"$word\"\n"; + } + else + { + foreach $entry (@$eref) + { + ($db, $match) = @$entry; + print "$db : $match\n"; + } + } +} + +#======================================================================= +# +# list_databases() +# +# Query and display the list of available databases on the selected +# DICT server. +# +#======================================================================= +sub list_databases +{ + my %dbs = $dict->dbs(); + + + tabulate_hash(\%dbs, 'Database', 'Description'); +} + +#======================================================================= +# +# list_strategies() +# +# Query and display the list of matching strategies supported +# by the DICT server. +# +#======================================================================= +sub list_strategies +{ + my %strats = $dict->strategies(); + + + tabulate_hash(\%strats, 'Strategy', 'Description'); +} + +#======================================================================= +# +# show_db_info() +# +# Query the server for information about the specified database, +# and display the results. +# +# The information is typically several pages of text, +# describing the contents of the dictionary, where it came from, +# credits, etc. +# +#======================================================================= +sub show_db_info +{ + my $db = shift; + my %dbs = $dict->dbs(); + + + if (not exists $dbs{$config->info}) + { + print " dictionary \"$db\" not known\n"; + return; + } + + print $dict->dbInfo($config->info); +} + +#======================================================================= +# +# initialise() +# +# check config file and command-line +# +#======================================================================= +sub initialise +{ + #------------------------------------------------------------------- + # Initialise misc global variables + #------------------------------------------------------------------- + ($PROGRAM = $0) =~ s!.*/!!; + + #------------------------------------------------------------------- + # Create AppConfig::Std, define parameters, and parse command-line + #------------------------------------------------------------------- + $config = AppConfig::Std->new({ CASE => 1 }) + || die "failed to create AppConfig::Std: $!\n"; + + $config->define('host', { ARGCOUNT => 1, ALIAS => 'h' }); + $config->define('port', { ARGCOUNT => 1, ALIAS => 'p', + DEFAULT => 2628 }); + $config->define('database', { ARGCOUNT => 1, ALIAS => 'd' }); + $config->define('match', { ARGCOUNT => 0, ALIAS => 'm' }); + $config->define('dbs', { ARGCOUNT => 0, ALIAS => 'D' }); + $config->define('strategy', { ARGCOUNT => 1, ALIAS => 's' }); + $config->define('strats', { ARGCOUNT => 0, ALIAS => 'S' }); + $config->define('client', { ARGCOUNT => 1, ALIAS => 'c', + DEFAULT => "$PROGRAM $VERSION ". + "[using Net::Dict $Net::Dict::VERSION]", + }); + $config->define('info', { ARGCOUNT => 1, ALIAS => 'i' }); + $config->define('serverinfo', { ARGCOUNT => 0, ALIAS => 'I' }); + $config->define('verbose', { ARGCOUNT => 0 }); + + $config->args(\@ARGV) + || die "run \"$PROGRAM -help\" to see valid options\n"; + + #------------------------------------------------------------------- + # Consistency checking, ensure we have required options, etc. + #------------------------------------------------------------------- + $config->host('dict.org') unless $config->host; + + print $config->client, "\n" if $config->verbose || $config->debug; + + #------------------------------------------------------------------- + # Create connection to DICT server + #------------------------------------------------------------------- + $dict = Net::Dict->new($config->host, + Port => $config->port, + Client => $config->client, + Debug => $config->debug, + ) + || die "failed to create Net::Dict: $!\n"; +} + +#======================================================================= +# +# tabulate_hash() +# +# format a hash as a simple ascii table, for displaying lists +# of databases and strategies. +# +#======================================================================= +sub tabulate_hash +{ + my $hashref = shift; + my $keytitle = shift; + my $value_title = shift; + + my $width = length $keytitle; + my ($key, $value); + + + #------------------------------------------------------------------- + # Find the length of the longest key, so we can right align + # the column of keys + #------------------------------------------------------------------- + foreach $key (keys %$hashref) + { + $width = length($key) if length($key) > $width; + } + + #------------------------------------------------------------------- + # print out keys and values in a basic ascii formatted table view + #------------------------------------------------------------------- + printf(" %${width}s $value_title\n", $keytitle); + print ' ', '-' x $width, ' ', '-' x (length $value_title), "\n"; + while (($key, $value) = each %$hashref) + { + printf(" %${width}s : $value\n", $key); + } + print "\n"; +} + + +__END__ + +=head1 NAME + +dict - a perl client for accessing network dictionary servers + +=head1 SYNOPSIS + +B<dict> [OPTIONS] I<word> + +=head1 DESCRIPTION + +B<dict> is a client for the Dictionary server protocol (DICT), +which is used to query natural language dictionaries hosted on +a remote machine. When used in the most simple way, + + % dict word + +B<dict> will look for definitions of I<word> in the dictionaries +hosted at B<dict.org>. If no definitions are found, then dict +will look for words which are similar, and list them: + + % dict bonana + no definition for "bonana" - perhaps you meant: + banana, bonanza, Banana, Bonanza, Bonasa + +This feature is only available if the remote DICT server supports +the I<soundex> or I<Levenshtein> matching strategies. +You can use the B<-stats> switch to find out for yourself. + +You can specify the hostname of the DICT server using the B<-h> option: + + % dict -h dict.org dictionary + +A DICT server can support a number of databases; +you can use the B<-d> option to specify a particular database. +For example, you can look up computer-related terms +in the Free On-line Dictionary Of Computing (FOLDOC) using: + + % dict -h dict.org -d foldoc byte + +To find out what databases (dictionaries) are available on +a server, use the B<-dbs> option: + + % dict -dbs + +There are many dictionaries hosted on other servers around the net; +a list of some of them can be found at + + http://www.dict.org/links.html + +=head2 MATCHING + +Instead of requesting word definitions, you can use dict +to request a list of words which match a pattern. +For example, to look for four-letter words starting in 'b' +and ending in 'p', you would use: + + % dict -match -strategy re '^b..p$' + +The B<-match> option says you want a list of matching words rather +than a definition. +The B<-strategy re> says to use POSIX regular expressions +when matching the pattern B<^b..p$>. + +Most DICT servers support a number of matching strategies; +you can get a list of the strategies provided by a server +using the B<-strats> switch: + + % dict -h dict.org -strats + +=head1 OPTIONS + +=over 4 + +=item B<-h> I<server> or B<-host> I<server> + +The hostname for the DICT server. If one isn't specified +then defaults to B<dict.org>. + +=item B<-p> I<port> or B<-port> I<port> + +Specify the port for connections (default is 2628, from RFC 2229). + +=item B<-d> I<dbname> or B<-database> I<dbname> + +The name of a specific database (dictionary) to query. + +=item B<-m> or B<-match> + +Look for words which match the pattern (using the specified strategy). + +=item B<-i> I<dbname> or B<-info> I<dbname> + +Request information on the specified database. +Typically results in a couple of pages of text. + +=item B<-c> I<string> or B<-client> I<string> + +Specify the CLIENT identification string sent to the DICT server. + +=item B<-D> or B<-dbs> + +List the available databases (dictionaries) on the DICT server. + +=item B<-s> I<strategy> or B<-strategy> I<strategy> + +Specify a matching strategy. Used in combination with B<-match>. + +=item B<-S> or B<-strats> + +List the matching strategies (used in -strategy) supported +by the DICT server. + +=item B<-I> or B<-serverinfo> + +Request information on the selected DICT server. + +=item B<-help> + +Display a short help message including command-line options. + +=item B<-doc> + +Display the full documentation for B<dict>. + +=item B<-version> + +Display the version of B<dict> + +=item B<-verbose> + +Display verbose information as B<dict> runs. + +=item B<-debug> + +Display debugging information as B<dict> runs. +Useful mainly for developers. + +=back + +=head1 KNOWN BUGS AND LIMITATIONS + +=over 4 + +=item * + +B<dict> doesn't know how to handle firewalls. + +=item * + +The authentication aspects of RFC 2229 aren't currently supported. + +=item * + +Display of list results (eg from B<-strats> and B<-dbs>) could be better. + +=item * + +B<dict> isn't very smart at handling combinations of options. + +=item * + +Currently no support for a configuration file - will add one soon. + +=back + +=head1 SEE ALSO + +=over 4 + +=item www.dict.org + +The DICT home page, with all sorts of useful information. +There are a number of other DICT clients available. + +=item dict + +The C dict client written by Rik Faith; +the options are pretty much lifted from Rik's client. + +=item RFC 2229 + +The document which defines the DICT network protocol. + +http://www.cis.ohio-state.edu/htbin/rfc/rfc2229.html + +=item Net::Dict + +The perl module which implements the client API for RFC 2229. + +=back + +=head1 VERSION + +$Revision: 1.2 $ + +=head1 AUTHOR + +Neil Bowers <n...@bowers.com> + +=head1 COPYRIGHT + +Copyright (C) 2002 Neil Bowers. All rights reserved. + +This script is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/examples/portuguese.pl b/examples/portuguese.pl new file mode 100755 index 0000000..84bc6ec --- /dev/null +++ b/examples/portuguese.pl @@ -0,0 +1,69 @@ +#!/usr/bin/perl -w +# +# portugueses.pl - example showing access to a translation dictionary +# +# DICT can also be used to provide translation dictionaries. +# +# Here we connect to a server which has an English->Portuguese +# dictionary: natura.di.uminho.pt +# +# We select the specific dictionary, and then prompt the user +# for words, displaying the translation back. +# +# This is based on an example from Jose Joao Dias de Almeida <j...@di.uminho.pt> +# +# $Id: portuguese.pl,v 1.1.1.1 2003/04/26 22:59:11 neilb Exp $ +# + +use Net::Dict; +use utf8; + +my $dict; +my $host = 'natura.di.uminho.pt'; +my $prompt = "english> "; +my $database = 'eng-por'; +my $entry; +my $db; +my $translation; + +#----------------------------------------------------------------------- +# Turn off buffering on STDOUT +#----------------------------------------------------------------------- +$| = 1; + +#----------------------------------------------------------------------- +# Create instance of Net::Dict, connecting to the server +#----------------------------------------------------------------------- +print "Connecting to $host ..."; +$dict = Net::Dict->new($host); +$dict->setDicts($database); + +#----------------------------------------------------------------------- +# Let the user repeatedly enter words, which we then look up. +#----------------------------------------------------------------------- +print $prompt; +while(<>) +{ + chomp; + next unless $_; + + $eref = $dict->define($_); + + if (@$eref == 0) + { + print " no translation for \"$_\"\n"; + } + else + { + foreach $entry (@$eref) + { + ($db, $translation) = @$entry; + $translation =~ y/[\200-\377]/[\200-\377]/UC; + + print "$db--------\n",$translation; + } + } + + print $prompt; +} + diff --git a/examples/simple.pl b/examples/simple.pl new file mode 100755 index 0000000..bec54da --- /dev/null +++ b/examples/simple.pl @@ -0,0 +1,83 @@ +#!/usr/bin/perl -w +# +# simple.pl - a simple example illustrating use of Net::Dict +# +# This is a simple Net::Dict which illustrates basic use +# to get word definitions. Usage: +# +# simple.pl myhost.org +# simple.pl +# +# if no hostname is given, then default to dict.org +# +# The user is then prompted for words. We look up definitions +# and display all that we get back. +# +# This is based on an example from Jose Joao Dias de Almeida <j...@di.uminho.pt> +# +# $Id: simple.pl,v 1.1.1.1 2003/04/26 22:59:11 neilb Exp $ +# + +use strict; +use Net::Dict; + +my $dict; +my $host; +my $prompt = "define> "; +my $eref; +my $entry; +my $db; +my $definition; + +#----------------------------------------------------------------------- +# Turn off buffering on STDOUT +#----------------------------------------------------------------------- +$| = 1; + +#----------------------------------------------------------------------- +# Create instance of Net::Dict, connecting either to a user-specified +# dict server, or defaulting to dict.org +#----------------------------------------------------------------------- +$host = @ARGV > 0 ? shift @ARGV : 'dict.org'; +print "Connecting to $host ..."; +$dict = Net::Dict->new($host); +print "\n"; + +#----------------------------------------------------------------------- +# Let the user repeatedly enter words, which we then look up. +#----------------------------------------------------------------------- +print $prompt; +while (<>) +{ + chomp; + next unless $_; + + #------------------------------------------------------------------- + # The define() method returns an array reference. + # The array has one entry for each definition found. + # If the referenced array has no entries, then there were no + # definitions in any of the dictionaries on the server. + #------------------------------------------------------------------- + $eref = $dict->define($_); + + if (@$eref == 0) + { + print " no definition for \"$_\"\n"; + } + else + { + #--------------------------------------------------------------- + # Each entry is another array reference. The referenced array + # for each entry has two elements: + # $db - the name of the database (ie dictionary) + # $definition - the text of the definition + #--------------------------------------------------------------- + foreach $entry (@$eref) + { + ($db, $definition) = @$entry; + print "\n-----(from: $db)---------------------------\n", + $definition; + } + } + print $prompt; +} diff --git a/lib/Net/Dict.pm b/lib/Net/Dict.pm new file mode 100644 index 0000000..96b60de --- /dev/null +++ b/lib/Net/Dict.pm @@ -0,0 +1,473 @@ +# +# Net::Dict.pm +# +# Copyright (C) 2001-2003 Neil Bowers <n...@bowers.com> +# Copyright (c) 1998 Dmitry Rubinstein <dim...@wisdom.weizmann.ac.il>. +# +# All rights reserved. This program is free software; you can +# redistribute it and/or modify it under the same terms as Perl +# itself. +# + +package Net::Dict; + +use warnings; +use strict; +use IO::Socket; +use Net::Cmd; +use Carp; + +use vars qw(@ISA $debug); +our $VERSION = '2.19'; + +#----------------------------------------------------------------------- +# Default values for arguments to new(). We also use this to +# determine valid argument names - if it's not a key of this hash, +# then it's not a valid argument. +#----------------------------------------------------------------------- +my %ARG_DEFAULT = +( + Port => 2628, + Timeout => 120, + Debug => 0, + Client => "Net::Dict v$VERSION", +); + +@ISA = qw(Net::Cmd IO::Socket::INET); + +#======================================================================= +# +# new() +# +# constructor - open connection to host, get a list of databases, +# and send CLIENT identification command. +# +#======================================================================= +sub new +{ + @_ > 1 or croak 'usage: Net::Dict->new() takes at least a HOST name'; + my $class = shift; + my $host = shift; + int(@_) % 2 == 0 or croak 'Net::Dict->new(): odd number of arguments'; + my %inargs = @_; + + my $self; + my $argref; + + + return undef unless defined $host; + + #------------------------------------------------------------------- + # Process arguments, setting defaults if needed + #------------------------------------------------------------------- + $argref = {}; + foreach my $arg (keys %ARG_DEFAULT) { + $argref->{$arg} = exists $inargs{$arg} + ? $inargs{$arg} + : $ARG_DEFAULT{$arg}; + delete $inargs{$arg}; + } + + if (keys(%inargs) > 0) { + croak "Net::Dict->new(): unknown argument - ", + join(', ', keys %inargs); + } + + #------------------------------------------------------------------- + # Make the connection + #------------------------------------------------------------------- + $self = $class->SUPER::new(PeerAddr => $host, + PeerPort => $argref->{Port}, + Proto => 'tcp', + Timeout => $argref->{Timeout} + ); + + return undef unless defined $self; + + ${*$self}{'net_dict_host'} = $host; + + $self->autoflush(1); + $self->debug($argref->{Debug}); + + if ($self->response() != CMD_OK) { + $self->close(); + return undef; + } + + # parse the initial 220 response + $self->_parse_banner($self->message); + + #------------------------------------------------------------------- + # Send the CLIENT command which identifies the connecting client + #------------------------------------------------------------------- + $self->_CLIENT($argref->{Client}); + + #------------------------------------------------------------------- + # The default - search ALL dictionaries + #------------------------------------------------------------------- + $self->setDicts('*'); + + return $self; +} + +sub dbs +{ + @_ == 1 or croak 'usage: $dict->dbs() - takes no arguments'; + my $self = shift; + + $self->_get_database_list(); + return %{${*$self}{'net_dict_dbs'}}; +} + +sub setDicts +{ + my $self = shift; + + @{${*$self}{'net_dict_userdbs'}} = @_; +} + +sub serverInfo +{ + @_ == 1 or croak 'usage: $dict->serverInfo()'; + my $self = shift; + + return 0 unless $self->_SHOW_SERVER(); + + my $info = join('', @{$self->read_until_dot}); + $self->getline(); + $info; +} + +sub dbInfo +{ + @_ == 2 or croak 'usage: $dict->dbInfo($dbname) - one argument only'; + my $self = shift; + + if ($self->_SHOW_INFO(@_)) { + return join('', @{$self->read_until_dot()}); + } + else { + return undef; + } +} + +sub dbTitle +{ + @_ == 2 or croak 'dbTitle() method expects one argument - DB name'; + my $self = shift; + my $dbname = shift; + + + $self->_get_database_list(); + if (exists ${${*$self}{'net_dict_dbs'}}{$dbname}) { + return ${${*$self}{'net_dict_dbs'}}{$dbname}; + } + else { + carp 'dbTitle(): unknown database name' if $self->debug; + return undef; + } +} + +sub strategies +{ + @_ == 1 or croak 'usage: $dict->strategies()'; + my $self = shift; + + return 0 unless $self->_SHOW_STRAT(); + + my (%strats, $name, $desc); + foreach (@{$self->read_until_dot()}) { + ($name, $desc) = (split /\s/, $_, 2); + chomp $desc; + $strats{$name} = _unquote($desc); + } + $self->getline(); + %strats; +} + +sub define +{ + @_ >= 2 or croak 'usage: $dict->define($word [, @dbs]) - takes at least one argument'; + my $self = shift; + my $word = shift; + my @dbs = (@_ > 0) ? @_ : @{${*$self}{'net_dict_userdbs'}}; + croak 'select some dictionaries with setDicts or supply as argument to define' + unless @dbs; + my($db, @defs); + + + #------------------------------------------------------------------- + # check whether we got an empty word + #------------------------------------------------------------------- + if (!defined($word) || $word eq '') { + carp "empty word passed to define() method"; + return undef; + } + + foreach $db (@dbs) { + next unless $self->_DEFINE($db, $word); + + my ($defNum) = ($self->message =~ /^\d{3} (\d+) /); + + foreach (0..$defNum-1) { + my ($d) = ($self->getline =~ /^\d{3} ".*" ([-\w]+) /); + my ($def) = join '', @{$self->read_until_dot}; + push @defs, [$d, $def]; + } + $self->getline(); + } + \@defs; +} + +sub match +{ + @_ >= 3 or croak 'usage: $self->match($word, $strat [, @dbs]) - takes at least two arguments'; + my $self = shift; + my $word = shift; + my $strat = shift; + my @dbs = (@_ > 0) ? @_ : @{${*$self}{'net_dict_userdbs'}}; + croak 'define some dictionaries by setDicts or supply as argument to define' + unless @dbs; + my ($db, @matches); + + #------------------------------------------------------------------- + # check whether we got an empty pattern + #------------------------------------------------------------------- + if (!defined($word) || $word eq '') { + carp "empty pattern passed to match() method"; + return undef; + } + + foreach $db (@dbs) { + next unless $self->_MATCH($db, $strat, $word); + + my ($db, $w); + foreach (@{$self->read_until_dot}) { + ($db, $w) = split /\s/, $_, 2; + chomp $w; + push @matches, [$db, _unquote($w)]; + } + $self->getline(); + } + \@matches; +} + +sub auth +{ + @_ == 3 or croak 'usage: $dict->auth() - takes two arguments'; + my $self = shift; + my $user = shift; + my $pass_phrase = shift; + my $auth_string; + my $string; + my $ctx; + + + require Digest::MD5; + $string = $self->msg_id().$pass_phrase; + $auth_string = Digest::MD5::md5_hex($string); + + if ($self->_AUTH($user, $auth_string)) { + #--------------------------------------------------------------- + # clear the cache of database names + # next time a method needs them, this will cause us to go + # back to the server, and thus pick up any AUTH-restricted DBs + #--------------------------------------------------------------- + delete ${*$self}{'net_dict_dbs'}; + } + else { + carp "auth() failed with error code ".$self->code() if $self->debug(); + return; + } +} + +sub status +{ + @_ == 1 or croak 'usage: $dict->status() - takes no arguments'; + my $self = shift; + my $message; + + + $self->_STATUS() || return 0; + chomp($message = $self->message); + $message =~ s/^\d{3} //; + return $message; +} + +sub capabilities +{ + @_ == 1 or croak 'usage: $dict->capabilities() - takes no arguments'; + my $self = shift; + + + return @{ ${*$self}{'net_dict_capabilities'} }; +} + +sub has_capability +{ + @_ == 2 or croak 'usage: $dict->has_capability() - takes one argument'; + my $self = shift; + my $cap = shift; + + + return grep(lc($cap) eq $_, $self->capabilities()); +} + +sub msg_id +{ + @_ == 1 or croak 'usage: $dict->msg_id() - takes no arguments'; + my $self = shift; + + + return ${*$self}{'net_dict_msgid'}; +} + + +sub _DEFINE { shift->command('DEFINE', map { '"'.$_.'"' } @_)->response() == CMD_INFO } +sub _MATCH { shift->command('MATCH', map { '"'.$_.'"' } @_)->response() == CMD_INFO } +sub _SHOW_DB { shift->command('SHOW DB')->response() == CMD_INFO } +sub _SHOW_STRAT { shift->command('SHOW STRAT')->response() == CMD_INFO } +sub _SHOW_INFO { shift->command('SHOW INFO', @_)->response() == CMD_INFO } +sub _SHOW_SERVER { shift->command('SHOW SERVER')->response() == CMD_INFO } +sub _CLIENT { shift->command('CLIENT', @_)->response() == CMD_OK } +sub _STATUS { shift->command('STATUS')->response() == CMD_OK } +sub _HELP { shift->command('HELP')->response() == CMD_INFO } +sub _QUIT { shift->command('QUIT')->response() == CMD_OK } +sub _OPTION_MIME { shift->command('OPTION MIME')->response() == CMD_OK } +sub _AUTH { shift->command('AUTH', @_)->response() == CMD_OK } +sub _SASLAUTH { shift->command('SASLAUTH', @_)->response() == CMD_OK } +sub _SASLRESP { shift->command('SASLRESP', @_)->response() == CMD_OK } + +sub quit +{ + my $self = shift; + + $self->_QUIT; + $self->close; +} + +sub DESTROY +{ + my $self = shift; + + if (defined fileno($self)) { + $self->quit; + } +} + +sub response +{ + my $self = shift; + my $str = $self->getline() || return undef; + + + if ($self->debug) { + $self->debug_print(0,$str); + } + + my($code) = ($str =~ /^(\d+) /); + + ${*$self}{'net_cmd_resp'} = [ $str ]; + ${*$self}{'net_cmd_code'} = $code; + + substr($code,0,1); +} + +#======================================================================= +# +# _unquote +# +# Private function used to remove quotation marks from around +# a string. +# +#======================================================================= +sub _unquote +{ + my $string = shift; + + + if ($string =~ /^"/) { + $string =~ s/^"//; + $string =~ s/"$//; + } + return $string; +} + +#======================================================================= +# +# _parse_banner +# +# Parse the initial response banner the server sends when we connect. +# Hoping for: +# 220 blah blah <auth.mime> <msgid> +# The <auth.mime> string gives a list of supported extensions. +# The last bit is a msg-id, which identifies this connection, +# and is used in authentication, for example. +# +#======================================================================= +sub _parse_banner +{ + my $self = shift; + my $banner = shift; + my ($code, $capstring, $msgid); + + + ${*$self}{'net_dict_banner'} = $banner; + ${*$self}{'net_dict_capabilities'} = []; + if ($banner =~ /^(\d{3}) (.*) (<[^<>]*>)?\s+(<[^<>]+>)\s*$/) { + ${*$self}{'net_dict_msgid'} = $4; + ($capstring = $3) =~ s/[<>]//g; + if (length($capstring) > 0) { + ${*$self}{'net_dict_capabilities'} = [split(/\./, $capstring)]; + } + } + else { + carp "unexpected format for welcome banner on connection:\n", + $banner if $self->debug; + } +} + +#======================================================================= +# +# _get_database_list +# +# Get the list of databases on the remote server. +# We cache them in the instance data object, so that dbTitle() +# and databases() don't have to go to the server every time. +# +# We check to see whether we've already got the databases first, +# and do nothing if so. This means that this private method +# can just be invoked in the public methods. +# +#======================================================================= +sub _get_database_list +{ + my $self = shift; + + + return if exists ${*$self}{'net_dict_dbs'}; + + if ($self->_SHOW_DB) { + my ($dbNum) = ($self->message =~ /^\d{3} (\d+)/); + my ($name, $descr); + + foreach (0..$dbNum-1) { + ($name, $descr) = (split /\s/, $self->getline, 2); + chomp $descr; + ${${*$self}{'net_dict_dbs'}}{$name} = _unquote($descr); + } + + # Is there a way to do it right? Reading the dot line and the + # status line afterwards? Maybe I should use read_until_dot? + $self->getline(); + $self->getline(); + } +} + +#----------------------------------------------------------------------- +# Method aliases for backwards compatibility +#----------------------------------------------------------------------- +*strats = \&strategies; + +1; + diff --git a/lib/Net/Dict.pod b/lib/Net/Dict.pod new file mode 100644 index 0000000..9cbab0f --- /dev/null +++ b/lib/Net/Dict.pod @@ -0,0 +1,394 @@ + +=head1 NAME + +Net::Dict - client API for accessing dictionary servers (RFC 2229) + +=head1 SYNOPSIS + + use Net::Dict; + + $dict = Net::Dict->new('dict.server.host'); + $h = $dict->define("word"); + foreach $i (@{$h}) { + ($db, $def) = @{$i}; + . . . + } + +=head1 DESCRIPTION + +C<Net::Dict> is a perl class for looking up words and their +definitions on network dictionary servers. +C<Net::Dict> provides a simple DICT client API for the network +protocol described in RFC2229. Quoting from that RFC: + +=over + +=item + +The Dictionary Server Protocol (DICT) is a TCP transaction based +query/response protocol that allows a client to access dictionary +definitions from a set of natural language dictionary databases. + +=back + +An instance of Net::Dict represents a connection to a single +DICT server. For example, to connect to the dictionary +server at C<dict.org>, you would write: + + $dict = Net::Dict->new('dict.org'); + +A DICT server can provide any number of dictionaries, +which are referred to as I<databases>. +Each database has a I<name> and a I<title>. +The name is a short identifier, +typically just one word, used to refer to that database. +The title is a brief one-line description of the database. +For example, at the time of writing, the C<dict.org> server +has 11 databases, including a version of Webster's +dictionary from 1913. The name of the database is I<web1913>, +and the title is I<Webster's Revised Unabridged Dictionary (1913)>. + +To look up definitions for a word, you use the C<define> method: + + $dref = $dict->define('banana'); + +This returns a reference to a list; each entry in the list +is a reference to a two item list: + + [ $dbname, $definition ] + +The first entry is a I<database name> as introduced above. +The second entry is the text of a definition from +the specified dictionary. + +=head2 MATCHING WORDS + +In addition the looking up word definitions, +you can lookup a list of words which match a given +pattern, using the B<match()> method. +Each DICT server typically supports a number of I<strategies> +which can be used to match words against a pattern. +For example, using B<prefix> strategy with a pattern "anti" +would find all words in databases which start with "anti": + + @mref = $dict->match('anti', 'prefix'); + foreach my $match (@{ $mref }) { + ($db, $word) = @{ $match }; + } + +Similarly the B<suffix> strategy is used to search for words +which end in a given pattern. +The B<strategies()> method is used to request a list of supported +strategies - see L<"METHODS"> for more details. + +=head2 SELECTING DATABASES + +By default Net::Dict will look in all databases on the DICT server. +This is specified with a special database name of C<*>. +You can specify the database(s) to search explicitly, +as additional arguments to the B<define> and B<match> methods: + + $dref = $dict->define('banana', 'wn', 'web1913'); + +Rather than specify the databases to use every time, +you can change the default from '*' using the C<setDicts> method: + + $dict->setDicts('wn', 'web1913'); + +Any subsequent calls to B<define> or B<match> will refer to these databases, +unless over-ridden with additional arguments to the method. +You can find out what databases are available on a server +using the C<dbs> method: + + %dbhash = $dict->dbs(); + +Each entry in the returned hash has the name of a database as the key, +and the corresponding title as the value. + +There is another special database name - C<!> - which says that +all databases should be searched, but as soon as a definition is +found, no further databases should be searched. + +=head1 CONSTRUCTOR + + $dict = Net::Dict->new (HOST [,OPTIONS]); + +This is the constructor for a new Net::Dict object. C<HOST> is the +name of the remote host on which a Dict server is running. +This is required, and must be an explicit host name. + +The constructor makes a connection to the remote DICT server, +and sends the CLIENT command, to identify the client to the server. + +B<Note:> previous versions let you give an empty string +for the hostname, resulting in selection of default hosts. +This behaviour is no longer supported. + +C<OPTIONS> are passed in a hash like fashion, using key and value pairs. +Possible options are: + +=over 4 + +=item B<Port> + +The port number to connect to on the remote machine for the +Dict connection (a default port number is 2628, according to RFC2229). + +=item B<Client> + +The string to send as the CLIENT identifier. +If not set, then a default identifier for Net::Dict is sent. + +=item B<Timeout> + +Sets the timeout for the connection, in seconds. +Defaults to 120. + +=item B<Debug> + +The debug level - a non-zero value will resulting in debugging +information being generated, particularly when errors occur. +Can be changed later using the C<debug> method, +which is inherited from Net::Cmd. +More on the debug method can be found in L<Net::Cmd>. + +=back + +Making everything explicit, here's how you might call +the constructor in your client: + + $dict = Net::Dict->new($HOST, + Port => 2628, + Client => "myclient v$VERSION", + Timeout => 120, + Debug => 0); + +This will return C<undef> if we failed to make the connection. +It will C<die> if bad arguments are passed: no hostname, +unknown argument, etc. + +=head1 METHODS + +Unless otherwise stated all methods return either a I<true> or I<false> +value, with I<true> meaning that the operation was a success. When a method +states that it returns a value, failure will be returned as I<undef> or an +empty list. + + +=head2 define ( $word [, @dbs] ) + +returns a reference to an array, whose members are lists, +consisting of two elements: the dictionary name and the definition. +If no dictionaries are specified, those set by setDicts() are used. + + +=head2 match ( $pattern, $strategy [, @dbs] ) + +Looks for words which match $pattern according to the specified +matching $strategy. +Returns a reference to an array, +each entry of which is a reference to a two-element +array: database name, matching word. + +=head2 dbs + +Returns a hash with information on the databases available +on the DICT server. +The keys are the short names, or identifiers, of the databases; +the value is title of the database: + + %dbhash = $dict->dbs(); + print "Available dictionaries:\n"; + while (($db, $title) = each %dbhash) { + print "$db : $title\n"; + } + +This is the C<SHOW DATABASES> command from RFC 2229. + + +=head2 dbInfo ( $dbname ) + +Returns a string, containing description of +the dictionary $dbname. + + +=head2 setDicts ( @dicts ) + +Specify the dictionaries that will be +searched during the successive define() or match() calls. +Defaults to '*'. +No existance checks are performed by this interface, so you'd better make +sure the dictionaries you specify are on the server (e.g. by calling +dbs()). + + +=head2 strategies + +returns an array, containing an ID of a matching strategy +as a key and a verbose description as a value. + +This method was previously called strats(); +that name for the method is also currently supported, +for backwards compatibility. + +=head2 auth ( $USER, $PASSPHRASE ) + +Attempt to authenticate the specified user, using the scheme +described on page 18 of RFC 2229. +The user should be known to the server, and $PASSPHRASE +is a shared secret known only to the server and the user. + +For example, if you were using dictd from dict.org, +your configuration file might include the following: + + database private { + data "/usr/local/dictd/db/private.dict.dz" + index "/usr/local/dictd/db/private.index" + access { user connor } + } + + user connor "there can be only one" + +To be able to access this database, you'd write +something like the following: + + $dict = Net::Dict->new('dict.foobar.com'); + $dict->auth('connor', 'there can be only one'); + +A subsequent call to the C<databases> method would +reveal the C<private> database now accessible. +Not all servers support the AUTH extension; +you can check this with the has_capability() method, +described below. + + +=head2 serverInfo + +Returns a string, containing the information about the server, +provided by the server: + + print "Server Info:\n"; + print $dict->serverInfo(), "\n"; + +This is the C<SHOW SERVER> command from RFC 2229. + + +=head2 dbTitle ( $DBNAME ) + +Returns the title string for the specified database. +This is the same string returned by the C<dbs()> method +for all databases. + +=head2 capabilities + +Returns a list of the capabilities supported by the DICT server, +as described on pages 7 and 8 of RFC 2229. + +=head2 has_capability ( $cap_name ) + +Returns true (non-zero) if the DICT server supports the +specified capability; false (zero) otherwise. Eg + + if ($dict->has_capability('auth')) { + $dict->auth('genie', 'open sesame'); + } + +=head2 status + +Send the STATUS command to the DICT server, +which will return some server-specific timing +or debugging information. +This may be useful when debugging or tuning a DICT server, +but probably won't be of interest to most users. + + +=head1 KNOWN BUGS AND LIMITATIONS + +=over 4 + +=item * + +Need to add methods for getting lists of databases and strategies +in the order they're returned by the remote server. +Suggested by Aleksey Cheusov. + +=item * + +The following DICT commands are not currently supported: + + OPTION MIME + +=item * + +No support for firewalls at the moment. + +=item * + +Site-wide configuration isn't supported. Previous documentation +suggested that it was. + +=item * + +Currently no way to specify that results of define and match +should be in HTML. This was also previously a config option +for the constructor, but it didn't do anything. + +=back + +=head1 EXAMPLES + +The distribution includes two example DICT clients: +B<dict> is a basic command-line client, and B<tkdict> +is a GUI-based client, created using Perl/Tk. + +The B<examples> directory of the Net-Dict distribution +includes two basic examples. +C<simple.pl> illustrates basic use of the module, +and C<portuguese.pl> demos use of an English to Portuguese +dictionary. Thanks to Jose Joao Dias de Almeida for the examples. + +=head1 SEE ALSO + +L<RFC 2229|https://tools.ietf.org/html/rfc2229> - +the internet document which defines the DICT protocol. + +L<Net::Cmd> - +a module which provides methods for a network command class, +such as Net::FTP, Net::SMTP, as well as Net::Dict. +Part of the libnet distribution, available from CPAN. + +L<Digest::MD5> - +you'll need this module if you want to use the B<auth> method. + +L<dict.org|http://www.dict.org> - +the home page for the DICT effort; has links to other resources, +including other libraries and clients, and C<dictd>, +the reference DICT server. + + +=head1 REPOSITORY + +L<https://github.com/neilbowers/Net-Dict> + +=head1 AUTHOR + +The first version of Net::Dict was written by +Dmitry Rubinstein E<lt>dim...@wisdom.weizmann.ac.ile<gt>, +using Net::FTP and Net::SMTP as a pattern and a model for imitation. + +The module was extended, and is now maintained, by +Neil Bowers E<lt>n...@bowers.come<gt> + +=head1 COPYRIGHT + +Copyright (C) 2002-2014 Neil Bowers. All rights reserved. + +Copyright (C) 2001 Canon Research Centre Europe, Ltd. + +Copyright (c) 1998 Dmitry Rubinstein. All rights reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=cut + diff --git a/t/auth.test b/t/auth.test new file mode 100644 index 0000000..8ccc718 --- /dev/null +++ b/t/auth.test @@ -0,0 +1,211 @@ +#!./perl +# +# auth.test - Net::Dict testsuite for auth method +# +# this is not called auth.t because we don't want +# it run automatically when you run "make test". +# This testsuite requires a server configured +# correctly - ie like my test server here, which +# isn't publicly accessible. +# + +use Net::Dict; + +$^W = 1; + +my $HOST = 'dalek'; +my $PORT = 2628; + +my $WARNING; +my %TESTDATA; +my $section; +my $string; +my $dbinfo; + +print "1..9\n"; + +$SIG{__WARN__} = sub { $WARNING = join('', @_); }; + +#----------------------------------------------------------------------- +# Build the hash of test data from after the __DATA__ symbol +# at the end of this file +#----------------------------------------------------------------------- +while (<DATA>) +{ + if (/^==== END ====$/) + { + $section = undef; + next; + } + + if (/^==== (\S+) ====$/) + { + $section = $1; + $TESTDATA{$section} = ''; + next; + } + + next unless defined $section; + + $TESTDATA{$section} .= $_; +} + +#----------------------------------------------------------------------- +# Make sure we have HOST and PORT specified +#----------------------------------------------------------------------- +if (defined($HOST) && defined($PORT)) +{ + print "ok 1\n"; +} +else +{ + print "not ok 1\n"; +} + +#----------------------------------------------------------------------- +# connect to server +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new($HOST, Port => $PORT); }; +if (!$@ && defined $dict) +{ + print "ok 2\n"; +} +else +{ + print "not ok 2\n"; +} + +#----------------------------------------------------------------------- +# call dbs() with an argument - it doesn't take any, and should die +#----------------------------------------------------------------------- +eval { %dbhash = $dict->dbs('foo'); }; +if ($@ && $@ =~ /takes no arguments/) +{ + print "ok 3\n"; +} +else +{ + print "not ok 3\n"; +} + +#----------------------------------------------------------------------- +# METHOD: dbs +# get a list of database, render into a string, match to expected +#----------------------------------------------------------------------- +$string = ''; +eval { %dbhash = $dict->dbs(); }; +if (!$@ + && defined %dbhash + && do { foreach my $db (sort keys %dbhash) { $string .= "${db}:$dbhash{$db}\n"; }; 1; } + && $string eq $TESTDATA{dblist}) +{ + print "ok 4\n"; +} +else +{ + print "not ok 4\n"; +} + +#----------------------------------------------------------------------- +# METHOD: auth +# call with no arguments - should croak() +#----------------------------------------------------------------------- +if ($dict->can('auth') + && do { eval { $dict->auth(); }; 1;} + && $@ + && $@ =~ /takes two arguments/ + ) +{ + print "ok 5\n"; +} +else +{ + print "not ok 5\n"; +} + +#----------------------------------------------------------------------- +# METHOD: auth +# call with only one argument - should croak() +#----------------------------------------------------------------------- +if ($dict->can('auth') + && do { eval { $dict->auth('testuser'); }; 1;} + && $@ + && $@ =~ /takes two arguments/ + ) +{ + print "ok 6\n"; +} +else +{ + print "not ok 6\n"; +} + +#----------------------------------------------------------------------- +# METHOD: auth +# call with three arguments - should croak() +#----------------------------------------------------------------------- +$string = ''; +if ($dict->can('auth') + && do { eval { $dict->auth('testuser', 'open sesame', 'foobar'); }; 1;} + && $@ + && $@ =~ /takes two arguments/ + ) +{ + print "ok 7\n"; +} +else +{ + print "not ok 7\n"; +} + +#----------------------------------------------------------------------- +# METHOD: auth +# call with two valid arguments - should work ok +#----------------------------------------------------------------------- +$string = ''; +if ($dict->can('auth') + && do { eval { $dict->auth('testuser', 'open sesame'); }; 1;} + && !$@ + ) +{ + print "ok 8\n"; +} +else +{ + print "not ok 8\n"; +} + +#----------------------------------------------------------------------- +# METHOD: dbs +# get a list of database, render into a string, match to expected +#----------------------------------------------------------------------- +$string = ''; +eval { %dbhash = $dict->dbs(); }; +if (!$@ + && defined %dbhash + && do { foreach my $db (sort keys %dbhash) { $string .= "${db}:$dbhash{$db}\n"; }; 1; } + && $string eq $TESTDATA{'auth-dblist'}) +{ + print "ok 9\n"; +} +else +{ + print STDERR "AUTH test 9\n", + "expected \"", $TESTDATA{'auth-dblist'}, "\", got\n\"$string\"\n"; + print "not ok 9\n"; +} + + +exit 0; + +__DATA__ +==== dblist ==== +elements:Elements database 20001107 +foldoc:The Free On-line Dictionary of Computing (13 Mar 01) +jargon:Jargon File (4.2.3, 23 NOV 2000) +==== auth-dblist ==== +devils:THE DEVIL'S DICTIONARY ((C)1911 Released April 15 1993) +elements:Elements database 20001107 +foldoc:The Free On-line Dictionary of Computing (13 Mar 01) +jargon:Jargon File (4.2.3, 23 NOV 2000) +==== END ==== diff --git a/t/connection.t b/t/connection.t new file mode 100644 index 0000000..1a4f8fe --- /dev/null +++ b/t/connection.t @@ -0,0 +1,293 @@ +#!./perl +# +# + +use Net::Dict; +use strict; +$^W = 1; + +use Test::More 0.88 tests => 17; +use Test::Differences qw/ eq_or_diff /; + +use lib 't/lib'; +use Net::Dict::TestConfig qw/ $TEST_HOST $TEST_PORT /; + +my $WARNING; +my %TESTDATA; +my $section; +my @caps; +my $description; +my $dict; +my $string; + +$SIG{__WARN__} = sub { $WARNING = join('', @_); }; + +#----------------------------------------------------------------------- +# Build the hash of test data from after the __DATA__ symbol +# at the end of this file +#----------------------------------------------------------------------- +while (<DATA>) +{ + if (/^==== END ====$/) { + $section = undef; + next; + } + + if (/^==== (\S+) ====$/) { + $section = $1; + $TESTDATA{$section} = ''; + next; + } + + next unless defined $section; + + $TESTDATA{$section} .= $_; +} + +#----------------------------------------------------------------------- +# Make sure we have HOST and PORT specified +#----------------------------------------------------------------------- +ok(defined($TEST_HOST) && defined($TEST_PORT), "have a HOST and PORT defined"); + +#----------------------------------------------------------------------- +# constructor with no arguments - should result in a die() +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new(); }; +ok((not defined $dict) && $@ =~ /takes at least a HOST/, + "Not passing a DICT server name should croak"); + +#----------------------------------------------------------------------- +# pass a hostname of 'undef' we should get undef back +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new(undef); }; +ok((not defined($dict)), + "passing undef for hostname should fail"); + +#----------------------------------------------------------------------- +# pass a hostname of empty string, should get undef back +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new(''); }; +ok(!$@ && !defined($dict), + "Passing an empty hostname should result in undef"); + +#----------------------------------------------------------------------- +# Ok hostname given, but unknown argument passed. +# => return undef +# => doesn't die +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new($TEST_HOST, Foo => 'Bar'); }; +ok($@ && !defined($dict) && $@ =~ /unknown argument/, + "passing an unknown argument to constructor should croak"); + +#----------------------------------------------------------------------- +# Ok hostname given, odd number of following arguments passed +# => return undef +# => doesn't die +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new($TEST_HOST, 'Foo'); }; +ok($@ =~ /odd number of arguments/, + "Odd number of arguments after hostname should croak"); + +#----------------------------------------------------------------------- +# Valid hostname and port - should succeed +#----------------------------------------------------------------------- +$WARNING = undef; +eval { $dict = Net::Dict->new($TEST_HOST, Port => $TEST_PORT); }; +ok(!$@ && defined $dict && !defined $WARNING, + "valid hostname and port to constructor should return object"); + +#----------------------------------------------------------------------- +# Check the serverinfo string. +# We compare this with what we expect to get from dict.org +# We strip off the first two lines, because they have time-varying +# information; but we make sure they're the lines we think they are. +#----------------------------------------------------------------------- +$description = "check serverinfo string"; +my $serverinfo = $dict->serverInfo(); +if (exists $TESTDATA{serverinfo} + && defined($serverinfo) + && do { $serverinfo =~ s/^dictd.*?\n//s} + && do { $serverinfo =~ s/^On pan\.alephnull\.com.*?[\n\r]+//s} + ) +{ + eq_or_diff($serverinfo, $TESTDATA{serverinfo}, $description); +} +else { + fail($description); +} + +#----------------------------------------------------------------------- +# METHOD: status +# call with an argument - should die since it takes no args. +#----------------------------------------------------------------------- +eval { $string = $dict->status('foo'); }; +ok ($@ && $@ =~ /takes no arguments/, + "status() with an argument should croak"); + +#----------------------------------------------------------------------- +# METHOD: status +# call with no args, and check that the general format of the string +# is what we expect +#----------------------------------------------------------------------- +eval { $string = $dict->status(); }; +ok(!$@ && defined $string && $string =~ m!^status \[d/m/c.*\]$!, + "status() with no args should result in a particular format string"); + +#----------------------------------------------------------------------- +# METHOD: capabilities +# call with an arg - doesn't take any, and should die +#----------------------------------------------------------------------- +eval { @caps = $dict->capabilities('foo'); }; +ok($@ && $@ =~ /takes no arguments/, + "passing an argument when getting capabilities should croak"); + +#----------------------------------------------------------------------- +# METHOD: capabilities +#----------------------------------------------------------------------- +$description = "capabilities() should return a lit of them"; +if ($dict->can('capabilities') + && eval { @caps = $dict->capabilities(); } + && !$@ + && @caps > 0 + && do { $string = join(':', sort(@caps)); 1;} + ) +{ + eq_or_diff($string."\n", $TESTDATA{'capabilities'}, $description); +} +else { + fail($description); +} + +#----------------------------------------------------------------------- +# METHOD: has_capability +# no argument passed +#----------------------------------------------------------------------- +ok($dict->can('has_capability') + && do { eval { $dict->has_capability(); }; 1;} + && $@ + && $@ =~ /takes one argument/, + "no argument passed to has_capability() should croak"); + +#----------------------------------------------------------------------- +# METHOD: has_capability +# pass two capability names - should also die() +#----------------------------------------------------------------------- +ok($dict->can('has_capability') + && do { eval { $dict->has_capability('mime', 'auth'); }; 1; } + && $@ + && $@ =~ /takes one argument/, + "passing to arguments to has_capability() should croak"); + +#----------------------------------------------------------------------- +# METHOD: has_capability +#----------------------------------------------------------------------- +ok($dict->can('has_capability') + && $dict->has_capability('mime') + && $dict->has_capability('auth') + && !$dict->has_capability('foobar'), + "check valid use of has_capability()"); + +#----------------------------------------------------------------------- +# METHOD: msg_id +# with an argument - should cause it to die() +#----------------------------------------------------------------------- +ok($dict->can('msg_id') + && do { eval { $string = $dict->msg_id('dict.org'); }; 1;} + && $@ + && $@ =~ /takes no arguments/, + "Passing an argument to msg_id() should croak"); + +#----------------------------------------------------------------------- +# METHOD: msg_id +# with no arguments, should get valid id back, of the form <...> +#----------------------------------------------------------------------- +ok($dict->can('msg_id') + && do { eval { $string = $dict->msg_id(); }; 1;} + && !$@ + && defined($string) + && $string =~ /^<[^<>]+>$/, + "calling msg_id() with no arguments should return id of form <...>"); + + +exit 0; + +__DATA__ +==== serverinfo ==== +Database Headwords Index Data Uncompressed +gcide 203645 3859 kB 12 MB 38 MB +wn 147311 3002 kB 9247 kB 29 MB +moby-thesaurus 30263 528 kB 10 MB 28 MB +elements 142 2 kB 17 kB 53 kB +vera 11877 135 kB 222 kB 735 kB +jargon 2314 40 kB 577 kB 1432 kB +foldoc 15031 298 kB 2198 kB 5379 kB +easton 3968 64 kB 1077 kB 2648 kB +hitchcock 2619 34 kB 33 kB 85 kB +bouvier 6797 128 kB 2338 kB 6185 kB +devil 1008 15 kB 161 kB 374 kB +world02 280 5 kB 1543 kB 7172 kB +gaz2k-counties 12875 269 kB 280 kB 1502 kB +gaz2k-places 51361 1006 kB 1711 kB 13 MB +gaz2k-zips 33249 454 kB 2122 kB 15 MB +--exit-- 0 0 kB 0 kB 0 kB +fd-tur-eng 1032 14 kB 11 kB 24 kB +fd-por-deu 8300 124 kB 110 kB 276 kB +fd-nld-eng 22753 378 kB 366 kB 991 kB +fd-eng-ara 87430 1404 kB 721 kB 2489 kB +fd-spa-eng 4508 67 kB 77 kB 190 kB +fd-eng-hun 89685 1907 kB 2158 kB 5876 kB +fd-ita-eng 3435 48 kB 37 kB 92 kB +fd-wel-eng 734 9 kB 7 kB 17 kB +fd-eng-nld 7720 119 kB 168 kB 446 kB +fd-fra-eng 8511 131 kB 138 kB 385 kB +fd-tur-deu 947 13 kB 11 kB 24 kB +fd-swe-eng 5226 71 kB 52 kB 128 kB +fd-nld-fra 16776 270 kB 249 kB 672 kB +fd-eng-swa 1458 18 kB 11 kB 37 kB +fd-deu-nld 12818 200 kB 192 kB 524 kB +fd-fra-deu 6120 90 kB 108 kB 275 kB +fd-eng-cro 59211 1220 kB 971 kB 2706 kB +fd-eng-ita 4525 59 kB 40 kB 108 kB +fd-eng-lat 3032 40 kB 39 kB 100 kB +fd-lat-eng 2311 31 kB 24 kB 62 kB +fd-fra-nld 9610 152 kB 195 kB 502 kB +fd-ita-deu 2929 40 kB 37 kB 87 kB +fd-eng-hin 25648 418 kB 1041 kB 3019 kB +fd-deu-eng 81622 1613 kB 1346 kB 4176 kB +fd-por-eng 10667 164 kB 125 kB 315 kB +fd-lat-deu 7342 107 kB 105 kB 365 kB +fd-jpn-deu 447 5 kB 6 kB 12 kB +fd-eng-deu 93279 1708 kB 1403 kB 4212 kB +fd-eng-scr 605 7 kB 8 kB 21 kB +fd-eng-rom 996 14 kB 12 kB 31 kB +fd-iri-eng 1191 16 kB 11 kB 28 kB +fd-cze-eng 494 6 kB 5 kB 11 kB +fd-scr-eng 401 6 kB 4 kB 11 kB +fd-eng-cze 150010 2482 kB 1463 kB 8478 kB +fd-eng-rus 1699 23 kB 26 kB 71 kB +fd-afr-deu 3806 52 kB 49 kB 129 kB +fd-eng-por 15854 248 kB 239 kB 634 kB +fd-hun-eng 139941 3343 kB 2244 kB 6184 kB +fd-eng-swe 5485 71 kB 75 kB 191 kB +fd-deu-ita 4460 64 kB 38 kB 99 kB +fd-cro-eng 79821 1791 kB 1016 kB 2899 kB +fd-dan-eng 4003 54 kB 43 kB 103 kB +fd-eng-tur 36595 580 kB 1687 kB 4214 kB +fd-eng-spa 5913 76 kB 81 kB 217 kB +fd-nld-deu 17230 278 kB 306 kB 827 kB +fd-deu-por 8748 130 kB 104 kB 270 kB +fd-swa-eng 1554 19 kB 13 kB 43 kB +fd-hin-eng 32971 1227 kB 1062 kB 3274 kB +fd-deu-fra 8174 120 kB 81 kB 216 kB +fd-eng-fra 8805 129 kB 137 kB 361 kB +fd-slo-eng 833 11 kB 9 kB 20 kB +fd-gla-deu 263 3 kB 4 kB 7 kB +fd-eng-wel 1066 13 kB 12 kB 31 kB +fd-eng-iri 1365 17 kB 18 kB 45 kB +english 0 0 kB 0 kB 0 kB +trans 0 0 kB 0 kB 0 kB +all 0 0 kB 0 kB 0 kB + +==== capabilities ==== +auth:mime +==== END ==== diff --git a/t/database.t b/t/database.t new file mode 100644 index 0000000..c664c6d --- /dev/null +++ b/t/database.t @@ -0,0 +1,290 @@ +#!./perl +# +# database.t - Net::Dict testsuite for database related methods +# + +use Test::More 0.88 tests => 13; +use Test::Differences qw/ eq_or_diff /; +use Net::Dict; +use lib 't/lib'; +use Net::Dict::TestConfig qw/ $TEST_HOST $TEST_PORT /; + +$^W = 1; + +my $WARNING; +my %TESTDATA; +my $section; +my $string; +my $dbinfo; +my $title; + +$SIG{__WARN__} = sub { $WARNING = join('', @_); }; + +#----------------------------------------------------------------------- +# Build the hash of test data from after the __DATA__ symbol +# at the end of this file +#----------------------------------------------------------------------- +while (<DATA>) { + if (/^==== END ====$/) { + $section = undef; + next; + } + + if (/^==== (\S+) ====$/) { + $section = $1; + $TESTDATA{$section} = ''; + next; + } + + next unless defined $section; + + $TESTDATA{$section} .= $_; +} + +#----------------------------------------------------------------------- +# Make sure we have HOST and PORT specified +#----------------------------------------------------------------------- +ok(defined($TEST_HOST) && defined($TEST_PORT), + "Do we have a test host and port?"); + +#----------------------------------------------------------------------- +# connect to server +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new($TEST_HOST, Port => $TEST_PORT); }; +ok(!$@ && defined $dict, "Connect to DICT server"); + +#----------------------------------------------------------------------- +# call dbs() with an argument - it doesn't take any, and should die +#----------------------------------------------------------------------- +eval { %dbhash = $dict->dbs('foo'); }; +ok($@ && $@ =~ /takes no arguments/, "dbs() with an argument should croak"); + +#----------------------------------------------------------------------- +# pass a hostname of empty string, should get undef back +#----------------------------------------------------------------------- +$string = ''; +$title = "Check list of database names"; +eval { %dbhash = $dict->dbs(); }; +if (!$@ + && %dbhash + && do { foreach my $db (sort keys %dbhash) { $string .= "${db}:$dbhash{$db}\n"; }; 1; }) +{ + eq_or_diff($string, $TESTDATA{dblist}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# call dbInfo() method with no arguments +#----------------------------------------------------------------------- +$dbinfo = undef; +eval { $dbinfo = $dict->dbInfo(); }; +ok($@ && $@ =~ /one argument only/, "dbInfo() with no arguments should croak"); + +#----------------------------------------------------------------------- +# call dbInfo() method with more than one argument +#----------------------------------------------------------------------- +$dbinfo = undef; +eval { $dbinfo = $dict->dbInfo('wn', 'web1913'); }; +ok($@ && $@ =~ /one argument only/, "dbInfo() with more than one argument should croak"); + +#----------------------------------------------------------------------- +# call dbInfo() method with one argument, but it's a non-existent DB +#----------------------------------------------------------------------- +$dbinfo = undef; +eval { $dbinfo = $dict->dbInfo('web1651'); }; +ok(!$@ && !defined($dbinfo), "dbInfo() on a non-existent DB should return undef"); + +#----------------------------------------------------------------------- +# get the database info for the wordnet db, and compare with expected +#----------------------------------------------------------------------- +$string = ''; +$dbinfo = undef; +$title = "Do we get expected DB info for wordnet?"; +eval { $dbinfo = $dict->dbInfo('wn'); }; +if (!$@ + && defined($dbinfo)) +{ + eq_or_diff($dbinfo, $TESTDATA{'dbinfo-wn'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: dbTitle +# Call method with no arguments - should result in die() +#----------------------------------------------------------------------- +eval { $string = $dict->dbTitle(); }; +ok($@ && $@ =~ /method expects one argument/, "dbTitle() with no arguments should croak"); + +#----------------------------------------------------------------------- +# METHOD: dbTitle +# Call method with too many arguments - should result in die() +#----------------------------------------------------------------------- +eval { $string = $dict->dbTitle('wn', 'foldoc'); }; +ok($@ && $@ =~ /method expects one argument/, "dbTitle() with more than one argument should croak"); + +#----------------------------------------------------------------------- +# METHOD: dbTitle +# Call method with non-existent DB - should result in undef +#----------------------------------------------------------------------- +$WARNING = ''; +eval { $string = $dict->dbTitle('web1651'); }; +ok(!$@ && !defined($string), "dbTitle() on a non-existent DB should return undef"); + +#----------------------------------------------------------------------- +# METHOD: dbTitle +# Call method with non-existent DB - should result in undef +# We set debug level to 1, should result in a warning message as +# well as undef. The Net::Cmd::debug() line is needed to suppress +# some verbosity from Net::Cmd when we turn on debugging. +# This is done so that the "make test" *looks* clean as well as being clean. +#----------------------------------------------------------------------- +Net::Dict->debug(0); +$dict->debug(1); +$WARNING = ''; +eval { $string = $dict->dbTitle('web1651'); }; +ok(!$@ && !defined($string) && $WARNING =~ /unknown database/, + "dbTitle on a non-existent database name should return undef"); +$dict->debug(0); + +#----------------------------------------------------------------------- +# METHOD: dbTitle +# Call method with an OK DB name +#----------------------------------------------------------------------- +$title = "check dbTitle() on wordnet"; +eval { $string = $dict->dbTitle('wn'); }; +if (!$@ && defined($string)) { + eq_or_diff($string."\n", $TESTDATA{'dbtitle-wn'}, $title); +} +else { + fail($title); +} + +exit 0; + +__DATA__ +==== dblist ==== +all:All Dictionaries (English-Only and Translating) +bouvier:Bouvier's Law Dictionary, Revised 6th Ed (1856) +devil:The Devil's Dictionary (1881-1906) +easton:Easton's 1897 Bible Dictionary +elements:The Elements (07Nov00) +english:English Monolingual Dictionaries +fd-afr-deu:Afrikaans-German FreeDict Dictionary ver. 0.3 +fd-cro-eng:Croatian-English Freedict Dictionary +fd-cze-eng:Czech-English Freedict dictionary +fd-dan-eng:Danish-English FreeDict Dictionary ver. 0.2.1 +fd-deu-eng:German-English FreeDict Dictionary ver. 0.3.3 +fd-deu-fra:German-French FreeDict Dictionary ver. 0.3.1 +fd-deu-ita:German-Italian FreeDict Dictionary ver. 0.1.1 +fd-deu-nld:German-Dutch FreeDict Dictionary ver. 0.1.1 +fd-deu-por:German-Portuguese FreeDict Dictionary ver. 0.2.1 +fd-eng-ara:English-Arabic FreeDict Dictionary ver. 0.6.2 +fd-eng-cro:English-Croatian Freedict Dictionary +fd-eng-cze:English-Czech fdicts/FreeDict Dictionary +fd-eng-deu:English-German FreeDict Dictionary ver. 0.3.5 +fd-eng-fra:English-French FreeDict Dictionary ver. 0.1.4 +fd-eng-hin:English-Hindi FreeDict Dictionary ver. 1.5.1 +fd-eng-hun:English-Hungarian FreeDict Dictionary ver. 0.1 +fd-eng-iri:English-Irish Freedict dictionary +fd-eng-ita:English-Italian FreeDict Dictionary ver. 0.1.1 +fd-eng-lat:English-Latin FreeDict Dictionary ver. 0.1.1 +fd-eng-nld:English-Dutch FreeDict Dictionary ver. 0.1.1 +fd-eng-por:English-Portuguese FreeDict Dictionary ver. 0.2.2 +fd-eng-rom:English-Romanian FreeDict Dictionary ver. 0.6.1 +fd-eng-rus:English-Russian FreeDict Dictionary ver. 0.3 +fd-eng-scr:English-Serbo-Croat Freedict dictionary +fd-eng-spa:English-Spanish FreeDict Dictionary ver. 0.2.1 +fd-eng-swa:English-Swahili xFried/FreeDict Dictionary +fd-eng-swe:English-Swedish FreeDict Dictionary ver. 0.1.1 +fd-eng-tur:English-Turkish FreeDict Dictionary ver. 0.2.1 +fd-eng-wel:English-Welsh Freedict dictionary +fd-fra-deu:French-German FreeDict Dictionary ver. 0.1.1 +fd-fra-eng:French-English FreeDict Dictionary ver. 0.3.4 +fd-fra-nld:French-Dutch FreeDict Dictionary ver. 0.1.2 +fd-gla-deu:Scottish Gaelic-German FreeDict Dictionary ver. 0.1.1 +fd-hin-eng:English-Hindi Freedict Dictionary [reverse index] +fd-hun-eng:Hungarian-English FreeDict Dictionary ver. 0.3 +fd-iri-eng:Irish-English Freedict dictionary +fd-ita-deu:Italian-German FreeDict Dictionary ver. 0.1.1 +fd-ita-eng:Italian-English FreeDict Dictionary ver. 0.1.1 +fd-jpn-deu:Japanese-German FreeDict Dictionary ver. 0.1.1 +fd-lat-deu:Latin - German FreeDict dictionary ver. 0.4 +fd-lat-eng:Latin-English FreeDict Dictionary ver. 0.1.1 +fd-nld-deu:Dutch-German FreeDict Dictionary ver. 0.1.1 +fd-nld-eng:Dutch-English Freedict Dictionary ver. 0.1.3 +fd-nld-fra:Nederlands-French FreeDict Dictionary ver. 0.1.1 +fd-por-deu:Portuguese-German FreeDict Dictionary ver. 0.1.1 +fd-por-eng:Portuguese-English FreeDict Dictionary ver. 0.1.1 +fd-scr-eng:Serbo-Croat-English Freedict dictionary +fd-slo-eng:Slovak-English Freedict dictionary +fd-spa-eng:Spanish-English FreeDict Dictionary ver. 0.1.1 +fd-swa-eng:Swahili-English xFried/FreeDict Dictionary +fd-swe-eng:Swedish-English FreeDict Dictionary ver. 0.1.1 +fd-tur-deu:Turkish-German FreeDict Dictionary ver. 0.1.1 +fd-tur-eng:Turkish-English FreeDict Dictionary ver. 0.2.1 +fd-wel-eng:Welsh-English Freedict dictionary +foldoc:The Free On-line Dictionary of Computing (20 July 2014) +gaz2k-counties:U.S. Gazetteer Counties (2000) +gaz2k-places:U.S. Gazetteer Places (2000) +gaz2k-zips:U.S. Gazetteer Zip Code Tabulation Areas (2000) +gcide:The Collaborative International Dictionary of English v.0.48 +hitchcock:Hitchcock's Bible Names Dictionary (late 1800's) +jargon:The Jargon File (version 4.4.7, 29 Dec 2003) +moby-thesaurus:Moby Thesaurus II by Grady Ward, 1.0 +trans:Translating Dictionaries +vera:V.E.R.A. -- Virtual Entity of Relevant Acronyms (January 2014) +wn:WordNet (r) 3.0 (2006) +world02:CIA World Factbook 2002 +==== dbtitle-wn ==== +WordNet (r) 3.0 (2006) +==== dbinfo-wn ==== +============ wn ============ +00-database-info +This file was converted from the original database on: + 2014-04-17T12:33:52 + +The original data is available from: + ftp://ftp.cogsci.princeton.edu/pub/wordnet/2.0 + +The original data was distributed with the notice shown below. No +additional restrictions are claimed. Please redistribute this changed +version under the same conditions and restriction that apply to the +original version. + + +This software and database is being provided to you, the LICENSEE, by +Princeton University under the following license. By obtaining, using +and/or copying this software and database, you agree that you have +read, understood, and will comply with these terms and conditions.: + +Permission to use, copy, modify and distribute this software and +database and its documentation for any purpose and without fee or +royalty is hereby granted, provided that you agree to comply with +the following copyright notice and statements, including the disclaimer, +and that the same appear on ALL copies of the software, database and +documentation, including modifications that you make for internal +use or for distribution. + +WordNet 3.0 Copyright 2006 by Princeton University. All rights reserved. + +THIS SOFTWARE AND DATABASE IS PROVIDED "AS IS" AND PRINCETON +UNIVERSITY MAKES NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR +IMPLIED. BY WAY OF EXAMPLE, BUT NOT LIMITATION, PRINCETON +UNIVERSITY MAKES NO REPRESENTATIONS OR WARRANTIES OF MERCHANT- +ABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR THAT THE USE +OF THE LICENSED SOFTWARE, DATABASE OR DOCUMENTATION WILL NOT +INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR +OTHER RIGHTS. + +The name of Princeton University or Princeton may not be used in +advertising or publicity pertaining to distribution of the software +and/or database. Title to copyright in this software, database and +any associated documentation shall at all times remain with +Princeton University and LICENSEE agrees to preserve same. + + +==== END ==== diff --git a/t/define.t b/t/define.t new file mode 100644 index 0000000..5c8e17e --- /dev/null +++ b/t/define.t @@ -0,0 +1,454 @@ +#!./perl +# +# define.t - Net::Dict testsuite for define() method +# + +use Test::More 0.88 tests => 16; +use Net::Dict; +use lib 't/lib'; +use Net::Dict::TestConfig qw/ $TEST_HOST $TEST_PORT /; + +$^W = 1; + +my $WARNING; +my %TESTDATA; +my $defref; +my $section; +my $string; +my $dbinfo; +my $title; + +$SIG{__WARN__} = sub { $WARNING = join('', @_); }; + +#----------------------------------------------------------------------- +# Build the hash of test data from after the __DATA__ symbol +# at the end of this file +#----------------------------------------------------------------------- +while (<DATA>) { + if (/^==== END ====$/) { + $section = undef; + next; + } + + if (/^==== (\S+) ====$/) { + $section = $1; + $TESTDATA{$section} = ''; + next; + } + + next unless defined $section; + + $TESTDATA{$section} .= $_; +} + +#----------------------------------------------------------------------- +# Make sure we have HOST and PORT specified +#----------------------------------------------------------------------- +ok(defined($TEST_HOST) && defined($TEST_PORT), + "do we have test host and port"); + +#----------------------------------------------------------------------- +# connect to server +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new($TEST_HOST, Port => $TEST_PORT); }; +ok(!$@ && defined $dict, "connect to DICT server"); + +#----------------------------------------------------------------------- +# call define() with no arguments - should die +#----------------------------------------------------------------------- +eval { $defref = $dict->define(); }; +ok($@ && $@ =~ /takes at least one argument/, + "define() with no arguments should croak"); + +#----------------------------------------------------------------------- +# try and get a definition of something which won't have a definition +# note: at this point we're using the default of '*' for dicts - ie all +#----------------------------------------------------------------------- +eval { $defref = $dict->define('asdfghijkl'); }; +ok(!$@ && defined $defref && int(@{$defref}) == 0, + "requesting a definition for a non-existent word should return no entries"); + +#----------------------------------------------------------------------- +# METHOD: define +# get definitions for biscuit, using the default of '*' for DBs +#----------------------------------------------------------------------- +$string = ''; +$title = "do we get expected definitions for 'biscuit'"; +eval { $defref = $dict->define('biscuit'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $entry->[1] =~ s/\r//sg; + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'*-biscuit'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# get definitions for biscuit, having set user dbs to (), and not +# giving any as args - should croak +#----------------------------------------------------------------------- +$dict->setDicts(); +eval { $defref = $dict->define('biscuit'); }; +ok($@ && $@ =~ /select some dictionaries/, + "calling define() after selecting empty DB list should croak"); + +#----------------------------------------------------------------------- +# METHOD: define +# get definitions for biscuit, specifying '*' explicitly for dicts +#----------------------------------------------------------------------- +$string = ''; +$title = "check definitions for 'biscuit', setting '*' for DBs"; +eval { $defref = $dict->define('biscuit', '*'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $entry->[1] =~ s/\r//sg; + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'*-biscuit'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# get definitions for biscuit, specifying '!' explicitly for dicts +#----------------------------------------------------------------------- +$string = ''; +$title = "check result for 'biscuit' with DB set to '!'"; +eval { $defref = $dict->define('biscuit', '!'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'!-biscuit'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# get definition for noun phrase (more than one word, separated +# by spaces), specifying all dicts ('*') +#----------------------------------------------------------------------- +$string = ''; +$title = "Test results for noun phrase, with dicts set to '*'"; +eval { $defref = $dict->define('antispasmodic agent', '*'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'*-antispasmodic_agent'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# get definition a something containing an apostrophe ("ko'd") +# specifying all dicts ('*') +#----------------------------------------------------------------------- +$string = ''; +$title = "get definition for a word containing an apostrophe"; +eval { $defref = $dict->define("ko'd", '*'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'*-kod'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# get definition of something with apostrophe and a space. +# specifying all dicts ('*') +#----------------------------------------------------------------------- +$string = ''; +$title = "get definition of a noun phrase containing an apostrophe"; +eval { $defref = $dict->define("oboe d'amore", '*'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'*-oboe_damore'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# Very long entry, which also happens to have multiple spaces +#----------------------------------------------------------------------- +$string = ''; +$title = "test getting definition for very long entry, with spaces"; +eval { $defref = $dict->define("Pityrogramma calomelanos aureoflava", '*'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'*-pityrogramma_calomelanos_aureoflava'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# Valid word, invalid dbname - should return no entries +#----------------------------------------------------------------------- +eval { $defref = $dict->define('banana', 'web1651'); }; +ok(!$@ && defined($defref) && int(@{$defref}) == 0, + "valid word, invalid db name, should return 0 entries"); + +#----------------------------------------------------------------------- +# METHOD: define +# Call setDicts to select web1913, but then explicitly specify +# "wn" as the dictionary to search when calling define. +# the word ("banana") is in both dictionaries, but we should only +# get the definition for wn +#----------------------------------------------------------------------- +$string = ''; +$title = "search for a word, with DB passed to define()"; +$dict->setDicts('web1913'); +eval { $defref = $dict->define('banana', 'wn'); }; +if (!$@ + && defined($defref) + && do { + foreach my $entry (sort {$a->[0] cmp $b->[0]} @{ $defref }) + { + $string .= $entry->[0]."\n"; + $string .= $entry->[1]; + } + 1; + }) +{ + is($string, $TESTDATA{'wn-banana'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: define +# Call define, passing undef for the word, and '*' for dicts +#----------------------------------------------------------------------- +$WARNING = ''; +eval { $defref = $dict->define(undef, '*'); }; +ok(!$@ && !defined($defref) + && $WARNING =~ /empty word passed to define/, + "passing undef for the word should return undef"); + +#----------------------------------------------------------------------- +# METHOD: define +# Call define, passing empty string for the word, and '*' for dicts +#----------------------------------------------------------------------- +$WARNING = ''; +eval { $defref = $dict->define('', '*'); }; +ok(!$@ + && !defined($defref) + && $WARNING =~ /empty word passed to define/, + "passing an empty string returns undef"); + + +exit 0; + +__DATA__ +==== *-biscuit ==== +gcide +Biscuit \Bis"cuit\, n. [F. biscuit (cf. It. biscotto, Sp. + bizcocho, Pg. biscouto), fr. L. bis twice + coctus, p. p. of + coquere to cook, bake. See {Cook}, and cf. {Bisque} a kind of + porcelain.] + 1. A kind of unraised bread, of many varieties, plain, sweet, + or fancy, formed into flat cakes, and bakes hard; as, ship + biscuit. + [1913 Webster] + + According to military practice, the bread or biscuit + of the Romans was twice prepared in the oven. + --Gibbon. + [1913 Webster] + + 2. A small loaf or cake of bread, raised and shortened, or + made light with soda or baking powder. Usually a number + are baked in the same pan, forming a sheet or card. + [1913 Webster] + + 3. Earthen ware or porcelain which has undergone the first + baking, before it is subjected to the glazing. + [1913 Webster] + + 4. (Sculp.) A species of white, unglazed porcelain, in which + vases, figures, and groups are formed in miniature. + [1913 Webster] + + {Meat biscuit}, an alimentary preparation consisting of + matters extracted from meat by boiling, or of meat ground + fine and combined with flour, so as to form biscuits. + [1913 Webster] +moby-thesaurus +52 Moby Thesaurus words for "biscuit": + Brussels biscuit, Melba toast, adobe, bisque, bone, bowl, brick, + brownie, cement, ceramic ware, ceramics, china, cookie, cracker, + crock, crockery, date bar, dust, enamelware, firebrick, fruit bar, + ginger snap, gingerbread man, glass, graham cracker, hardtack, jug, + ladyfinger, macaroon, mummy, parchment, pilot biscuit, porcelain, + pot, pottery, pretzel, refractory, rusk, saltine, sea biscuit, + ship biscuit, shortbread, sinker, soda cracker, stick, + sugar cookie, tile, tiling, urn, vase, wafer, zwieback + + +wn +biscuit + n 1: small round bread leavened with baking-powder or soda + 2: any of various small flat sweet cakes (`biscuit' is the + British term) [syn: {cookie}, {cooky}, {biscuit}] +==== !-biscuit ==== +gcide +Biscuit \Bis"cuit\, n. [F. biscuit (cf. It. biscotto, Sp. + bizcocho, Pg. biscouto), fr. L. bis twice + coctus, p. p. of + coquere to cook, bake. See {Cook}, and cf. {Bisque} a kind of + porcelain.] + 1. A kind of unraised bread, of many varieties, plain, sweet, + or fancy, formed into flat cakes, and bakes hard; as, ship + biscuit. + [1913 Webster] + + According to military practice, the bread or biscuit + of the Romans was twice prepared in the oven. + --Gibbon. + [1913 Webster] + + 2. A small loaf or cake of bread, raised and shortened, or + made light with soda or baking powder. Usually a number + are baked in the same pan, forming a sheet or card. + [1913 Webster] + + 3. Earthen ware or porcelain which has undergone the first + baking, before it is subjected to the glazing. + [1913 Webster] + + 4. (Sculp.) A species of white, unglazed porcelain, in which + vases, figures, and groups are formed in miniature. + [1913 Webster] + + {Meat biscuit}, an alimentary preparation consisting of + matters extracted from meat by boiling, or of meat ground + fine and combined with flour, so as to form biscuits. + [1913 Webster] +==== *-antispasmodic_agent ==== +wn +antispasmodic agent + n 1: a drug used to relieve or prevent spasms (especially of the + smooth muscles) [syn: {antispasmodic}, {spasmolytic}, + {antispasmodic agent}] +==== *-oboe_damore ==== +gcide +Oboe \O"boe\, n. [It., fr. F. hautbois. See {Hautboy}.] (Mus.) + One of the higher wind instruments in the modern orchestra, + yet of great antiquity, having a penetrating pastoral quality + of tone, somewhat like the clarinet in form, but more + slender, and sounded by means of a double reed; a hautboy. + [1913 Webster] + + {Oboe d'amore} [It., lit., oboe of love], and {Oboe di + caccia} [It., lit., oboe of the chase], are names of obsolete + modifications of the oboe, often found in the scores of + Bach and Handel. + [1913 Webster] +wn +oboe d'amore + n 1: an oboe pitched a minor third lower than the ordinary oboe; + used to perform baroque music +==== *-kod ==== +gcide +KO \KO\ v. t. [imp. & p. p. {KO'd}; p. pr. & vb. n. {KO'ing}.] + To knock out; to deliver a blow that renders (the opponent) + unconscious; -- used especially in boxing. [acronym] + + Syn: knockout. + [WordNet 1.5] +gcide +KO'd \KO'd\ adj. [from {KO}, v. t.] + rendered unconscious, usually by a blow. + + Syn: knocked out(predicate), kayoed, out(predicate), stunned. + [WordNet 1.5] +wn +KO'd + adj 1: knocked unconscious by a heavy blow [syn: {knocked + out(p)}, {kayoed}, {KO'd}, {out(p)}, {stunned}] +==== *-pityrogramma_calomelanos_aureoflava ==== +wn +Pityrogramma calomelanos aureoflava + n 1: tropical American fern having fronds with light golden + undersides [syn: {golden fern}, {Pityrogramma calomelanos + aureoflava}] +==== wn-banana ==== +wn +banana + n 1: any of several tropical and subtropical treelike herbs of + the genus Musa having a terminal crown of large entire + leaves and usually bearing hanging clusters of elongated + fruits [syn: {banana}, {banana tree}] + 2: elongated crescent-shaped yellow fruit with soft sweet flesh +==== END ==== diff --git a/t/lib/Net/Dict/TestConfig.pm b/t/lib/Net/Dict/TestConfig.pm new file mode 100644 index 0000000..f93855b --- /dev/null +++ b/t/lib/Net/Dict/TestConfig.pm @@ -0,0 +1,10 @@ +package Net::Dict::TestConfig; + +use parent 'Exporter'; + +our @EXPORT_OK = qw($TEST_HOST $TEST_PORT); + +our $TEST_HOST = 'dict.org'; +our $TEST_PORT = 2628; + +1; diff --git a/t/match.t b/t/match.t new file mode 100644 index 0000000..0da35d5 --- /dev/null +++ b/t/match.t @@ -0,0 +1,537 @@ +#!./perl +# +# match.t - Net::Dict testsuite for match() method +# + +use Test::More 0.88 tests => 15; +use Test::Differences qw/ eq_or_diff /; +use Net::Dict; +use lib 't/lib'; +use Net::Dict::TestConfig qw/ $TEST_HOST $TEST_PORT /; +use Env qw($VERBOSE); + +$^W = 1; + +my $WARNING; +my %TESTDATA; +my $defref; +my $section; +my $string; +my $dbinfo; +my %strathash; +my $title; + +if (defined $VERBOSE && $VERBOSE==1) { + print STDERR "\nVERBOSE ON\n"; +} + +$SIG{__WARN__} = sub { $WARNING = join('', @_); }; + +#----------------------------------------------------------------------- +# Build the hash of test data from after the __DATA__ symbol +# at the end of this file +#----------------------------------------------------------------------- +while (<DATA>) +{ + if (/^==== END ====$/) { + $section = undef; + next; + } + + if (/^==== (\S+) ====$/) { + $section = $1; + $TESTDATA{$section} = ''; + next; + } + + next unless defined $section; + + $TESTDATA{$section} .= $_; +} + +#----------------------------------------------------------------------- +# Make sure we have HOST and PORT specified +#----------------------------------------------------------------------- +ok(defined($TEST_HOST) && defined($TEST_PORT), + "Do we have a test HOST and PORT?"); + +#----------------------------------------------------------------------- +# connect to server +#----------------------------------------------------------------------- +eval { $dict = Net::Dict->new($TEST_HOST, Port => $TEST_PORT); }; +ok(!$@ && defined($dict), "connect to DICT server"); + +#----------------------------------------------------------------------- +# call match() with no arguments - should die +#----------------------------------------------------------------------- +eval { $defref = $dict->match(); }; +ok($@ && $@ =~ /takes at least two arguments/, + "calling match() with no arguments should croak()"); + +#----------------------------------------------------------------------- +# call match() with one arguments - should die +#----------------------------------------------------------------------- +eval { $defref = $dict->match('banana'); }; +ok($@ && $@ =~ /takes at least two arguments/, + "match() with no argument should croak"); + +#----------------------------------------------------------------------- +# call match() with two arguments, but word is undef +#----------------------------------------------------------------------- +$WARNING = ''; +eval { $defref = $dict->match(undef, '*'); }; +ok(!$@ && !defined($defref) + && $WARNING =~ /empty pattern passed to match/, + "match() with 2 arguments, but word is undef, should return undef"); + +#----------------------------------------------------------------------- +# call match() with two arguments, but word is empty string +#----------------------------------------------------------------------- +$WARNING = ''; +eval { $defref = $dict->match('', '*'); }; +ok(!$@ + && !defined($defref) + && $WARNING =~ /empty pattern passed to match/, + "match() with 2 args but empty word should return undef"); + +#----------------------------------------------------------------------- +# get a list of supported strategies, render as string and compare +#----------------------------------------------------------------------- +$title = "do we get the expected list of strategies"; +$string = ''; +eval { %strathash = $dict->strategies(); }; +if (!$@ + && %strathash + && do { + foreach my $s (sort keys %strathash) + { + $string .= $s.':'.$strathash{$s}."\n"; + } + 1; + }) +{ + eq_or_diff($string, $TESTDATA{'strats'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# same as previous test, but using obsolete method name +#----------------------------------------------------------------------- +$title = "do we get the expected list of strats (back compat)"; +$string = ''; +eval { %strathash = $dict->strats(); }; +if (!$@ + && %strathash + && do { + foreach my $s (sort keys %strathash) + { + $string .= $s.':'.$strathash{$s}."\n"; + } + 1; + }) +{ + eq_or_diff($string, $TESTDATA{'strats'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# A list of words which start with "blue screen" - ie contains +# a space. +#----------------------------------------------------------------------- +$title = "get a list of words starting with 'blue screen'"; +eval { $defref = $dict->match('blue screen', 'prefix', '*'); }; +if (!$@ + && defined $defref + && do { $string = _format_matches($defref); }) +{ + eq_or_diff($string, $TESTDATA{'*-prefix-blue_screen'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# A list of words which start with "blue " in the jargon dictionary. +# We've previously specified a default dictionary of foldoc, +# but we shouldn't get anything from that. +#----------------------------------------------------------------------- +$title = "list of words starting with 'blue ' in the jargon dict"; +$dict->setDicts('foldoc'); +eval { $defref = $dict->match('blue ', 'prefix', 'jargon'); }; +if (!$@ + && defined $defref + && do { $string = _format_matches($defref); }) +{ + eq_or_diff($string, $TESTDATA{'jargon-prefix-blue_'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: match +# Now we do the same match, but without specifying a dictionary, +# so it should fall back on the previously specified foldoc +#----------------------------------------------------------------------- +$title = "match words starting with 'blue '"; +$dict->setDicts('foldoc'); +eval { $defref = $dict->match('blue ', 'prefix'); }; +if (!$@ + && defined $defref + && do { $string = _format_matches($defref); }) +{ + eq_or_diff($string, $TESTDATA{'foldoc-prefix-blue_'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: match +# Look for words with apostrophe in them, in a specific dictionary +#----------------------------------------------------------------------- +$title = "use match() to look for words with an apostophe, in world02"; +eval { $defref = $dict->match("d'i", 're', 'world02'); }; +if (!$@ + && defined $defref + && do { $string = _format_matches($defref); }) +{ + eq_or_diff($string, $TESTDATA{"world02-re-'"}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: match +# look for all words in all dictionaries ending in "standard" +#----------------------------------------------------------------------- +$title = "look for words ending in 'standard' in all DBs"; +eval { $defref = $dict->match("standard", 'suffix', '*'); }; +if (!$@ + && defined $defref + && do { $string = _format_matches($defref); }) +{ + eq_or_diff($string, $TESTDATA{'*-suffix-standard'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: match +# Using regular expressions to find all entries in a dictionary +# of a given length +#----------------------------------------------------------------------- +$title = "use regexp to find all entries of a given length"; +eval { $defref = $dict->match('^a....................$', + 're', 'wn'); }; +if (!$@ + && defined $defref + && do { $string = _format_matches($defref); }) +{ + eq_or_diff($string, $TESTDATA{'web1913-re-dotmatch'}, $title); +} +else { + fail($title); +} + +#----------------------------------------------------------------------- +# METHOD: match +# Look for words which have a Levenshtein distance one +# from "know" +#----------------------------------------------------------------------- +$title = "look for words with a Levenshtein distance one from 'know'"; +eval { $defref = $dict->match('know', 'lev', '*'); }; +if (!$@ + && defined $defref + && do { $string = _format_matches($defref); }) +{ + eq_or_diff($string, $TESTDATA{'*-lev-know'}, $title); +} +else { + fail($title); +} + + +exit 0; + +#======================================================================= +# +# _format_matches() +# +# takes a reference to a list which is assumed to be the result +# from a match() - each entry in the list is a reference to +# a 2-element list: [DICTIONARY, WORD] +# +# We return a string which has one line per entry: +# DICTIONARY:WORD +# sorted on the whole line (ie by dictionary, then by word) +# +#======================================================================= +sub _format_matches +{ + my $mref = shift; + + my $string = ''; + + + foreach my $entry (sort { lc($a->[0].$a->[1]) cmp lc($b->[0].$b->[1]) } @$mref) + { + $string .= $entry->[0].':'.$entry->[1]."\n"; + } + + return $string; +} + +__DATA__ +==== strats ==== +exact:Match headwords exactly +first:Match the first word within headwords +last:Match the last word within headwords +lev:Match headwords within Levenshtein distance one +nprefix:Match prefixes (skip, count) +prefix:Match prefixes +re:POSIX 1003.2 (modern) regular expressions +regexp:Old (basic) regular expressions +soundex:Match using SOUNDEX algorithm +substring:Match substring occurring anywhere in a headword +suffix:Match suffixes +word:Match separate words within headwords +==== *-exact-blue ==== +easton:Blue +foldoc:Blue +gazetteer:Blue +web1913:Blue +web1913:blue +wn:blue +==== *-prefix-blue_screen ==== +foldoc:blue screen of death +foldoc:blue screen of life +jargon:blue screen of death +==== jargon-prefix-blue_ ==== +jargon:blue box +jargon:blue glue +jargon:blue goo +jargon:blue screen of death +jargon:blue wire +==== foldoc-prefix-blue_ ==== +foldoc:blue book +foldoc:blue box +foldoc:blue dot syndrome +foldoc:blue glue +foldoc:blue screen of death +foldoc:blue screen of life +foldoc:blue sky software +foldoc:blue wire +==== world02-re-' ==== +world02:Cote d'Ivoire +==== *-suffix-standard ==== +bouvier:STANDARD +foldoc:a tools integration standard +foldoc:advanced encryption standard +foldoc:american national standard +foldoc:binary compatibility standard +foldoc:data encryption standard +foldoc:de facto standard +foldoc:digital signature standard +foldoc:display standard +foldoc:filesystem hierarchy standard +foldoc:ieee floating point standard +foldoc:international standard +foldoc:object compatibility standard +foldoc:recommended standard +foldoc:robot exclusion standard +foldoc:standard +foldoc:video display standard +gaz2k-places:Standard +gcide:deficient inferior substandard +gcide:Double standard +gcide:double standard +gcide:non-standard +gcide:nonstandard +gcide:standard +gcide:Standard +jargon:ansi standard +moby-thesaurus:standard +wn:accounting standard +wn:double standard +wn:gold standard +wn:monetary standard +wn:nonstandard +wn:procrustean standard +wn:silver standard +wn:standard +wn:substandard +==== web1913-re-dotmatch ==== +wn:aaron montgomery ward +wn:abelmoschus moschatus +wn:aboriginal australian +wn:abruptly-pinnate leaf +wn:absence without leave +wn:acacia auriculiformis +wn:acid-base equilibrium +wn:acquisition agreement +wn:acute-angled triangle +wn:adams-stokes syndrome +wn:adenosine diphosphate +wn:adlai ewing stevenson +wn:advance death benefit +wn:aeronautical engineer +wn:affine transformation +wn:africanized honey bee +wn:ageratum houstonianum +wn:aglaomorpha meyeniana +wn:agnes george de mille +wn:agnes gonxha bojaxhiu +wn:agricultural labourer +wn:agriculture secretary +wn:agrippina the younger +wn:agropyron intermedium +wn:agropyron pauciflorum +wn:agropyron subsecundum +wn:air-to-ground missile +wn:airborne transmission +wn:aksa martyrs brigades +wn:albatrellus dispansus +wn:alben william barkley +wn:aldous leonard huxley +wn:aldrovanda vesiculosa +wn:alex boncayao brigade +wn:alexander archipelago +wn:alexander graham bell +wn:alexis de tocqueville +wn:alfred alistair cooke +wn:alfred bernhard nobel +wn:alfred charles kinsey +wn:alfred edward housman +wn:alfred lothar wegener +wn:alfred russel wallace +wn:alkylbenzenesulfonate +wn:allied command europe +wn:allium cepa viviparum +wn:amaranthus graecizans +wn:ambloplites rupestris +wn:ambrosia psilostachya +wn:ambystomid salamander +wn:amelanchier alnifolia +wn:american bog asphodel +wn:american mountain ash +wn:american parsley fern +wn:american pasqueflower +wn:american red squirrel +wn:american saddle horse +wn:amphitheatrum flavium +wn:amsinckia grandiflora +wn:andrew william mellon +wn:andropogon virginicus +wn:anemopsis californica +wn:angelica archangelica +wn:angolan monetary unit +wn:anogramma leptophylla +wn:anointing of the sick +wn:anterior crural nerve +wn:anterior jugular vein +wn:anterior labial veins +wn:anthriscus sylvestris +wn:anthyllis barba-jovis +wn:anti-racketeering law +wn:anti-submarine rocket +wn:anti-takeover defense +wn:antiballistic missile +wn:antigenic determinant +wn:antihemophilic factor +wn:antihypertensive drug +wn:antilocapra americana +wn:antiophthalmic factor +wn:antitrust legislation +wn:anton van leeuwenhoek +wn:antonio lucio vivaldi +wn:antonius stradivarius +wn:apalachicola rosemary +wn:apex of the sun's way +wn:aposematic coloration +wn:appalachian mountains +wn:appendicular skeleton +wn:arceuthobium pusillum +wn:archeological remains +wn:archimedes' principle +wn:arctostaphylos alpina +wn:ardisia escallonoides +wn:arenaria groenlandica +wn:ariocarpus fissuratus +wn:army of the righteous +wn:arna wendell bontemps +wn:arnold joseph toynbee +wn:arrhenatherum elatius +wn:artemisia californica +wn:artemisia dracunculus +wn:artemisia gnaphalodes +wn:artemisia ludoviciana +wn:artemisia stelleriana +wn:artemision at ephesus +wn:arteria intercostalis +wn:arterial blood vessel +wn:arthur edwin kennelly +wn:articles of agreement +wn:as luck would have it +wn:asarum shuttleworthii +wn:ascension of the lord +wn:asclepias curassavica +wn:asparagus officinales +wn:aspergillus fumigatus +wn:asplenium platyneuron +wn:asplenium trichomanes +wn:astreus hygrometricus +wn:astrophyton muricatum +wn:athyrium filix-femina +wn:atmospheric condition +wn:atrioventricular node +wn:august von wassermann +wn:augustin jean fresnel +wn:australian blacksnake +wn:australian bonytongue +wn:australian grass tree +wn:australian reed grass +wn:australian sword lily +wn:australian turtledove +wn:austronesian language +wn:automotive technology +wn:aversive conditioning +wn:avicennia officinalis +wn:avogadro's hypothesis +wn:azerbajdzhan republic +==== *-lev-know ==== +easton:Knop +easton:Snow +gaz2k-counties:Knox +gaz2k-places:Knox +gcide:Aknow +gcide:Enow +gcide:Gnow +gcide:Knaw +gcide:Knew +gcide:Knob +gcide:Knop +gcide:Knor +gcide:knot +gcide:Known +gcide:Now +gcide:Snow +gcide:Ynow +moby-thesaurus:knob +moby-thesaurus:knot +moby-thesaurus:now +moby-thesaurus:snow +vera:now +wn:knob +wn:knot +wn:known +wn:knox +wn:now +wn:snow +==== END ==== diff --git a/tkdict b/tkdict new file mode 100755 index 0000000..e1b9ec4 --- /dev/null +++ b/tkdict @@ -0,0 +1,795 @@ +#!/usr/bin/env perl +# +# tkdict - a Perl/Tk DICT client, for accessing network dictionary servers +# +# Neil Bowers <n...@bowers.com> +# Copyright (C) 2001-2002, Neil Bowers +# + +use strict; +use warnings; + +use Tk; +use Tk::Dialog; +use Net::Dict; +use AppConfig::Std; + +use vars qw($PROGRAM $VERSION); +$VERSION = sprintf("%d.%d", q$Revision: 1.1.1.1 $ =~ /(\d+)\.(\d+)/); + +my $warn_dialog; +my $dict_server; +my $word; +my $text_window; +my $bgcolor; +my $mw; +my $config; +my $help; +my ($info_top, $info_text, $info_title); +my $ht; +my %helpString; +my $dict; +my ($lookup_mode, $modeDisplay); +my $mbDefine; +my ($sframe, $strat_menu, $strategy, $strategyDisplay); +my ($db_frame, $db_menu, $db, $dbDisplay); +my $bar3; + +main(); +exit 0; + + +#======================================================================= +# +# main() +# +# This is the main body of tkdict +# +#======================================================================= +sub main +{ + initialise(); + create_gui(); + if ($config->host) + { + $dict_server = $config->host; + select_server(); + } + $mw->protocol('WM_DELETE_WINDOW', \&tkdict_exit); + MainLoop(); +} + +#======================================================================= +# +# initialise() +# +# check config file and command-line +# +#======================================================================= +sub initialise +{ + #------------------------------------------------------------------- + # Initialise misc global variables + #------------------------------------------------------------------- + $PROGRAM = "TkDict"; + $lookup_mode = "define"; + + #------------------------------------------------------------------- + # Create AppConfig::Std, define parameters, and parse command-line + #------------------------------------------------------------------- + $config = AppConfig::Std->new() + || die "failed to create AppConfig::Std: $!\n"; + + $config->define('host', { ARGCOUNT => 1, ALIAS => 'h' }); + $config->define('port', { ARGCOUNT => 1, ALIAS => 'p', + DEFAULT => 2628 }); + $config->define('client', { ARGCOUNT => 1, ALIAS => 'c', + DEFAULT => "$PROGRAM $VERSION ". + "[using Net::Dict $Net::Dict::VERSION]", + }); + + $config->args(\@ARGV) + || die "run \"$PROGRAM -help\" to see valid options\n"; + + #------------------------------------------------------------------- + # Consistency checking, ensure we have required options, etc. + #------------------------------------------------------------------- +} + +#======================================================================= +# +# select_server() +# +# connect to the server, and get information needed to +# configure the user interface. +# +#======================================================================= +sub select_server +{ + + if (not defined $dict_server || $dict_server eq '') + { + configure_dict_gui(); + return; + } + + $word = ''; + + #------------------------------------------------------------------- + # Create connection to DICT server + #------------------------------------------------------------------- + $dict = Net::Dict->new($dict_server, + Port => $config->port, + Client => $config->client, + Debug => $config->debug, + ); + if (not defined $dict) + { + tkd_warn("Failed to connect to DICT server $dict_server"); + configure_dict_gui(); + return; + } + + configure_dict_gui(); +} + +#======================================================================= +# +# configure_dict_gui() +# +# Configure the relevant bits of the GUI according to +# the current DICT connection. +# +#======================================================================= +sub configure_dict_gui +{ + my @dbs; + my %dbhash; + my @strats; + my %shash; + + $text_window->delete('0.0', 'end'); + if (not defined $dict) + { + $bar3->packForget(); + $db_frame->packForget(); + } + else + { + $bar3->pack(-side => 'top', -fill => 'x'); + + %dbhash = $dict->dbs(); + @dbs = map { [$dbhash{$_}, $_] } sort keys %dbhash; + unshift(@dbs, ['search all databases', '*'], + ['search all, stop after 1st match', '!']); + $db_menu->configure(-options => \@dbs); + + %shash = $dict->strategies(); + @strats = map { [$shash{$_}, $_] } sort keys %shash; + $strat_menu->configure(-options => \@strats); + + $db_frame->pack(-side => 'left'); + } +} + +#======================================================================= +# +# create_gui() +# +# This procedure creates the widgets for the tkdict GUI +# +#======================================================================= +sub create_gui +{ + my $bar2; + my $menu_bar; + my $mbFile; + my $mbView; + my $mbHelp; + my $server_entry; + my $word_entry; + + $mw = MainWindow->new(-title => "$PROGRAM $VERSION"); + + $bgcolor = $mw->cget(-bg); + + #--------------------------------------------------------------------- + # menu bar + #--------------------------------------------------------------------- + $menu_bar = $mw->Frame(-relief => 'raised', -bd => 2); + $menu_bar->pack(-side => 'top', -fill => 'x'); + + #--------------------------------------------------------------------- + # Menu: File + # + # Create the File menu and the entries on the menu + #--------------------------------------------------------------------- + + $mbFile = $menu_bar->Menubutton( + -text => 'File', + -underline => 0, + -tearoff => 0, + -menuitems => [ + '-', + ['command' => 'Exit', + -underline => 1, + -command => \&tkdict_exit] + ]); + $mbFile->pack(-side => 'left'); + + #--------------------------------------------------------------------- + # Menu: View + # + # Create the View menu and the entries on the menu + #--------------------------------------------------------------------- + $mbView = $menu_bar->Menubutton( + -text => 'View', -underline => 0, + -tearoff => 0, + -menuitems => [ ['command' => 'Server Information', + -command => [\&show_info, 'server']], + ['command' => 'Database Information', + -command => [\&show_info, 'db']], + ]); + $mbView->pack(-side => 'left'); + + + #--------------------------------------------------------------------- + # Menu: Help + # + # Create the Help menu and the entries on the menu + #--------------------------------------------------------------------- + $mbHelp = $menu_bar->Menubutton( + -text => 'Help', + -underline => 0, + -tearoff => 0, + -menuitems => [ + ['command' => 'Overview', + -command => [\&show_help, 'overview']], + ['command' => 'ToDo List', + -command => [\&show_help, 'todo']], + '-', + ['command' => 'About TkDict ...', + -command => [\&show_help, 'about']], + ]); + $mbHelp->pack(-side => 'right'); + + #--------------------------------------------------------------------- + # bar which has the entries for specifying server and select a dict + #--------------------------------------------------------------------- + $bar2 = $mw->Frame(-relief => 'raised', -bd => 2); + $bar2->pack(-side => 'top', -fill => 'x'); + + $bar2->Label(-text => 'Server: ')->pack(-side => 'left'); + $server_entry = $bar2->Entry(-relief => 'sunken', + -textvariable => \$dict_server, + -width => 16)->pack(-side => 'left', -fill => 'x'); + $server_entry->bind('<Return>', \&select_server); + $server_entry->bind('<FocusIn>', + sub { $server_entry->configure(-bg => 'white'); }); + $server_entry->bind('<FocusOut>', + sub { $server_entry->configure(-bg => "$bgcolor"); }); + + $db_frame = $bar2->Frame(); + + $db_frame->Label(-text => 'Dictionary: ')->pack(-side => 'left'); + $db_menu = $db_frame->Optionmenu(-variable => \$db, + -textvariable => \$dbDisplay, + -options => [], + )->pack(-side => 'left'); + + #------------------------------------------------------------------- + # Bar which has the entry for entering the word to be defined + #------------------------------------------------------------------- + $bar3 = $mw->Frame(-relief => 'raised', -bd => 2); + $bar3->pack(-side => 'top', -fill => 'x'); + # $bar3->Label(-text => 'Define word:')->pack(-side => 'left'); + $mbDefine = $bar3->Optionmenu( + -textvariable => \$modeDisplay, + -variable => \$lookup_mode, + -command => \&set_mode, + -options => [ ['Define word', 'define'], + ['Match pattern', 'match'], + ], + ); + $mbDefine->pack(-side => 'left'); + + $word_entry = $bar3->Entry(-relief => 'sunken', + -textvariable => \$word, + -width => 16)->pack(-side => 'left'); + $word_entry->bind('<Return>', \&lookup_word); + $word_entry->bind('<FocusIn>', + sub { $word_entry->configure(-bg => 'white'); }); + $word_entry->bind('<FocusOut>', + sub { $word_entry->configure(-bg => "$bgcolor"); }); + + $sframe = $bar3->Frame(); + $sframe->Label(-text => 'Strategy')->pack(-side => 'left'); + $strat_menu = $sframe->Optionmenu(-variable => \$strategy, + -textvariable => \$strategyDisplay, + -options => [], + )->pack(-side => 'left'); + $sframe->pack(-side => 'left'); + + $bar3->packForget(); + + #------------------------------------------------------------------- + # Bar which has the entry for entering the word to be defined + #------------------------------------------------------------------- + $text_window = $mw->Scrolled('Text', + -bg => 'white', -fg => 'black', + -width => 72, -height => 16, + -scrollbars => 'osoe'); + $text_window->pack(-side => 'bottom', -fill => 'both', -expand => 1); + + + #-- accelerators --------------------------------------------- + $mw->bind('<Control-x><Control-c>', \&tkdict_exit); + + set_mode(); + + $mw->update; +} + +#======================================================================= +# +# set_mode() +# +# Configure the GUI according to the lookup mode selected. +# If 'match', then show the menu for selecting the match strategy. +# If 'define', then hide the strategy selection menu. +# +#======================================================================= +sub set_mode +{ + + if ($lookup_mode eq 'match') + { + $sframe->pack(); + } + else + { + $sframe->packForget(); + } +} + +#======================================================================= +# +# lookup_word() +# +# Look up the word entered by the user. +# This will either be a match or a define operation. +# +#======================================================================= +sub lookup_word +{ + my $string = ''; + my $eref; + + if (!defined($word) || length($word) == 0) + { + tkd_warn("You need to type something first!"); + return; + } + + #------------------------------------------------------------------- + # clear out any help text which might be displayed + #------------------------------------------------------------------- + $text_window->delete('0.0', 'end'); + + if ($lookup_mode eq 'define') + { + #--------------------------------------------------------------- + # Word definitions requested. We get back a list ref: + # [ [db,definition], [db,definition], ... ] + #--------------------------------------------------------------- + $eref = $dict->define($word, $db); + if (@$eref == 0) + { + $string = "no definition found for \"$word\"\n"; + } + else + { + foreach my $entry (@$eref) + { + $string .= "--- ".$dict->dbTitle($entry->[0])." ---\n"; + $string .= $entry->[1]."\n\n"; + } + } + + } + else + { + #--------------------------------------------------------------- + # List of matching words requested. + #--------------------------------------------------------------- + my %dbwords; + my ($dbname, $match); + + $eref = $dict->match($word, $strategy); + if (@$eref == 0) + { + $string = "no words matched :-(\n"; + } + else + { + foreach my $entry (@$eref) + { + ($dbname, $match) = @$entry; + $dbwords{$dbname} = [] if not exists $dbwords{$dbname}; + push(@{ $dbwords{$dbname }}, $match); + } + foreach $dbname (sort keys %dbwords) + { + my @words; + $string .= $dict->dbTitle($dbname).":\n"; + $string .= join(', ', @{ $dbwords{$dbname}}); + $string .= "\n\n"; + } + } + } + + #------------------------------------------------------------------- + # display the resulting string in the scrolling text window + #------------------------------------------------------------------- + $text_window->insert('end', $string); +} + + +#======================================================================= +# +# tkdict_exit() +# +# quit from TkDict. In the future there might be +# more to do here, hence the function. +# +#======================================================================= +sub tkdict_exit +{ + exit 0; +} + +#======================================================================= +# +# show_info() +# +# Display information which is retrieved from the server. +# An argument is passed to identify which piece of info: +# +# server: information about the server +# db : information about the selected DB (dictionary) +# +#======================================================================= +sub show_info +{ + my $topic = shift; + + + if ($topic eq 'server' && !$dict_server) + { + tkd_warn("You have to connect to a server first!"); + return; + } + if ($topic eq 'db' && (!$db || $db eq '*' || $db eq '!')) + { + tkd_warn("You must select a specific database first"); + return; + } + + if (not Exists($info_top)) + { + $info_top = $mw->Toplevel(-class => 'TkDictInfo'); + $info_top->title("$PROGRAM Info"); + $info_title = $info_top->Label(); + $info_title->pack(-side => 'top', -fill => 'x'); + + $info_text = $info_top->Scrolled('Text', + -bg => 'white', -fg => 'black', + -width => 60, -height => 12, + -scrollbars => 'osoe', + )->pack(-side => 'top', -fill => 'both', + -expand => 1); + + $info_top->Button(-text => "Close", + -command => sub {$info_top->withdraw})->pack(-side => 'bottom'); + } else { + $info_top->deiconify(); + $info_top->raise(); + } + + $info_text->delete('0.0', 'end'); + + if ($topic eq 'server') + { + $info_title->configure(-text => "Server: $dict_server"); + $info_text->insert('end', $dict->serverInfo()); + } + else + { + $info_title->configure(-text => "Database: ".$dict->dbTitle($db)); + foreach my $line ($dict->dbInfo($db)) + { + $info_text->insert('end', $line); + } + } +} + +#======================================================================= +# show_help() - display a selected help message +# $topic - the identifier for the topic to display +# +# This procedure is used to display a help message. An identifying +# string is passed in, which is used to index the associative array +# holding the help text. +#======================================================================= +sub show_help +{ + my $topic = shift; + + + #-- create the help display toplevel, if needed -------------- + if (not Exists($help)) + { + $help = $mw->Toplevel(-class => 'TkDictHelp'); + $help->title("$PROGRAM Help"); + + $ht = $help->Scrolled('Text', + -bg => 'white', -fg => 'black', + -width => 60, -height => 12, + -scrollbars => 'osoe', + )->pack(-side => 'top', -fill => 'both', + -expand => 1); + + $help->Button(-text => "Close", + -command => sub {$help->withdraw})->pack(-side => 'bottom'); + initialise_help(); + } else { + $help->deiconify(); + $help->raise(); + } + + #-- clear out any help text which might be displayed --------- + $ht->delete('0.0', 'end'); + + #-- insert the selected help message in text widget ---------- + $ht->insert('end', $helpString{$topic}); +} + +#======================================================================= +# +# tkd_warn() +# +# Display a warning message in a dialog, then wait for the +# user to acknowledge it. +# +#======================================================================= +sub tkd_warn +{ + my $message = shift; + + my $choice; + + + if (not Exists($warn_dialog)) + { + $warn_dialog = $mw->Dialog( + -title => "Warning", + -text => $message, + -bitmap => 'warning', + -default_button => "OK", + ); + } + else + { + $warn_dialog->configure(-text => $message); + } + + $choice = $warn_dialog->Show(-global); +} + + +#======================================================================= +# initialise_help() - initialize the help strings +# +# This procedure initializes the global array helpString, which holds +# the text for the different help messages. The array is indexed by +# single word identifiers. +#======================================================================= +sub initialise_help +{ + $helpString{about} = <<EOFABOUT; + + $PROGRAM v$VERSION + +$PROGRAM is a DICT client, used to access network dictionary +servers which support the protocol defined in RFC 2229. + +This client is using Perl module Net::Dict $Net::Dict::VERSION. + +Neil Bowers <neil\@bowers.com> +Copyright (C) 2001-2002, Neil Bowers +EOFABOUT + + $helpString{overview} = <<EOFENTRY; + + $PROGRAM $VERSION - Overview + +$PROGRAM is a simple Tk tool for looking up entries +in dictionaries which are accessed using the DICT protocol. + +First you must specify a Server (and press RETURN). +A good one to try is dict.org - it has a number of dictionaries. +You should get a menu for selecting dictionaries, +and a text box for entering a word. + +Enter a word and press return. By default $PROGRAM will check +all dictionaries, so you might get a number of definitions. + +EOFENTRY + + $helpString{todo} = <<EOFTODO; + + $PROGRAM v$VERSION - ToDo List + + * better formatting of results + * more user-oriented user interface + * have the inline pod available on Help menu + * show one definition at a time + with some sort of NEXT and PREV interface + * option to specify whether to stay connect or not + * haven't done anything to handle connnection timing out + * status line at the bottom of the main window + +EOFTODO +} + + +#======================================================================= +# +# show_db_info() +# +# Query the server for information about the specified database, +# and display the results. +# +# The information is typically several pages of text, +# describing the contents of the dictionary, where it came from, +# credits, etc. +# +#======================================================================= +sub show_db_info +{ + my $db = shift; + my %dbs = $dict->dbs(); + + + if (not exists $dbs{$config->info}) + { + print " dictionary \"$db\" not known\n"; + return; + } + + print $dict->dbInfo($config->info); +} + +__END__ + +=head1 NAME + +tkdict - a perl client for accessing network dictionary servers + +=head1 SYNOPSIS + +tkdict [OPTIONS] + +=head1 DESCRIPTION + +B<tkdict> is a Perl/Tk client for the Dictionary server protocol (DICT), +which is used to query natural dictionaries hosted on a remote machine. + +At the moment it's not very user oriented, since I've just been +creating an interface to the protocol. + +There is more information available in the B<Help> menu +when running B<tkdict>. + +=head1 OPTIONS + +=over 4 + +=item B<-h> I<server> or B<-host> I<server> + +The hostname for the DICT server. + +=item B<-p> I<port> or B<-port> I<port> + +Specify the port for connections (default is 2628, from RFC 2229). + +=item B<-c> I<string> or B<-client> I<string> + +Specify the CLIENT identification string sent to the DICT server. + +=item B<-help> + +Display a short help message including command-line options. + +=item B<-doc> + +Display the full documentation for B<tkdict>. + +=item B<-version> + +Display the version of B<tkdict> + +=item B<-verbose> + +Display verbose information as B<tkdict> runs. + +=item B<-debug> + +Display debugging information as B<tkdict> runs. +Useful mainly for developers. + +=back + +=head1 KNOWN BUGS AND LIMITATIONS + +=over 4 + +=item * + +B<tkdict> doesn't know how to handle firewalls. + +=item * + +The authentication aspects of RFC 2229 aren't currently supported. + +=item * + +See the B<ToDo> page under the B<Help> menu. + +=back + +=head1 SEE ALSO + +=over 4 + +=item www.dict.org + +The DICT home page, with all sorts of useful information. +There are a number of other DICT clients available. + +=item dict + +The C dict client written by Rik Faith; +the options are pretty much lifted from Rik's client. + +=item RFC 2229 + +The document which defines the DICT network protocol. + +http://www.cis.ohio-state.edu/htbin/rfc/rfc2229.html + +=item Net::Dict + +The perl module which implements the client API for RFC 2229. +It includes a command-line perl client, B<dict>, +as well as B<tkdict>. + +=back + +=head1 VERSION + +$Revision: 1.1.1.1 $ + +=head1 AUTHOR + +Neil Bowers <n...@bowers.com> + +=head1 COPYRIGHT + +Copyright (C) 2001-2002 Neil Bowers. All rights reserved. + +This script is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libnet-dict-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits