WWW-Wikipedia-2.04/0000755000175000017500000000000012641016615013321 5ustar bricasbricasWWW-Wikipedia-2.04/Changes0000644000175000017500000000640512641016427014622 0ustar bricasbricasRevision history for Perl extension WWW::Wikipedia. 2.04 2015-12-30 - add LWP::Protocol::https to prereqs (RT #110781) 2.03 2015-12-23 - fix "Unescaped left brace in regex is deprecated" (RT #110564) 2.02 2015-12-21 - Make whitespace after REDIRECT optional, to fix RT#94111 - Changed github URL to https, and added repo to doc - Added "use 5.006;" to both modules - Add clean_html option to strip basic HTML tags. 2.01 2013-02-21 - Update test suite due to a change in returned data 2.00 2011-04-05 - use decoded_content() rather than just content() (RT #66337) - parse raw text to get proper redirect link (RT #66337) - try to catch self-redirects (RT #66337) 1.99 2011-02-16 - Fix up title in entry and provide an accessor for the value - use uri_escape_utf8 in search() as needed 1.98 2010-12-01 - Remove newline that was attached to redirects returned by search() 1.97 2010-06-16 - Update redirect regex due to wikipedia changes (RT #58440) 1.96 2009-09-14 - Add text_basic() and fulltext_basic() to Entry, which are the same as the non _basic methods, but not run through Text::Autoformat 1.95 2009-04-29 - Swap out CGI for URI::Escape 1.94 2008-02-25 - Fix random() to get the proper url for the raw content 1.93 2007-12-11 - add a setting to control the following of redirect directives - switch to Module::Install 1.92 2007-01-02 - a random() method was added in 1.91 - added parse_head(0) to squash some warnings 1.91 2007-01-02 - redirects no longer case sensitive (thanks Chris Bolt) 1.9 2006-04-18 - handle wikipedia style redirects when the raw content looks like #REDIRECT [[systems theory]] 1.8 2005-08-26 - avoid passing in any sequence of \n to autoformamt since it barfs on that as well in v1.13 (thanks Steve Freedman) - when there is no summary paragraph in an entry, a call to text() will return the fulltext for an entry. 1.7 2005-07-15 - avoid passing "\n" to Text::Autoformat::autoformat() since it blows chunks in v1.13 (thanks Tom Halford) 1.6 2005-07-11 - updated WWW::Wikipedia to use the new raw url (thanks Katrin Tomanek) 1.5 2005-03-23 - added language option (-l) to bin/wikipedia - added pod and pod_coverage tests 1.4 2005-02-14 - added error() for error messages - search() now returns undef on error and sets error() 1.3 2004-10-26 - added multi-lingual support to WWW::Wikipedia::Entry 1.2 2004-09-01 - removed newline stripping (thanks Offer Kaye) - bin/wikipedia uses Text::Autoformat 1.1 2004-08-19 - fixed t/15.entry.t to hopefull pass on multiple platforms no matter what OS the distribution was created on. 1.0 2004-08-10 - added initial multi-lingual support 0.9 2004-08-04 - new WWW::Wikipedia::Entry, backwards incompatible changes to interface. - t/15.entry.t test the new entry class. - WWW::Wikipedia is now a subclass of LWP::UserAgent. 0.6 2004-04-06 - fixed documentation bug (thanks Thomas Galley) 0.5 2004-02-13 - wikipedia cmd line tool uses IO::Page if it can. 0.4 2004-02-13 - wikipedia cmd line tool courtesy of Slaven Rezic. - fixed warnings emanating from module 0.3 2003-04-01 - added ability to specify useragent in constructor thanks Lin Yung-Chung. 0.2 2003-03-24 - fixed README 0.1 2003-03-21 - original version WWW-Wikipedia-2.04/Makefile.PL0000644000175000017500000000065512641016343015277 0ustar bricasbricasuse inc::Module::Install 1.00; if ( -e 'MANIFEST.SKIP' ) { system( 'pod2text lib/WWW/Wikipedia.pm > README' ); } perl_version '5.006'; name 'WWW-Wikipedia'; all_from 'lib/WWW/Wikipedia.pm'; requires 'LWP::UserAgent'; requires 'LWP::Protocol::https'; requires 'URI'; requires 'Text::Autoformat'; test_requires 'Test::More'; install_script 'bin/wikipedia'; repository 'https://github.com/edsu/www-wikipedia'; WriteAll; WWW-Wikipedia-2.04/inc/0000755000175000017500000000000012641016615014072 5ustar bricasbricasWWW-Wikipedia-2.04/inc/Module/0000755000175000017500000000000012641016615015317 5ustar bricasbricasWWW-Wikipedia-2.04/inc/Module/Install.pm0000644000175000017500000003013512641016545017267 0ustar bricasbricas#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy. WWW-Wikipedia-2.04/inc/Module/Install/0000755000175000017500000000000012641016615016725 5ustar bricasbricasWWW-Wikipedia-2.04/inc/Module/Install/Can.pm0000644000175000017500000000615712641016546020000 0ustar bricasbricas#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 WWW-Wikipedia-2.04/inc/Module/Install/Makefile.pm0000644000175000017500000002743712641016546021020 0ustar bricasbricas#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 WWW-Wikipedia-2.04/inc/Module/Install/Scripts.pm0000644000175000017500000000101112641016546020706 0ustar bricasbricas#line 1 package Module::Install::Scripts; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub install_script { my $self = shift; my $args = $self->makemaker_args; my $exe = $args->{EXE_FILES} ||= []; foreach ( @_ ) { if ( -f $_ ) { push @$exe, $_; } elsif ( -d 'script' and -f "script/$_" ) { push @$exe, "script/$_"; } else { die("Cannot find script '$_'"); } } } 1; WWW-Wikipedia-2.04/inc/Module/Install/Base.pm0000644000175000017500000000214712641016546020144 0ustar bricasbricas#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 WWW-Wikipedia-2.04/inc/Module/Install/Win32.pm0000644000175000017500000000340312641016546020170 0ustar bricasbricas#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; WWW-Wikipedia-2.04/inc/Module/Install/Fetch.pm0000644000175000017500000000462712641016546020330 0ustar bricasbricas#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; WWW-Wikipedia-2.04/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612641016546021021 0ustar bricasbricas#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; WWW-Wikipedia-2.04/inc/Module/Install/Metadata.pm0000644000175000017500000004327712641016546021023 0ustar bricasbricas#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; WWW-Wikipedia-2.04/META.yml0000644000175000017500000000124312641016546014575 0ustar bricasbricas--- abstract: 'Automated interface to the Wikipedia ' author: - 'Ed Summers ' build_requires: ExtUtils::MakeMaker: 6.59 Test::More: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: WWW-Wikipedia no_index: directory: - inc - t requires: LWP::Protocol::https: 0 LWP::UserAgent: 0 Text::Autoformat: 0 URI: 0 perl: 5.6.0 resources: license: http://dev.perl.org/licenses/ repository: https://github.com/edsu/www-wikipedia version: 2.04 WWW-Wikipedia-2.04/bin/0000755000175000017500000000000012641016615014071 5ustar bricasbricasWWW-Wikipedia-2.04/bin/wikipedia0000755000175000017500000000204312110310667015757 0ustar bricasbricas#!/usr/bin/perl =head1 NAME wikipedia - lookup an entry in the wikipedia =head1 SYNOPSIS % wikipedia [-l lang] perl =head1 DESCRIPTION wikipedia is a command line tool for looking up a topic in the wikipedia and printing it to STDOUT. Useful if you spend a lot of time in a shell and don't want to fire up a web browser to see what something is. =head1 AUTHORS =over 4 =item * Slaven Rezic =back =cut use strict; use WWW::Wikipedia; use Text::Autoformat; use Pod::Usage; use Getopt::Std; my %options; getopts( 'l:', \%options ); my $term = shift; pod2usage( { verbose => 1 } ) if !defined( $term ); my $wiki = WWW::Wikipedia->new( language => $options{ l } || 'en' ); my $entry = $wiki->search( $term ); ## use a pager if we can eval( 'use IO::Page' ); if ( $entry ) { my $text = $entry->text(); if ( $text ) { print $text; } else { print "Specific entry not found, see also:\n"; foreach ( $entry->related() ) { print " - $_\n"; } } } else { print qq("$term" not found in wikipedia\n) } WWW-Wikipedia-2.04/README0000644000175000017500000000726112641016546014212 0ustar bricasbricasNAME WWW::Wikipedia - Automated interface to the Wikipedia SYNOPSIS use WWW::Wikipedia; my $wiki = WWW::Wikipedia->new(); ## search for 'perl' my $result = $wiki->search( 'perl' ); ## if the entry has some text print it out if ( $result->text() ) { print $result->text(); } ## list any related items we can look up print join( "\n", $result->related() ); DESCRIPTION WWW::Wikipedia provides an automated interface to the Wikipedia , which is a free, collaborative, online encyclopedia. This module allows you to search for a topic and return the resulting entry. It also gives you access to related topics which are also available via the Wikipedia for that entry. INSTALLATION To install this module type the following: perl Makefile.PL make make test make install METHODS new() The constructor. You can pass it a two letter language code, or nothing to let it default to 'en'. ## Default: English my $wiki = WWW::Wikipedia->new(); ## use the French wiki instead my $wiki = WWW::Wikipedia->new( language => 'fr' ); WWW::Wikipedia is a subclass of LWP::UserAgent. If you would like to have more control over the user agent (control timeouts, proxies ...) you have full access. ## set HTTP request timeout my $wiki = WWW::Wikipedia->new(); $wiki->timeout( 2 ); You can turn off the following of wikipedia redirect directives by passing a false value to "follow_redirects". Together with the Wiki markup, some entries include HTML tags. They can be stripped out using the "clean_html" option: my $wiki = WWW::Wikipedia->new( clean_html => 1 ); See "clean_html" documentation bellow for details. language() This allows you to get and set the language you want to use. Two letter language codes should be used. The default is 'en'. my $wiki = WWW::Wikipedia->new( language => 'es' ); # Later on... $wiki->language( 'fr' ); clean_html() Allows to get/set if HTML is being stripped out. # set HTML strip $wiki->clean_html( 1 ); This option removes all tags and attributes they might have. Their contents, however, is maintained (for now). Comments are also removed. follow_redirects() By default, wikipeda redirect directives are followed. Set this to false to turn that off. search() Which performs the search and returns a WWW::Wikipedia::Entry object which you can query further. See WWW::Wikipedia::Entry docs for more info. $entry = $wiki->search( 'Perl' ); print $entry->text(); If there's a problem connecting to Wikipedia, "undef" will be returned and the error message will be stored in "error()". random() This method fetches a random wikipedia page. error() This is a generic error accessor/mutator. You can retrieve any searching error messages here. TODO * Be more specific on the HTML clean methodology. For now all tags are removed, keeping only their contents. In the future the behaviour might change accordingly with each specific tag. * Watch the development of Special:Export XML formatting, eg: http://en.wikipedia.org/wiki/Special:Export/perl SEE ALSO * LWP::UserAgent REPOSITORY AUTHORS Ed Summers Brian Cassidy COPYRIGHT AND LICENSE Copyright 2003-2015 by Ed Summers This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. WWW-Wikipedia-2.04/t/0000755000175000017500000000000012641016615013564 5ustar bricasbricasWWW-Wikipedia-2.04/t/15.entry.t0000644000175000017500000000266712110310667015344 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 16; use_ok( 'WWW::Wikipedia::Entry' ); ## test english text my $wikitext = getWikiText( 'perl.raw' ); my $entry = WWW::Wikipedia::Entry->new( $wikitext, 'http://en.wikipedia.org/wiki/Perl' ); isa_ok( $entry, 'WWW::Wikipedia::Entry' ); my $text = $entry->text(); like( $text, qr/'Perl', also 'Practical Extraction and Report Language'/, 'text()' ); ok( $entry->text_basic(), 'text_basic()' ); is( $entry->headings(), 13, 'headings()' ); my @categories = $entry->categories(); is( $categories[ 0 ], "Programming languages", 'categories()' ); is( $entry->related(), 91, 'related()' ); is( $entry->raw(), $wikitext, 'raw()' ); is( $entry->title(), 'Perl', 'title()' ); ## test spanish text $wikitext = getWikiText( 'perl.es.raw' ); $entry = WWW::Wikipedia::Entry->new( $wikitext, 'http://es.wikipedia.org/wiki/Perl' ); isa_ok( $entry, 'WWW::Wikipedia::Entry' ); ok( $entry->text(), 'text()' ); is( $entry->headings(), 0, 'headings()' ); @categories = $entry->categories(); is( $categories[ 0 ], "Lenguajes interpretados", 'categories()' ); is( $entry->related(), 36, 'related()' ); is( $entry->raw(), $wikitext, 'raw()' ); is( $entry->title(), 'Perl', 'title()' ); ## fetches some wikitext from disk sub getWikiText { my $file = shift; open( TEXT, "t/$file" ); my $text = join( '', ); close( TEXT ); return ( $text ); } WWW-Wikipedia-2.04/t/10.load.t0000644000175000017500000000012712110310667015102 0ustar bricasbricasuse strict; use warnings; use Test::More ( tests => 1 ); use_ok( 'WWW::Wikipedia' ); WWW-Wikipedia-2.04/t/25.search_error.t0000644000175000017500000000067412110310667016656 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 3; package WWW::Wikipedia; use HTTP::Response; sub get { return HTTP::Response->new( 500 ); } package main; use WWW::Wikipedia; # test default language my $wiki = WWW::Wikipedia->new(); isa_ok( $wiki, 'WWW::Wikipedia' ); my $entry = $wiki->search( 'perl' ); is( $entry, undef, 'search() returns undef' ); like( $wiki->error, qr/^uhoh, WWW::Wikipedia unable to contact/, 'error()' ); WWW-Wikipedia-2.04/t/21.random.t0000644000175000017500000000053212110310667015445 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 4; use WWW::Wikipedia; # test default language my $wiki = WWW::Wikipedia->new(); isa_ok( $wiki, 'WWW::Wikipedia' ); my $entry = $wiki->random(); isa_ok( $entry, 'WWW::Wikipedia::Entry' ); ok( length( $entry->text() ) > 0, 'text()' ); ok( length( $entry->fulltext() ) > 0, 'fulltext()' ); WWW-Wikipedia-2.04/t/perl.es.raw0000644000175000017500000000671512110310667015653 0ustar bricasbricas'''Perl''' ('''P'''ractical '''E'''xtraction and '''R'''eport '''L'''anguage) es un [[lenguaje de programación]] desarrollado por [[Larry Wall]] (lwall at netlabs.com) a partir otras herramientas de [[UNIX]] como son: [[ed]],[[grep]],[[awk]],[[c-shell]], para la administración de tareas propias de sistemas [[UNIX]]. No establece ninguna filosofía de [[programación]] concreta. No se puede decir que sea [[Programación orientada a objetos|orientado a objetos]], [[Programación modular|modular]] o [[Programación estructurada|estructurado]] aunque soporta directamente todos estos [[Paradigma de programación|paradigmas]] y su punto fuerte son las labores de procesamiento de textos y archivos. No es ni un [[compilador]] ni un [[intérprete]], esta en un punto intermedio, cuando mandamos a ejecutar un programa en Perl, se compila el código fuente a un código intermedio en memoria que se optimiza como si se fuera a elaborar un programa ejecutable pero es ejecutado por un motor, como si se tratase de un interprete. [[Lenguaje de programación]] basado en [[script]]s portable a casi cualquier plataforma. Es muy utilizado para escribir [[CGI]]s. [[Lenguaje]] optimizado para el escaneo de texto arbitrario de [[fichero]]s. Es también un buen [[lenguaje]] para tareas de administración de sistemas. Es un [[lenguaje]] con intención de ser práctico en lugar de bonito. Satisface las tres virtudes del programador: flojera, impaciencia y petulancia. Según el manual, Perl también significa ''Pathologically Eclectic Rubbish Lister''. --------- Resumen técnico de PERL. PERL es un [[lenguaje]] de [[script]] de tipo [[BCPL]] (como [[TCL]] o [[PHP]]), muy semejante al [[AWK]] (de hecho está basado en él), de tipo estructurado con trazas de orientación a objetos (no completamente soportado de forma directa), que permite el desarrollo rápido de aplicaciones y herramientas especialmente orientadas al tratamiento de textos y archivos, aunque actualmente también se utiliza incluso para entornos graficos, en combinacion con sistemas como [[Perl/TK]] o [[GTK]]. Básicamente, es un lenguaje que se ha intentado que sea lo más natural posible, lo que conlleva que en ocasiones nos encontremos estructuras poco habituales en un lenguaje de este tipo: print "hola" if $saludo == 1; Destaca también el uso de [[variable]]s especiales, muy habituales en los lenguajes de tipo script en los sistemas de tipo [[Unix]]. Estas variables permiten realizar una serie de operaciones sobre los datos y los archivos que aportan a PERL una flexibilidad y potencia enormes. Además de variables que podemos encontrar en otros lenguajes como @ARGV (indica los parámetros con los que se ha llamado al programa) o %ENV (indica las [[variables de entorno]] de la aplicación), podemos utilizar también variables como $_ (que representa el último dato que llegó por la [[entrada estandar]]), o $/, que nos indica si PERL debe enviar el texto a la [[salida estandar]] inmediatamente (o al flujo de salida que le hayamos indicado previamente). PERL tiene implementadas las [[expresión regular| expresiones regulares]], (regular expressions), lo que le da una potencia muy grande en el procesamiento de textos. [[category:Lenguajes interpretados]] {{Template:Lenguajes de programacion}} {{Soluciones LAMP}} [[cs:Perl]] [[de:Perl]] [[en:Perl]] [[eo:Perl]] [[et:Perl]] [[fi:Perl]] [[fr:Perl]] [[it:Perl]] [[ja:Perl]] [[nl:Programmeertaal Perl]] [[pl:Perl]] [[pt:Perl]] [[sv:Perl]]WWW-Wikipedia-2.04/t/20.search.t0000644000175000017500000000146012110310667015432 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 7; use WWW::Wikipedia; my ( $wiki, $testexception ); BEGIN { eval "use Test::Exception"; $testexception = $@ ? 0 : 1; } # test default language $wiki = WWW::Wikipedia->new(); isa_ok( $wiki, 'WWW::Wikipedia' ); SKIP: { skip 'Test::Exception not installed', 1 unless $testexception; throws_ok { $wiki->search(); } qr/search\(\) requires you pass in a string/, 'search()'; } my $entry = $wiki->search( 'perl' ); isa_ok( $entry, 'WWW::Wikipedia::Entry' ); ok( length( $entry->text() ) > 0, 'text()' ); # test language 'es' $wiki = WWW::Wikipedia->new( language => 'es' ); isa_ok( $wiki, 'WWW::Wikipedia' ); $entry = $wiki->search( 'perl' ); isa_ok( $entry, 'WWW::Wikipedia::Entry' ); ok( length( $entry->fulltext() ) > 0, 'fulltext()' ); WWW-Wikipedia-2.04/t/30.ua.t0000644000175000017500000000023112110310667014566 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 2; use_ok( 'WWW::Wikipedia' ); my $wiki = WWW::Wikipedia->new(); isa_ok( $wiki, 'LWP::UserAgent' ); WWW-Wikipedia-2.04/t/26.autoformat.t0000644000175000017500000000064012110310667016353 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 2; use WWW::Wikipedia; # Text::Autoformat has had some bugs which some wikipedia content # has been known to trigger. Make sure we cover those bases. my $wiki = WWW::Wikipedia->new(); foreach my $search ( 'princeton', 'Eddie Fenech Adami' ) { my $entry = $wiki->search( $search ); isa_ok( $entry, 'WWW::Wikipedia::Entry', "search result for: $search" ); } WWW-Wikipedia-2.04/t/40.redirect.t0000644000175000017500000000123012110310667015763 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 4; use WWW::Wikipedia; # the use of 'Systems Theory' over time may need to change my $q = 'Systems Theory'; my $wiki = WWW::Wikipedia->new(); # test to make sure redirects in content are followed { my $entry = $wiki->search( $q ); isa_ok $entry, 'WWW::Wikipedia::Entry'; unlike $entry->text(), qr/REDIRECT/, 'redirect not found'; } # test to make sure redirects in content are not followed # when follow_redirects == 0 { $wiki->follow_redirects( 0 ); my $entry = $wiki->search( $q ); isa_ok $entry, 'WWW::Wikipedia::Entry'; like $entry->text(), qr/REDIRECT/, 'redirect found'; } WWW-Wikipedia-2.04/t/16.entry_language.t0000644000175000017500000000173312111435777017214 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 10; use_ok( 'WWW::Wikipedia::Entry' ); my $wikitext = getWikiText( 'perl.raw' ); my $entry = WWW::Wikipedia::Entry->new( $wikitext, 'http://en.wikipedia.org/wiki/Perl' ); isa_ok( $entry, 'WWW::Wikipedia::Entry' ); is( $entry->languages(), 15, 'languages()' ); is( $entry->language(), 'en', 'language()' ); my $entry_es = $entry->language( 'es' ); isa_ok( $entry_es, 'WWW::Wikipedia::Entry' ); ok( $entry_es->languages() > 0, 'languages()' ); is( $entry_es->language(), 'es', 'language()' ); { my $ru = WWW::Wikipedia->new->search( 'Babushka' ); isa_ok( $ru, 'WWW::Wikipedia::Entry' ); my $ru_ru = $ru->language( 'ru' ); isa_ok( $ru_ru, 'WWW::Wikipedia::Entry' ); ok( $ru_ru->text, 'Page for "Babushka" in Russian' ); } ## fetches some wikitext from disk sub getWikiText { my $file = shift; open( TEXT, "t/$file" ); my $text = join( '', ); close( TEXT ); return ( $text ); } WWW-Wikipedia-2.04/t/11.language.t0000644000175000017500000000116212110310667015747 0ustar bricasbricasuse strict; use warnings; use Test::More tests => 7; use WWW::Wikipedia; my $wiki; # test default language: 'en' $wiki = WWW::Wikipedia->new(); isa_ok( $wiki, 'WWW::Wikipedia' ); is( $wiki->language, 'en', 'default language' ); # test language on new() $wiki = WWW::Wikipedia->new( language => 'es' ); isa_ok( $wiki, 'WWW::Wikipedia' ); is( $wiki->language, 'es', "new( language => 'es' )" ); # test language switching after new() $wiki = WWW::Wikipedia->new(); isa_ok( $wiki, 'WWW::Wikipedia' ); is( $wiki->language, 'en', 'default language' ); $wiki->language( 'fr' ); is( $wiki->language, 'fr', "language( 'fr' )" ); WWW-Wikipedia-2.04/t/98.pod.t0000644000175000017500000000023412110310667014764 0ustar bricasbricasuse strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); WWW-Wikipedia-2.04/t/99.pod_coverage.t0000644000175000017500000000027712110310667016647 0ustar bricasbricasuse strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); WWW-Wikipedia-2.04/t/perl.raw0000644000175000017500000004730412110310667015244 0ustar bricasbricas[[Category:Programming languages]] [[image:Programming-republic-of-perl.gif|right|Programming Republic Of Perl]] '''Perl''', also '''Practical Extraction and Report Language''' (a [[backronym]], see [[#Name|below]]), is a [[programming language]] released by [[Larry Wall]] on [[December 18]], [[1987]] that borrows features from [[C programming language|C]], [[sed]], [[awk]], [[UNIX shell|shell]] scripting ([[UNIX shell|sh]]), and (to a lesser extent) from many other programming languages. == Rationale == Perl was designed to be a practical language to extract information from text files and to generate reports from that information. One of its mottos is "There's more than one way to do it" (TMTOWTDI - pronounced 'Tim Toady'). Another is ''Perl: the Swiss Army Chainsaw of Programming Languages''. One stated design goal is to make easy tasks easy and difficult tasks possible. Its versatility permits versions of many programming paradigms: [[procedural programming|procedural]], [[functional programming|functional]], and [[Object Oriented Programming|object-oriented]] (though some claim that Perl is not a cleanly designed language because of its multiple paradigms). Perl has a powerful [[regular expression]] engine built directly into its syntax. Perl is often considered the archetypal [[scripting programming languages|scripting language]] and has been called the "glue that holds the web together", as it is one of the most popular [[Common Gateway Interface|CGI]] languages. Its function as a "glue language" can be described broadly as its ability to tie together different systems and interfaces that were not designed to interoperate. Perl is one of the [[programming language]] components of the popular [[LAMP]] free software platform for web development. Perl is [[free software movement|free software]], available under a combination of the ''[[Artistic License]]'' and the [[GPL]]. It is available for most [[operating system|operating systems]] but is particularly prevalent on [[Unix]] and [[Unix-like]] systems (e.g: [[Linux]] and [[FreeBSD]]), and is growing in popularity on [[Microsoft Windows]] systems. As an example of Perl in action, [[Wikipedia]] itself was a [[Common Gateway Interface|CGI]] script written in Perl until January [[2002]]. Another example is [[Slashdot]], which runs on the Perl-based [[Slashcode]] software. When used on the web, Perl is often used in conjunction with the [[Apache web server]] and its [[mod_perl]] module. Perl is regarded by both its proponents and detractors as something of a grab bag of features and syntax. The difference between the two camps lies in whether this is seen as a virtue or a vice. Perl votaries maintain that this varied heritage is what makes the language so useful. Reference is often made to natural languages such as [[English language|English]] and to [[evolution]]. For example, Larry Wall has argued that: :''... we often joke that a camel is a horse designed by a committee, but if you think about it, the camel is pretty well adapted for life in the desert. The camel has evolved to be relatively self-sufficient. On the other hand, the camel has not evolved to smell good. Neither has Perl.'' In recognition of its ugly-but-useful nature, Perl has adopted the camel as its mascot. == Implementation == A huge collection of freely usable [[perl module]]s, ranging from advanced mathematics to database connectivity, networking and more, can be downloaded from a network of sites called [[CPAN]], an [[Acronym|acronym]] for Comprehensive Perl Archive Network. Most or all of the software on CPAN is also available under either the [[Artistic License]], the [[GPL]], or both. CPAN.pm is also the name of the Perl module that downloads and installs other Perl modules from one of the CPAN mirror sites: such installations can be done with interactive prompts, or can be fully automated. Although Perl has most of the ease-of-use features of an interpreted language, it does not strictly interpret and execute source code one line at a time. Rather, perl (the program) first compiles an entire program to an intermediate [[byte code]] (much like [[Java programming language|Java's]] byte code), optimizing as it goes, and then executes that byte code. It is possible to compile a Perl program to byte code to save the compilation step on later executions, though the "interpreter" is still needed to execute that code. == Current version == The current version, 5.8.5, includes [[Unicode]] support. Development of the next major release, Perl 6, is also underway. It will run on [[Parrot virtual machine|Parrot]], a [[virtual machine]] which is being developed as a possible multi-language target architecture. == Control structures == The basic control structures do not differ greatly from those used in the [[C programming language|C]] or [[Java programming language|Java]] programming languages: ''Loops'' while (''Boolean expression'') { ''statement(s)'' } do { ''statement(s)'' } while (''Boolean expression''); do { ''statement(s)'' } until (''Boolean expression''); for (''initialisation'' ; ''termination condition'' ; ''incrementing expr'') { ''statement(s)'' } foreach ( ''array'' ) { ''statement(s)'' } ''If-then-statements'' if (''Boolean expression'') { ''statement(s)'' } unless (''Boolean expression'') { ''statement(s)'' } if (''Boolean expression'') { ''statement(s)'' } else { ''statement(s)'' } if (''Boolean expression'') { ''statement(s)'' } elsif (''Boolean expression'') { ''statement(s)'' } ''For one-line statements, "until", "while" and "if" can also be used as follows'': ''statement(s)'' until ''Boolean expression''; ''statement(s)'' while ''Boolean expression''; ''statement(s)'' if ''Boolean expression''; == Subroutines == [[Subroutine]]s in Perl can be specified with the [[keyword]] 'sub'. [[Variable]]s passed to a subroutine appear in the subroutine as elements of the local (to the subroutine) scalar array @_. Calling a subroutine with three scalar variables results in array elements @_[0], @_[1], and @_[2] within the subroutine. Note that these elements would be referred to as the scalars $_[0], $_[1], and $_[2]. Also shift can be used, without specifying @_, to obtain each value. Changes to elements in the @_ array within the subroutine are reflected in the elements in the calling program. Subroutines naturally return the value of the last expression evaluated, though explicit use of the ''return'' statement is often encouraged for clarity. An example subroutine definition and call follows: sub cube { my $x = shift; $x * $x * $x; } ... $z = -4; $y = cube($z); print "$y\n"; Named parameters can be simulated by passing a hash. == Perl and [[SQL]] databases == [[DBI/DBD]] modules can be used to access most [[ANSI]] [[SQL]] databases, including [[MySQL]], [[PostgreSQL]] and [[Oracle database|Oracle]]. == Perl 5 == Perl5, the most current production version of perl, is an interpreter which processes the text of a Perl script at runtime. Thus, the [[debugger]] is invoked directly from the command line with
        perl -dw ScriptName.pl Argument1 ... ...
Note that there is no limit to the number of arguments: Perl is polyadic; any number of arguments can be passed to any Perl subroutine, in general. This concept of "no arbitrary limits" is present in most other parts of the language as well. Perl can read a ten million byte string into a variable, if the machine has the memory for it. == Perl 6 == Perl6 is currently under development, and is planned to separate parsing, compilation and runtime, making a virtual machine that is more attractive to developers looking to port other languages to the architecture. [[Parrot virtual machine|Parrot]] is the Perl6 runtime, and can be programmed at a low level in [[Parrot assembly language]]. Parrot has existed in a limited form since December 2003. An increasing number of languages have been implemented to various degrees for the Parrot to be 'compiled' to Parrot assembly language opcodes. Besides a subset of the planned Perl6, these include [[BASIC programming language|BASIC]], [[Befunge]], [[Cola programming language|Cola]], [[Forth programming language|Forth]], [[Jako]], [[Ook!]], [[Plot programming language|Plot]], and even [[Python programming language|Python]], [[Ruby programming language|Ruby]], and [[Scheme]]. == Perl code samples == The canonical "[[hello world]]" program would be: #!/usr/bin/perl -w print "Hello world\n"; The first line is the [[shebang]], which indicates the interpreter for Unix-like operating systems. The second line prints the string 'Hello world' and a [[newline]] (like a person pressing 'Return' or 'Enter'). Some people humorously claim that Perl stands for "Pathologically Eclectic Rubbish Lister" due to its philosophy that there should be many ways to do the same thing, its growth by accretion, and its origins in report writing. There are many other jokes, including the annual [[Obfuscated Perl contest]], which makes an arch virtue of Perl's [[syntax|syntactical]] flexibility. The following program, which prints a greeting that is modified by a [[regular expression]], is a mild example of this pastime: # A sample Perl program $_ = "Hello, world! The magic number is 234542354.\n"; print; s/\d+/-1/; print; Here is its output: Hello, world! The magic number is 234542354. Hello, world! The magic number is -1.
===Regular expressions with Perl examples===

Regular Expression Description Example
Note that all the if statements return a TRUE value
'''.''' Matches an arbitrary character, but not a newline.
$string1 = "Hello World\n";
if ($string1 =~ m/...../) {
  print "$string1 has length >= 5\n";
}
( ) Groups a series of pattern elements to a single element. When you match a pattern within parentheses, you can use any of $1, $2, ... $9 later to refer to the previously matched pattern.
$string1 = "Hello World\n";
if ($string1 =~ m/(H..).(o..)/) {
  print "We matched '$1' and '$2'\n";
}

Output:
We matched 'Hel' and 'o W';
+ Matches the preceding pattern element one or more times.
$string1 = "Hello World\n";
if ($string1 =~ m/l+/) {
  print "There are one or more consecutive l's in $string1\n";
}
? Matches zero or one times.
$string1 = "Hello World\n";
if ($string1 =~ m/H.?e/) {
  print "There is an 'H' and a 'e' separated by ";
  print "0-1 characters (Ex: He Hoe)\n";
}
? Matches the *, +, or {M,N}'d regexp that comes before as few times as possible.
$string1 = "Hello World\n";
if ($string1 =~ m/(l+?o)/) {
  print "The non-greedy match with one or more 'l' ";
  print "followed by an 'o' is 'lo', not 'llo'.\n";
}
* Matches zero or more times.
$string1 = "Hello World\n";
if ($string =~ m/el*o/) {
  print "There is a 'e' followed by zero to many";
  print "'l' followed by 'o' (eo, elo, ello, elllo)\n";
}
{M,N} Denotes the minimum M and the maximum N match count.
$string1 = "Hello World\n";
if ($string1 =~ m/l{1,2}/) {
 print "There exists a substring with at least 1";
 print "and at most 2 l's in $string1\n";
}
[...] Denotes a set of possible matches.
$string1 = "Hello World\n";
if ($string1 =~ m/[aeiou]+/) {
  print "$string1 contains a one or more";
  print "vowels\n";
}
| Matches one of the left or right operand.
$string1 = "Hello World\n";
if ($string1 =~ m/(Hello|Hi)/) {
  print "Hello or Hi is ";
  print "contained in $string1";
}
\b Matches a word boundary.
$string1 = "Hello World\n";
if ($string1 =~ m/\bllo\b/) {
  print "There is a word that starts with";
  print " 'llo'\n";
} else {
  print "There are no words that start with";

  print "'llo'\n";
}

\w Matches alphanumeric, including "_".
$string1 = "Hello World\n";
if ($string1 =~ m/\w/) {
  print "There is at least one alpha-";
  print "numeric char in $string1 (A-Z, a-z, 0-9, _)\n";
}
\W Matches a non-alphanumeric character.
$string1 = "Hello World\n";
if ($string1 =~ m/\W/) {
  print "The space between Hello and ";
  print "World is not alphanumeric\n";
}
\s Matches a whitespace character (space, tab, newline, formfeed)
$string1 = "Hello World\n";
if ($string1 =~ m/\s.*\s/) {
  print "There are TWO whitespace ";
  print "characters separated by other characters in $string1";
}
\S Matches anything BUT a whitespace.
$string1 = "Hello World\n";
if ($string1 =~ m/\S.*\S/) {
  print "There are TWO non-whitespace ";
  print "characters separated by other characters in $string1";
}
\d Matches a digit, same as [0-9].
$string1 = "99 bottles of beer on the wall.";
if ($string1 =~ m/(\d+)/) {
  print "$1 is the first number in '$string1'\n";
}

Output:
99 is the first number in '99 bottles of beer on the wall.'
\D Matches a non-digit.
$string1 = "Hello World\n";
if ($string1 =~ m/\D/) {
  print "There is at least one character in $string1";
  print "that is not a digit.\n";
}
^ Matches the beginning of a line or string.
$string1 = "Hello World\n";
if ($string1 =~ m/^He/) {
  print "$string1 starts with the characters 'He'\n";
}
$ Matches the end of a line or string.
$string1 = "Hello World\n";
if ($string1 =~ m/rld$/) {
  print "$string1 is a line or string";
  print "that ends with 'rld'\n";
}
[^...] Matches every character except the ones inside brackets.
$string1 = "Hello World\n";
if ($string1 =~ m/[^abc]/) {
  print "$string1 does not contain the characters a, b, and c\n";
}

Note that the 'm' in the above regular expressions, for example m/[^abc]/, is not required in order for perl to recognize the expression as a 'match' (cf. 'substitute': s/a/b/); /[^abc]/ could just as easily be used without the preceding 'm'. The 'm' operator can be used to alter the delimiting character; for example, m{/} may be used to enhance the legibility of patterns such as /\//. See 'perldoc perlre' for more details. In common with [[C programming language|C]], [[obfuscated code]] competitions are an interesting feature of the Perl culture. Similar to obfuscated code but with a different purpose, Perl [[Poetry]] is the practice of writing poems that can actually be compiled by perl. This practice is fairly unique to Perl, due to the large number of regular English words used in the language. New poems can regularly be seen [http://www.perlmonks.org/index.pl?node=Perl%20Poetry here]. == Name == "Perl" was originally named "pearl", after the "pearl of great price" of [[Gospel of Matthew|Matthew]] 13:46. Larry Wall wanted to give the language a short name with positive connotations, and claims he looked at (and rejected) every three- and four-letter word in the dictionary. He even thought of naming it after his wife Gloria. Before the language's official release, Wall discovered that there was already a programming language named "pearl", and changed the spelling of the name. Several [[backronym]]s have been suggested, including the humorous ''Pathologically Eclectic Rubbish Lister''. ''Practical Extraction and Report Language'' has prevailed in many of today's manuals, including the official Perl [[man page]]s. The name is normally capitalized ("Perl") when referring to the language, and uncapitalized ("perl") when referring to the interpreter program itself. (There is a saying in the Perl community that ''"Nothing but perl can parse Perl"''.) It is not appropriate to write "Perl" as "PERL" as it is not an [[acronym]]. == Perl humor == *[http://wikibooks.org/wiki/Programming:Perl_humour Perl humour on wikibooks] *[http://www.perl.com/pub/a/2003/07/16/soto2003.html State of the Onion 2003 (Larry Wall on Perl 6)] *[http://www.cmpe.boun.edu.tr/~kosar/other/lwall.html Larry Wall quotes] *[http://search.cpan.org/~dconway/Lingua-Romana-Perligata-0.50/lib/Lingua/Romana/Perligata.pm Lingua::Romana::Perligata - Write Perl in Latin!] *[http://www.softpanorama.org/Bulletin/Humor/humor092.html Perl Purity Test] == See also == * [[Just another Perl hacker]] * [[Obfuscated Perl contest]] * [[POE]] -- Perl Object Environment * [[Fibonacci number program]] * [[Perl poetry]] == External links == * [http://www.perl.com/ Perl.com] * [http://dmoz.org/Computers/Programming/Languages/Perl/ dmoz on Perl] * [http://www.perl.org/ Perl.org] * [http://www.pm.org/ Perl Mongers user group site] * [http://www.perlmonks.org/ The Perl Monastery] * [http://activestate.com/ ActiveState - Perl for Microsoft Windows platforms] * [http://www.indigostar.com/ IndigoStar], home of [http://www.indigostar.com/indigoperl.htm IndigoPerl], another distribution of Perl for the [[Microsoft Windows]] platform * [http://www.cpan.org/ CPAN - Comprehensive Perl Archive Network] * [http://search.cpan.org/ Search the Comprehensive Perl Archive Network] * [http://dev.perl.org/perl6/ Perl 6 development] * [http://www.parrotcode.org/ Parrot virtual machine] * [http://www.perldoc.com/ Perl POD documentation] * [http://www.wired.com/wired/archive/8.10/cruise_pr.html ''Scripting on the Lido Deck'' by Steve Silberman, Wired Magazine article about Perl Whirl 2000] * [http://www.linuxjournal.com/article.php?sid=3394 Interview with Larry Wall on Perl (May 01, 1999)] * [http://history.perl.org/PerlTimeline.html Perl Timeline] * [http://groups.google.com/groups?selm=4628%40sdcrdcf.UUCP First reference to "Perl" on Usenet] ===Books=== *[[Programming Perl]] (often called the ''Camel book'') ([http://safari.oreilly.com/JVXSL.asp?x=1&mode=section&sortKey=title&sortOrder=asc&view=&xmlid=0-596-00027-8&open=false&g=&srchText=BOOK+AND+%28AUTHOR+Larry+Wall%29&code=&h=&m=&l=1&catid=&s=1&b=1&f=1&t=1&c=1&u=1&r=&o=1&page=0 read online]) * [[Perl Cookbook]] (read online: [http://safari.oreilly.com/JVXSL.asp?x=1&mode=section&sortKey=title&sortOrder=asc&view=&xmlid=0-596-00313-7&open=false&g=&srchText=BOOK+AND+%28BOOKTITLE+perl+cookbook%29&code=&h=&m=&l=1&catid=&s=1&b=1&f=1&t=1&c=1&u=1&r=&o=1&page=0 2nd edition] [http://safari.oreilly.com/JVXSL.asp?x=1&mode=section&sortKey=title&sortOrder=asc&view=&xmlid=1-56592-243-3&open=false&g=&srchText=BOOK+AND+%28BOOKTITLE+perl+cookbook%29&code=&h=&m=&l=1&catid=&s=1&b=1&f=1&t=1&c=1&u=1&r=&o=1&page=0 1st edition]). *[[Learning Perl]] (also called the ''Llama book'') {{List_of_programming_languages}} [[cs:Perl]] [[de:Perl]] [[eo:Perl Komputillingvo]] [[es:Perl]] [[et:Perl]] [[fi:Perl]] [[fr:Perl (langage)]] [[it:Perl]] [[ja:Perl]] [[lt:Perl]] [[nl:Perl]] [[pl:Perl]] [[pt:Perl]] [[sv:Perl]] WWW-Wikipedia-2.04/MANIFEST0000644000175000017500000000112112111440364014437 0ustar bricasbricasbin/wikipedia Changes inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Scripts.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/WWW/Wikipedia.pm lib/WWW/Wikipedia/Entry.pm Makefile.PL MANIFEST This list of files META.yml README t/10.load.t t/11.language.t t/15.entry.t t/16.entry_language.t t/20.search.t t/21.random.t t/25.search_error.t t/26.autoformat.t t/30.ua.t t/40.redirect.t t/98.pod.t t/99.pod_coverage.t t/perl.es.raw t/perl.raw WWW-Wikipedia-2.04/lib/0000755000175000017500000000000012641016615014067 5ustar bricasbricasWWW-Wikipedia-2.04/lib/WWW/0000755000175000017500000000000012641016615014553 5ustar bricasbricasWWW-Wikipedia-2.04/lib/WWW/Wikipedia.pm0000644000175000017500000001520512641016517017023 0ustar bricasbricaspackage WWW::Wikipedia; use 5.006; use strict; use warnings; use Carp qw( croak ); use URI::Escape (); use WWW::Wikipedia::Entry; use base qw( LWP::UserAgent ); our $VERSION = '2.04'; use constant WIKIPEDIA_URL => 'http://%s.wikipedia.org/w/index.php?title=%s&action=raw'; use constant WIKIPEDIA_RAND_URL => 'http://%s.wikipedia.org/wiki/Special:Random'; =head1 NAME WWW::Wikipedia - Automated interface to the Wikipedia =head1 SYNOPSIS use WWW::Wikipedia; my $wiki = WWW::Wikipedia->new(); ## search for 'perl' my $result = $wiki->search( 'perl' ); ## if the entry has some text print it out if ( $result->text() ) { print $result->text(); } ## list any related items we can look up print join( "\n", $result->related() ); =head1 DESCRIPTION WWW::Wikipedia provides an automated interface to the Wikipedia L, which is a free, collaborative, online encyclopedia. This module allows you to search for a topic and return the resulting entry. It also gives you access to related topics which are also available via the Wikipedia for that entry. =head1 INSTALLATION To install this module type the following: perl Makefile.PL make make test make install =head1 METHODS =head2 new() The constructor. You can pass it a two letter language code, or nothing to let it default to 'en'. ## Default: English my $wiki = WWW::Wikipedia->new(); ## use the French wiki instead my $wiki = WWW::Wikipedia->new( language => 'fr' ); WWW::Wikipedia is a subclass of LWP::UserAgent. If you would like to have more control over the user agent (control timeouts, proxies ...) you have full access. ## set HTTP request timeout my $wiki = WWW::Wikipedia->new(); $wiki->timeout( 2 ); You can turn off the following of wikipedia redirect directives by passing a false value to C. Together with the Wiki markup, some entries include HTML tags. They can be stripped out using the C option: my $wiki = WWW::Wikipedia->new( clean_html => 1 ); See C documentation bellow for details. =cut sub new { my ( $class, %opts ) = @_; my $language = delete $opts{ language } || 'en'; my $follow = delete $opts{ follow_redirects }; $follow = 1 if !defined $follow; my $clean_html = delete $opts{ clean_html } || 0; my $self = LWP::UserAgent->new( %opts ); $self->agent( 'WWW::Wikipedia' ); bless $self, ref( $class ) || $class; $self->language( $language ); $self->follow_redirects( $follow ); $self->clean_html( $clean_html ); $self->parse_head( 0 ); return $self; } =head2 language() This allows you to get and set the language you want to use. Two letter language codes should be used. The default is 'en'. my $wiki = WWW::Wikipedia->new( language => 'es' ); # Later on... $wiki->language( 'fr' ); =cut sub language { my ( $self, $language ) = @_; $self->{ language } = $language if $language; return $self->{ language }; } =head2 clean_html() Allows to get/set if HTML is being stripped out. # set HTML strip $wiki->clean_html( 1 ); This option removes all tags and attributes they might have. Their contents, however, is maintained (for now). Comments are also removed. =cut sub clean_html { my ( $self, $bool ) = @_; $self->{ clean_html } = $bool if defined $bool; return $self->{ clean_html }; } =head2 follow_redirects() By default, wikipeda redirect directives are followed. Set this to false to turn that off. =cut sub follow_redirects { my ( $self, $value ) = @_; $self->{ follow_redirects } = $value if defined $value; return $self->{ follow_redirects }; } =head2 search() Which performs the search and returns a WWW::Wikipedia::Entry object which you can query further. See WWW::Wikipedia::Entry docs for more info. $entry = $wiki->search( 'Perl' ); print $entry->text(); If there's a problem connecting to Wikipedia, C will be returned and the error message will be stored in C. =cut sub search { my ( $self, $string ) = @_; $self->error( undef ); croak( "search() requires you pass in a string" ) if !defined( $string ); my $enc_string = utf8::is_utf8( $string ) ? URI::Escape::uri_escape_utf8( $string ) : URI::Escape::uri_escape( $string ); my $src = sprintf( WIKIPEDIA_URL, $self->language(), $enc_string ); my $response = $self->get( $src ); if ( $response->is_success() ) { my $entry = WWW::Wikipedia::Entry->new( $response->decoded_content(), $src, clean_html => $self->{ clean_html } ); # look for a wikipedia style redirect and process if necessary # try to catch self-redirects return $self->search( $1 ) if $self->follow_redirects && $entry->raw() =~ /^#REDIRECT\s*\[\[([^|\]]+)/is && $1 ne $string; return ( $entry ); } else { $self->error( "uhoh, WWW::Wikipedia unable to contact " . $src ); return undef; } } =head2 random() This method fetches a random wikipedia page. =cut sub random { my ( $self ) = @_; my $src = sprintf( WIKIPEDIA_RAND_URL, $self->language() ); my $response = $self->get( $src ); if ( $response->is_success() ) { # get the raw version of the current url my( $title ) = $response->request->uri =~ m{\.org/wiki/(.+)$}; $src = sprintf( WIKIPEDIA_URL, $self->language(), $title ); $response = $self->get( $src ); return WWW::Wikipedia::Entry->new( $response->decoded_content(), $src, clean_html => $self->{ clean_html } ); } $self->error( "uhoh, WWW::Wikipedia unable to contact " . $src ); return; } =head2 error() This is a generic error accessor/mutator. You can retrieve any searching error messages here. =cut sub error { my $self = shift; if ( @_ ) { $self->{ _ERROR } = shift; } return $self->{ _ERROR }; } =head1 TODO =over 4 =item * Be more specific on the HTML clean methodology. For now all tags are removed, keeping only their contents. In the future the behaviour might change accordingly with each specific tag. =item * Watch the development of Special:Export XML formatting, eg: http://en.wikipedia.org/wiki/Special:Export/perl =back =head1 SEE ALSO =over 4 =item * LWP::UserAgent =back =head1 REPOSITORY L =head1 AUTHORS Ed Summers Eehs@pobox.comE Brian Cassidy Ebricas@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2003-2015 by Ed Summers This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1; WWW-Wikipedia-2.04/lib/WWW/Wikipedia/0000755000175000017500000000000012641016615016461 5ustar bricasbricasWWW-Wikipedia-2.04/lib/WWW/Wikipedia/Entry.pm0000644000175000017500000001727512641016523020132 0ustar bricasbricaspackage WWW::Wikipedia::Entry; use 5.006; use strict; use warnings; use Text::Autoformat; use WWW::Wikipedia; our $VERSION = '2.04'; =head1 NAME WWW::Wikipedia::Entry - A class for representing a Wikipedia Entry =head1 SYNOPSIS my $wiki = WWW::Wikipedia->new(); my $entry = $wiki->search( 'Perl' ); print $entry->text(); my $entry_es = $entry->language( 'es' ); print $entry_es->text(); =head1 DESCRIPTION WWW::Wikipedia::Entry objects are usually created using the search() method on a WWW::Wikipedia object to search for a term. Once you've got an entry object you can then extract pieces of information from the entry using the following methods. =head1 METHODS =head2 new() You probably won't use this one, it's the constructor that is called behind the scenes with the correct arguments by WWW::Wikipedia::search(). =cut sub new { my ( $class, $raw, $src, %ops ) = @_; return if length( $raw ) == 0; my $self = bless { raw => $raw, src => $src, text => '', fulltext => '', cursor => 0, related => [], categories => [], headings => [], languages => {}, currentlang => '' }, ref( $class ) || $class; $self->_parse(); # store un-"pretty"-ed version of text $self->{ fulltext_basic } = $self->{ fulltext }; $self->{ text_basic } = $self->{ text }; if ($ops{clean_html}) { $self->{ fulltext } = _clean_html( $self->{ fulltext }); $self->{ text } = _clean_html( $self->{ text }); } $self->{ fulltext } = _pretty( $self->{ fulltext } ); $self->{ text } = _pretty( $self->{ text } ); return ( $self ); } =head2 text() The brief text for the entry. This will provide the first paragraph of text; basically everything up to the first heading. Ordinarily this will be what you want to use. When there doesn't appear to be summary text you will be returned the fulltext instead. If text() returns nothing then you probably are looking at a disambiguation entry, and should use related() to lookup more specific entries. =cut sub text { my $self = shift; return $self->{ text } if $self->{ text }; return $self->fulltext(); } =head2 text_basic() The same as C, but not run through Text::Autoformat. =cut sub text_basic { my $self = shift; return $self->{ text_basic } if $self->{ text_basic }; return $self->fulltext_basic(); } =head2 fulltext() Returns the full text for the entry, which can be extensive. =cut sub fulltext { my $self = shift; return $self->{ fulltext }; } =head2 fulltext_basic() The same as C, but not run through Text::Autoformat. =cut sub fulltext_basic { my $self = shift; return $self->{ fulltext_basic }; } =head2 title() Returns a title of the entry. =cut sub title { my $self = shift; return $self->{ title }; } =head2 related() Returns a list of terms in the wikipedia that are mentioned in the entry text. =cut sub related { return ( @{ shift->{ related } } ); } =head2 categories() Returns a list of categories which the entry is part of. So Perl is part of the Programming languages category. =cut sub categories { return ( @{ shift->{ categories } } ); } =head2 headings() Returns a list of headings used in the entry. =cut sub headings { return ( @{ shift->{ headings } } ); } =head2 raw() Returns the raw wikitext for the entry. =cut sub raw { my $self = shift; return $self->{ raw }; } =head2 language() With no parameters, it will return the current language of the entry. By specifying a two-letter language code, it will return the same entry in that language, if available. =cut sub language { my $self = shift; my $lang = shift; return $self->{ currentlang } unless defined $lang; return undef unless exists $self->{ languages }->{ $lang }; my $wiki = WWW::Wikipedia->new( language => $lang ); return $wiki->search( $self->{ languages }->{ $lang } ); } =head2 languages() Returns an array of two letter language codes denoting the languages in which this entry is available. =cut sub languages { my $self = shift; return keys %{ $self->{ languages } }; } ## messy internal routine for barebones parsing of wikitext sub _parse { my $self = shift; my $raw = $self->{ raw }; my $src = $self->{ src }; # Add current language my ( $lang ) = ( $src =~ /http:\/\/(..)/ ); my $title = ( split( /\//, $src ) )[ -1 ]; if( $title =~ m{\?title=} ) { ( $title ) = $src =~ m{\?title=([^\&]+)}; $title =~ s{_}{ }g; } $self->{ currentlang } = $lang; $self->{ languages }->{ $lang } = $title; $self->{ title } = $title; for ( $self->{ cursor } = 0; $self->{ cursor } < length( $raw ); $self->{ cursor }++ ) { pos( $raw ) = $self->{ cursor }; ## [[ ... ]] if ( $raw =~ /\G\[\[ *(.*?) *\]\]/ ) { my $directive = $1; $self->{ cursor } += length( $& ) - 1; if ( $directive =~ /\:/ ) { my ( $type, $text ) = split /:/, $directive; if ( lc( $type ) eq 'category' ) { push( @{ $self->{ categories } }, $text ); } # language codes if ( length( $type ) == 2 and lc( $type ) eq $type ) { $self->{ languages }->{ $type } = $text; } } elsif ( $directive =~ /\|/ ) { my ( $lookup, $name ) = split /\|/, $directive; $self->{ fulltext } .= $name; push( @{ $self->{ related } }, $lookup ) if $lookup !~ /^#/; } else { $self->{ fulltext } .= $directive; push( @{ $self->{ related } }, $directive ); } } ## === heading 2 === elsif ( $raw =~ /\G=== *(.*?) *===/ ) { ### don't bother storing these headings $self->{ fulltext } .= $1; $self->{ cursor } += length( $& ) - 1; next; } ## == heading 1 == elsif ( $raw =~ /\G== *(.*?) *==/ ) { push( @{ $self->{ headings } }, $1 ); $self->{ text } = $self->{ fulltext } if !$self->{ seenHeading }; $self->{ seenHeading } = 1; $self->{ fulltext } .= $1; $self->{ cursor } += length( $& ) - 1; next; } ## '' italics '' elsif ( $raw =~ /\G'' *(.*?) *''/ ) { $self->{ fulltext } .= $1; $self->{ cursor } += length( $& ) - 1; next; } ## {{ disambig }} elsif ( $raw =~ /\G\{\{ *(.*?) *\}\}/ ) { ## ignore for now $self->{ cursor } += length( $& ) - 1; next; } else { $self->{ fulltext } .= substr( $raw, $self->{ cursor }, 1 ); } } } # future versions might clean tag contents for some specific ones. sub _clean_html { my $text = shift; # force first letter so that standalone < might be kept $text =~ s{<[/a-zA-Z!][^>]+>}{}g; return $text; } sub _pretty { my $text = shift; # Text::Autoformat v1.13 chokes on strings that are one or more "\n" return '' if $text =~ m/^\n+$/; return autoformat( $text, { left => 0, right => 80, justify => 'left', all => 1 } ); } =head1 AUTHORS Ed Summers Eehs@pobox.comE Brian Cassidy Ebricas@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2003-2015 by Ed Summers This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1;