--- /dev/null
+Revision history for BackPAN
+
+0.01
+ First version, released on an unsuspecting world.
--- /dev/null
+Changes
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/BackPAN/Web.pm
+Makefile.PL
+MANIFEST
+META.yml
+README
+root/about.html
+root/listing.html
+root/static/main.css
+script/backpan.psgi
+script/update_index.pl
+t/00-load.t
+t/boilerplate.t
+t/manifest.t
+t/pod-coverage.t
+t/pod.t
--- /dev/null
+use inc::Module::Install;
+
+name 'BackPAN';
+all_from 'lib/BackPAN/Web.pm';
+author q{Wallace Reis <wreis@cpan.org>};
+license 'perl';
+
+test_requires 'Test::More';
+
+requires 'parent';
+requires 'CLASS' => '1.00';
+requires 'DBD::SQLite' => '1.25';
+requires 'App::Cache' => '0.37';
+requires 'Class::Accessor::Fast';
+requires 'CPAN::DistnameInfo' => '0.09';
+requires 'Archive::Extract';
+requires 'autodie';
+requires 'Path::Class' => '0.17';
+requires 'LWP::Simple';
+requires 'DBIx::Class::Schema::Loader' => '0.05003';
+requires 'DBIx::Class' => '0.08109';
+requires 'Plack' => '0.9910';
+requires 'Plack::Middleware::Debug';
+requires 'Web::Simple';
+requires 'HTML::Zoom';
+requires 'Template::Tiny';
+requires 'Data::Page::FlickrLike';
+requires 'DateTime';
+requires 'Log::Log4perl';
+requires 'Log::Dispatch';
+requires 'Mail::Send';
+
+auto_install;
+
+WriteAll;
--- /dev/null
+BackPAN
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+LICENSE AND COPYRIGHT
+
+Copyright (C) 2010 Wallace Reis
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See http://dev.perl.org/licenses/ for more information.
--- /dev/null
+package BackPAN::Index;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.39';
+
+use autodie;
+use App::Cache 0.37;
+use CPAN::DistnameInfo 0.09;
+use LWP::Simple qw(getstore head is_success);
+use Archive::Extract;
+use Path::Class ();
+use File::stat;
+use BackPAN::Index::Schema;
+
+use parent qw( Class::Accessor::Fast );
+
+__PACKAGE__->mk_accessors(qw(
+ update
+ cache_ttl
+ debug
+ releases_only_from_authors
+ cache_dir
+ backpan_index_url
+
+ backpan_index schema cache
+));
+
+my %Defaults = (
+ backpan_index_url => "http://www.astray.com/tmp/backpan.txt.gz",
+ releases_only_from_authors => 1,
+ debug => 0,
+ cache_ttl => 60 * 60,
+);
+
+
+sub new {
+ my $class = shift;
+ my $options = shift;
+
+ $options ||= {};
+
+ # Apply defaults
+ %$options = ( %Defaults, %$options );
+
+ my $self = $class->SUPER::new($options);
+
+ my %cache_opts;
+ $cache_opts{ttl} = $self->cache_ttl;
+ $cache_opts{directory} = $self->cache_dir if $self->cache_dir;
+ $cache_opts{enabled} = !$self->update;
+
+ my $cache = App::Cache->new( \%cache_opts );
+ $self->cache($cache);
+
+ $self->_update_database();
+
+ return $self;
+}
+
+sub _dbh {
+ my $self = shift;
+ return $self->schema->storage->dbh;
+}
+
+sub _log {
+ my $self = shift;
+ return unless $self->debug;
+ print STDERR @_, "\n";
+}
+
+sub _update_database {
+ my $self = shift;
+
+ my $cache = $self->cache;
+ my $db_file = Path::Class::file($cache->directory, "backpan.sqlite");
+
+ my $should_update_db;
+ if( ! -e $db_file ) {
+ $should_update_db = 1;
+ }
+ elsif( defined $self->update ) {
+ $should_update_db = $self->update;
+ }
+ else {
+ # Check the database file before we connect to it. Connecting will create
+ # the file.
+ # XXX Should probably just put a timestamp in the DB
+ my $db_mtime = $db_file->stat->mtime;
+ my $db_age = time - $db_mtime;
+ $should_update_db = ($db_age > $cache->ttl);
+
+ # No matter what, update the DB if we got a new index file.
+ my $archive_mtime = -e $self->_backpan_index_archive ? $self->_backpan_index_archive->stat->mtime : 0;
+ $should_update_db = 1 if $db_mtime < $archive_mtime;
+ }
+
+ unlink $db_file if -e $db_file and $should_update_db;
+
+ $self->schema( BackPAN::Index::Schema->connect("dbi:SQLite:dbname=$db_file") );
+ return unless $should_update_db;
+
+ # Delay loading it into memory until we need it
+ $self->_log("Fetching BackPAN index...");
+ $self->_get_backpan_index;
+ $self->_log("Done.");
+
+ $self->_setup_database;
+
+ $should_update_db = 1 if $self->_database_is_empty;
+
+ return unless $should_update_db;
+
+ my $dbh = $self->_dbh;
+
+ $self->_log("Populating database...");
+ $dbh->begin_work;
+
+ # Get it out of the hot loop.
+ my $only_authors = $self->releases_only_from_authors;
+
+ my $insert_file_sth = $dbh->prepare(q[
+ INSERT INTO files
+ (path, date, size)
+ VALUES (?, ?, ? )
+ ]);
+
+ my $insert_release_sth = $dbh->prepare(q[
+ INSERT INTO releases
+ (path, dist, version, date, size, maturity, cpanid, distvname)
+ VALUES (?, ?, ?, ?, ?, ?, ?, ? )
+ ]);
+
+ my $insert_dist_sth = $dbh->prepare(q[
+ INSERT INTO dists
+ (name, num_releases,
+ first_release, first_date, first_author,
+ latest_release, latest_date, latest_author)
+ VALUES (?, ?,
+ ?, ?, ?,
+ ?, ?, ?)
+ ]);
+
+ my %dists;
+ my %files;
+ open my $fh, $self->_backpan_index_file;
+ while( my $line = <$fh> ) {
+ chomp $line;
+ my ( $path, $date, $size, @junk ) = split ' ', $line;
+
+ if( $files{$path}++ ) {
+ $self->_log("Duplicate file $path in index, ignoring");
+ next;
+ }
+
+ if( !defined $path or !defined $date or !defined $size or @junk ) {
+ $self->_log("Bad data read at line $.: $line");
+ next;
+ }
+
+ next unless $size;
+ next if $only_authors and $path !~ m{^authors/};
+
+ $insert_file_sth->execute($path, $date, $size);
+
+ next if $path =~ /\.(readme|meta)$/;
+
+ my $i = CPAN::DistnameInfo->new( $path );
+
+ my $dist = $i->dist;
+ next unless $i->dist;
+
+ $insert_release_sth->execute(
+ $path,
+ $dist,
+ $i->version || '',
+ $date,
+ $size,
+ $i->maturity,
+ $i->cpanid,
+ $i->distvname,
+ );
+
+
+ # Update aggregate data about dists
+ my $distdata = ($dists{$dist} ||= { name => $dist });
+
+ if( !defined $distdata->{first_release} ||
+ $date < $distdata->{first_date} )
+ {
+ $distdata->{first_release} = $path;
+ $distdata->{first_author} = $i->cpanid;
+ $distdata->{first_date} = $date;
+ }
+
+ if( !defined $distdata->{latest_release} ||
+ $date > $distdata->{latest_date} )
+ {
+ $distdata->{latest_release} = $path;
+ $distdata->{latest_author} = $i->cpanid;
+ $distdata->{latest_date} = $date;
+ }
+
+ $distdata->{num_releases}++;
+ }
+
+ for my $dist (values %dists) {
+ $insert_dist_sth->execute(
+ @{$dist}
+ {qw(name num_releases
+ first_release first_date first_author
+ latest_release latest_date latest_author
+ )}
+ );
+ }
+
+ # Add indexes after inserting so as not to slow down the inserts
+ $self->_add_indexes;
+
+ $dbh->commit;
+
+ $self->_log("Done.");
+
+ return;
+}
+
+
+sub _database_is_empty {
+ my $self = shift;
+
+ return 1 unless $self->files->count;
+ return 1 unless $self->releases->count;
+ return 0;
+}
+
+
+# This is denormalized for performance, its read-only anyway
+sub _setup_database {
+ my $self = shift;
+
+ my %create_for = (
+ files => <<'SQL',
+CREATE TABLE IF NOT EXISTS files (
+ path TEXT NOT NULL PRIMARY KEY,
+ date INTEGER NOT NULL,
+ size INTEGER NOT NULL CHECK ( size >= 0 )
+)
+SQL
+ releases => <<'SQL',
+CREATE TABLE IF NOT EXISTS releases (
+ path TEXT NOT NULL PRIMARY KEY REFERENCES files,
+ dist TEXT NOT NULL REFERENCES dists,
+ date INTEGER NOT NULL,
+ size TEXT NOT NULL,
+ version TEXT NOT NULL,
+ maturity TEXT NOT NULL,
+ distvname TEXT NOT NULL,
+ cpanid TEXT NOT NULL
+)
+SQL
+
+ dists => <<'SQL',
+CREATE TABLE IF NOT EXISTS dists (
+ name TEXT NOT NULL PRIMARY KEY,
+ first_release TEXT NOT NULL REFERENCES releases,
+ latest_release TEXT NOT NULL REFERENCES releases,
+ first_date INTEGER NOT NULL,
+ latest_date INTEGER NOT NULL,
+ first_author TEXT NOT NULL,
+ latest_author TEXT NOT NULL,
+ num_releases INTEGER NOT NULL
+)
+SQL
+);
+
+ my $dbh = $self->_dbh;
+ for my $sql (values %create_for) {
+ $dbh->do($sql);
+ }
+
+ $self->schema->rescan;
+
+ return;
+}
+
+
+sub _add_indexes {
+ my $self = shift;
+
+ my @indexes = (
+ # Speed up dists_by several orders of magnitude
+ "CREATE INDEX IF NOT EXISTS dists_by ON releases (cpanid, dist)",
+
+ # Speed up files_by a lot
+ "CREATE INDEX IF NOT EXISTS files_by ON releases (cpanid, path)",
+
+ # Let us order releases by date quickly
+ "CREATE INDEX IF NOT EXISTS releases_by_date ON releases (date, dist)",
+ );
+ my $dbh = $self->_dbh;
+ for my $sql (@indexes) {
+ $dbh->do($sql);
+ }
+}
+
+
+sub _get_backpan_index {
+ my $self = shift;
+
+ my $url = $self->backpan_index_url;
+
+ return if !$self->_backpan_index_has_changed;
+
+ my $status = getstore($url, $self->_backpan_index_archive.'');
+ die "Error fetching $url: $status" unless is_success($status);
+
+ # Faster
+ local $Archive::Extract::PREFER_BIN = 1;
+
+ # Archive::Extract is vulnerable to the ORS.
+ local $\;
+
+ my $ae = Archive::Extract->new( archive => $self->_backpan_index_archive );
+ $ae->extract( to => $self->_backpan_index_file )
+ or die "Problem extracting @{[ $self->_backpan_index_archive ]}: @{[ $ae->error ]}";
+
+ # If the backpan index age is older than the TTL this prevents us
+ # from immediately looking again.
+ # XXX Should probably use a "last checked" semaphore file
+ $self->_backpan_index_file->touch;
+
+ return;
+}
+
+
+sub _backpan_index_archive {
+ my $self = shift;
+
+ my $file = URI->new($self->backpan_index_url)->path;
+ $file = Path::Class::file($file)->basename;
+ return Path::Class::file($file)->absolute($self->cache->directory);
+}
+
+
+sub _backpan_index_file {
+ my $self = shift;
+
+ my $file = $self->_backpan_index_archive;
+ $file =~ s{\.[^.]+$}{};
+
+ return Path::Class::file($file);
+}
+
+
+sub _backpan_index_has_changed {
+ my $self = shift;
+
+ my $file = $self->_backpan_index_file;
+ return 1 unless -e $file;
+
+ my $local_mod_time = stat($file)->mtime;
+ my $local_age = time - $local_mod_time;
+ return 0 unless $local_age > $self->cache->ttl;
+
+ # We looked, don't have to look again until the ttl is up.
+ $self->_backpan_index_file->touch;
+
+ my(undef, undef, $remote_mod_time) = head($self->backpan_index_url);
+ return $remote_mod_time > $local_mod_time;
+}
+
+
+sub files {
+ my $self = shift;
+ return $self->schema->resultset('File');
+}
+
+
+sub dist {
+ my($self, $dist) = @_;
+
+ return $self->dists->single({ name => $dist });
+}
+
+
+sub releases {
+ my($self, $dist) = @_;
+
+ return $self->schema->resultset("Release") unless defined $dist;
+ return $self->schema->resultset("Release")->search({ dist => $dist });
+}
+
+
+sub release {
+ my($self, $dist, $version) = @_;
+
+ return $self->releases($dist)->single({ version => $version });
+}
+
+
+sub dists {
+ my $self = shift;
+
+ return $self->schema->resultset("Dist");
+}
+
+
+=head1 NAME
+
+BackPAN::Index - An interface to the BackPAN index
+
+=head1 SYNOPSIS
+
+ use BackPAN::Index;
+ my $backpan = BackPAN::Index->new;
+
+ # These are all DBIx::Class::ResultSet's
+ my $files = $backpan->files;
+ my $dists = $backpan->dists;
+ my $releases = $backpan->releases("Acme-Pony");
+
+ # Use DBIx::Class::ResultSet methods on them
+ my $release = $releases->single({ version => '1.23' });
+
+ my $dist = $backpan->dist("Test-Simple");
+ my $releases = $dist->releases;
+
+=head1 DESCRIPTION
+
+This downloads, caches and parses the BackPAN index into a local
+database for efficient querying.
+
+Its a pretty thin wrapper around DBIx::Class returning
+L<DBIx::Class::ResultSet> objects which makes it efficient and
+flexible.
+
+The Comprehensive Perl Archive Network (CPAN) is a very useful
+collection of Perl code. However, in order to keep CPAN relatively
+small, authors of modules can delete older versions of modules to only
+let CPAN have the latest version of a module. BackPAN is where these
+deleted modules are backed up. It's more like a full CPAN mirror, only
+without the deletions. This module provides an index of BackPAN and
+some handy methods.
+
+=head1 METHODS
+
+=head2 new
+
+ my $backpan = BackPAN::Index->new(\%options);
+
+Create a new object representing the BackPAN index.
+
+It will, if necessary, download the BackPAN index and compile it into
+a database for efficient storage. Initial creation is slow, but it
+will be cached.
+
+new() takes some options
+
+=head3 update
+
+Because it is rather large, BackPAN::Index caches a copy of the
+BackPAN index and builds a local database to speed access. This flag
+controls if the local index is updated.
+
+If true, forces an update of the BACKPAN index.
+
+If false, the index will never be updated even if the cache is
+expired. It will always create a new index if one does not exist.
+
+By default the index is cached and checked for updates according to
+C<<$backpan->cache_ttl>>.
+
+=head3 cache_ttl
+
+How many seconds before checking for an updated index.
+
+Defaults to an hour.
+
+=head3 debug
+
+If true, debug messages will be printed.
+
+Defaults to false.
+
+=head3 releases_only_from_authors
+
+If true, only files in the C<authors> directory will be considered as
+releases. If false any file in the index may be considered for a
+release.
+
+Defaults to true.
+
+=head3 cache_dir
+
+Location of the cache directory.
+
+Defaults to whatever L<App::Cache> does.
+
+=head3 backpan_index_url
+
+URL to the BackPAN index.
+
+Defaults to a sensible location.
+
+
+=head2 files
+
+ my $files = $backpan->files;
+
+Returns a ResultSet representing all the files on BackPAN.
+
+=head2 files_by
+
+ my $files = $backpan->files_by($cpanid);
+ my @files = $backpan->files_by($cpanid);
+
+Returns all the files by a given $cpanid.
+
+Returns either a list of BackPAN::Index::Files or a ResultSet.
+
+=cut
+
+sub files_by {
+ my $self = shift;
+ my $cpanid = shift;
+
+ return $self->files->search({ "releases.cpanid" => $cpanid }, { join => "releases" });
+}
+
+=head2 dists
+
+ my $dists = $backpan->dists;
+
+Returns a ResultSet representing all the distributions on BackPAN.
+
+=head2 dist
+
+ my $dists = $backpan->dist($dist_name);
+
+Returns a single BackPAN::Index::Dist object for $dist_name.
+
+=head2 dists_by
+
+ my $dists = $backpan->dists_by($cpanid);
+ my @dists = $backpan->dists_by($cpanid);
+
+Returns the dists which contain at least one release by the given
+$cpanid.
+
+Returns either a ResultSet or a list of the Dists.
+
+=cut
+
+sub dists_by {
+ my $self = shift;
+ my $cpanid = shift;
+
+ return $self->dists->search({ "releases.cpanid" => $cpanid }, { join => "releases", distinct => 1 });
+}
+
+
+=head2 dists_changed_since
+
+ my $dists = $backpan->dists_changed_since($time);
+
+Returns a ResultSet of distributions which have had releases at or after after $time.
+
+=cut
+
+sub dists_changed_since {
+ my $self = shift;
+ my $time = shift;
+
+ return $self->dists->search( latest_date => \">= $time" );
+}
+
+=head2 releases
+
+ my $all_releases = $backpan->releases();
+ my $dist_releases = $backpan->releases($dist_name);
+
+Returns a ResultSet representing all the releases on BackPAN. If a
+$dist_name is given it returns the releases of just one distribution.
+
+=head2 release
+
+ my $release = $backpan->release($dist_name, $version);
+
+Returns a single BackPAN::Index::Release object for the given
+$dist_name and $version.
+
+=head2 releases_by
+
+ my $releases = $backpan->releases_by($cpanid);
+ my @releases = $backpan->releases_by($cpanid);
+
+Returns all the releases of a single author.
+
+Returns either a list of Releases or a ResultSet representing those releases.
+
+=cut
+
+sub releases_by {
+ my $self = shift;
+ my $cpanid = shift;
+
+ return $self->releases->search({ cpanid => $cpanid });
+}
+
+
+=head2 releases_since
+
+ my $releases = $backpan->releases_since($time);
+
+Returns a ResultSet of releases which were released at or after $time.
+
+=cut
+
+sub releases_since {
+ my $self = shift;
+ my $time = shift;
+
+ return $self->releases->search( date => \">= $time" );
+}
+
+
+=head1 EXAMPLES
+
+The real power of BackPAN::Index comes from L<DBIx::Class::ResultSet>.
+Its very flexible and very powerful but not always obvious how to get
+it to do things. Here's some examples.
+
+ # How many files are on BackPAN?
+ my $count = $backpan->files->count;
+
+ # How big is BackPAN?
+ my $size = $backpan->files->get_column("size")->sum;
+
+ # What are the names of all the distributions?
+ my @names = $backpan->dists->get_column("name")->all;
+
+ # What path contains this release?
+ my $path = $backpan->release("Acme-Pony", 1.01)->path;
+
+ # Get all the releases of Moose ordered by version
+ my @releases = $backpan->dist("Moose")->releases
+ ->search(undef, { order_by => "version" });
+
+=head1 AUTHOR
+
+Michael G Schwern <schwern@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright 2009, Michael G Schwern
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::ResultSet>, L<BackPAN::Index::File>,
+L<BackPAN::Index::Release>, L<BackPAN::Index::Dist>
+
+Repository: L<http://github.com/acme/parse-backpan-packages>
+Bugs: L<http://rt.cpan.org/Public/Dist/Display.html?Name=Parse-BACKPAN-Packages>
+
+=cut
+
+1;
--- /dev/null
+package BackPAN::Index::Dist;
+
+use strict;
+use warnings;
+
+use CLASS;
+use BackPAN::Index::Role::AsHash;
+
+use overload
+ q[""] => sub { $_[0]->name },
+ fallback => 1;
+
+sub data_methods {
+ return qw(
+ name num_releases
+ first_release first_date first_author
+ latest_release latest_date latest_author
+ );
+}
+
+sub authors {
+ my $self = shift;
+
+ return $self->releases->search(undef, { distinct => 1 })->get_column("cpanid")->all;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+BackPAN::Index::Dist - Representing a distribution on BackPAN
+
+=head1 SYNOPSIS
+
+Use through BackPAN::Index.
+
+=head1 DESCRIPTION
+
+An object representing a distribution on BackPAN. A distribution is
+made up of releases.
+
+=head2 releases
+
+ my $releases = $dist->releases;
+
+A ResultSet of this distribution's releases.
+
+=head2 name
+
+ my $dist_name = $dist->name;
+
+Name of the distribution.
+
+=head2 authors
+
+ my @authors = $dist->authors;
+
+Return the CPANIDs which made releases of this $dist, in no particular order.
+
+=head2 num_releases
+
+ my $num_releases = $dist->num_releases;
+
+Returns the number of releases this distribution has.
+
+=head2 first_release
+
+=head2 latest_release
+
+ my $release = $dist->first_release;
+
+Returns the first or latest release of this distribution as a BackPAN::Index::Release.
+
+=head2 first_date
+
+=head2 latest_date
+
+ my $release = $dist->first_date;
+
+Returns the date of the first or latest release of this distribution.
+
+=head2 first_author
+
+=head2 latest_author
+
+ my $cpanid = $dist->first_author;
+
+Returns the CPANID of the author of the first or latest release.
+
+=head2 as_hash
+
+ my $data = $dist->as_hash;
+
+Returns a hash ref containing the data inside C<$dist>.
+
+
+=head1 SEE ALSO
+
+L<BackPAN::Index>
+
+=cut
+
+1;
--- /dev/null
+package BackPAN::Index::File;
+
+use strict;
+use warnings;
+
+use File::Basename qw(basename);
+
+use overload
+ q[""] => sub { $_[0]->path },
+ fallback => 1;
+
+use BackPAN::Index::Role::AsHash;
+
+sub data_methods {
+ return qw(path date size);
+}
+
+sub url {
+ my $self = shift;
+ return "http://backpan.cpan.org/" . $self->path;
+}
+
+sub filename {
+ my $self = shift;
+ return basename $self->path;
+}
+
+# Backwards compatibility with PBP
+sub prefix {
+ my $self = shift;
+ return $self->path;
+}
+
+sub release {
+ my $self = shift;
+
+ my $schema = $self->result_source->schema;
+ my($release) = $schema->resultset("Release")
+ ->search({ file => $self->path }, { rows => 1 })
+ ->first;
+
+ return $release;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+BackPAN::Index::File - Represent a file on BackPAN
+
+=head1 SYNOPSIS
+
+ my $b = BackPAN::Index->new();
+ my $file = $b->file("authors/id/L/LB/LBROCARD/Acme-Colour-0.16.tar.gz");
+ print " Date: " . $file->date . "\n";
+ print " Path: " . $file->path . "\n";
+ print " Size: " . $file->size . "\n";
+ print " URL: " . $file->url . "\n";
+
+=head1 DESCRIPTION
+
+BackPAN::Index::File objects represent files on BackPAN. It may
+represent a release, a readme or meta file or just some random stuff
+on BackPAN.
+
+=head1 METHODS
+
+=head2 date
+
+ my $date = $file->date;
+
+Returns the upload date of the file, in UNIX epoch seconds.
+
+=head2 path
+
+ my $path = $file->path;
+
+Returns the full path to the file on CPAN.
+
+=head2 size
+
+ my $size = $file->size;
+
+Returns the size of the file in bytes.
+
+=head2 url
+
+ my $url = $file->url;
+
+Returns a URL to the file on a BackPAN mirror.
+
+=head2 filename
+
+ my $filename = $file->filename;
+
+Returns the filename part of the path.
+
+=head2 release
+
+ my $release = $file->release;
+
+Returns the release associated with this file, if any, as a
+L<BackPAN::Index::Release> instance.
+
+=head2 as_hash
+
+ my $data = $file->as_hash;
+
+Returns a hash ref containing the data inside C<$file>.
+
+
+=head1 AUTHOR
+
+Leon Brocard <acme@astray.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2009, Leon Brocard
+
+This module is free software; you can redistribute it or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<BackPAN::Index>, L<BackPAN::Index::Release>
--- /dev/null
+package BackPAN::Index::Release;
+
+use strict;
+use warnings;
+
+use overload
+ q[""] => sub { $_[0]->distvname },
+ fallback => 1;
+
+use BackPAN::Index::Role::AsHash;
+
+sub data_methods {
+ return qw(dist version cpanid date path maturity);
+}
+
+sub filename {
+ my $self = shift;
+ return $self->path->filename;
+}
+
+# Compatibility with PBP
+sub prefix {
+ my $self = shift;
+ return $self->path;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+BackPAN::Index::Release - A single release of a distribution
+
+=head1 SYNOPSIS
+
+ my $b = BackPAN::Index->new();
+
+ # Find version 1.2.3 of Acme-Colour
+ my $release = $b->release("Acme-Colour", '1.2.3');
+
+ print " CPANID: " . $release->cpanid . "\n";
+ print " Date: " . $release->date . "\n";
+ print " Dist: " . $release->dist . "\n";
+ print "Distvname: " . $release->distvname . "\n";
+ print " Filename: " . $release->filename . "\n";
+ print " Maturity: " . $release->maturity . "\n";
+ print " Path: " . $release->path . "\n";
+ print " Version: " . $release->version . "\n";
+
+=head1 DESCRIPTION
+
+BackPAN::Index::Release objects represent releases,
+individual tarballs/zip files, of a distribution on BackPAN.
+
+For example, Acme-Pony-1.2.3.tar.gz is a release of the Acme-Pony
+distribution.
+
+=head1 METHODS
+
+=head2 cpanid
+
+ my $cpanid = $release->cpanid;
+
+Returns the PAUSE ID of the author of the release.
+
+=head2 date
+
+ my $date = $release->date;
+
+Returns the date of the release, in UNIX epoch seconds.
+
+=head2 dist
+
+ my $dist_name = $release->dist;
+
+Returns the name of the distribution this release belongs to.
+
+=head2 distvname
+
+ my $distvname = $release->distvname;
+
+Returns the name of the distribution, hyphen, and version.
+
+=head2 filename
+
+ my $filename = $release->filename;
+
+Returns the filename of the release, just the file part.
+
+=head2 maturity
+
+ my $maturity = $release->maturity;
+
+Returns the maturity of the release.
+
+=head2 path
+
+ my $path = $release->path;
+
+Returns the full path on CPAN to the release. This is a
+L<BackPAN::File> object.
+
+=head2 version
+
+ my $version = $release->version;
+
+Returns the version of the release:
+
+=head2 as_hash
+
+ my $data = $release->as_hash;
+
+Returns a hash ref containing the data inside C<$release>.
+
+
+=head1 AUTHOR
+
+Leon Brocard <acme@astray.com> and Michael G Schwern <schwern@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-2009, Leon Brocard
+
+This module is free software; you can redistribute it or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<BackPAN::Index>, L<BackPAN::Index::Dist>, L<BackPAN::Index::File>
+
--- /dev/null
+package BackPAN::Index::Role::AsHash;
+
+use strict;
+use warnings;
+
+use base 'Exporter';
+our @EXPORT = qw(as_hash);
+our @REQUIRED = qw(data_methods);
+
+use CLASS;
+
+sub as_hash {
+ my $self = shift;
+
+ my %data;
+ for my $method ($self->data_methods) {
+ $data{$method} = $self->$method;
+ }
+
+ return \%data;
+}
+
+
+=head1 NAME
+
+BackPAN::Index::Role::AsHash - Role to dump object data as a hash
+
+=head1 SYNOPSIS
+
+ use BackPAN::Index::Role::AsHash;
+
+ sub data_methods { return qw(list of data methods) }
+
+=head1 DESCRIPTION
+
+A role to implement C<<as_hash>> in result objects.
+
+=head2 Requires
+
+The receiving class must implement...
+
+=head3 data_methods
+
+ my @methods = $self->data_methods;
+
+Returns a list of methods which get data about the object.
+
+=head2 Implements
+
+=head3 as_hash
+
+ my $hash = $self->as_hash;
+
+Produces a hash reference representing the object's data based on
+C<<$self->data_methods>>. Each key is a method name, the value is
+C<<$self->$method>>.
+
+=cut
+
+1;
--- /dev/null
+package BackPAN::Index::Schema;
+
+use strict;
+use warnings;
+
+use parent qw(DBIx::Class::Schema::Loader);
+
+use CLASS;
+
+CLASS->loader_options(
+ moniker_map => sub {
+ my $table = shift;
+ my $class = ucfirst $table;
+ $class =~ s/s$//;
+
+ return $class;
+ },
+ result_namespace => '+BackPAN::Index',
+ use_namespaces => 1,
+ naming => 'current',
+);
+
+
+=head1 NAME
+
+BackPAN::Index::Schema - DBIx::Class schema class
+
+=head1 SYNOPSIS
+
+No user servicable parts inside
+
+=head1 DESCRIPTION
+
+No user servicable parts inside
+
+=cut
+
+1;
--- /dev/null
+package BackPAN::Web;
+
+use Web::Simple __PACKAGE__;
+use Plack::Request;
+use Plack::Builder;
+use Plack::Util;
+use HTML::Zoom;
+use HTML::Zoom::FilterBuilder::Template;
+use BackPAN::Index;
+use Data::Page;
+use Data::Page::FlickrLike;
+use File::stat;
+use DateTime;
+use Log::Log4perl 'get_logger';
+
+our $VERSION = '0.12';
+
+default_config(
+ template_dir => 'root/html',
+ backpan_url => 'http://backpan.perl.org/',
+ cpan_search_url => 'http://search.cpan.org/',
+);
+
+sub _build_request_obj_from {
+ my ( $self, $env ) = @_;
+ return $self->request(Plack::Request->new($env));
+}
+
+sub request {
+ my $self = shift;
+ $self->{'request'} = shift if @_;
+ return $self->{'request'};
+}
+
+sub req { return shift->request(@_) }
+
+sub log {
+ my ( $self, $level, $msg ) = @_;
+ chomp $msg;
+ $self->request->{'env'}->{'psgix.logger'}->({
+ level => $level,
+ message => $msg,
+ });
+}
+
+sub backpan_index {
+ return $_[0]->{'backpan_index'} ||= BackPAN::Index->new({
+ update => 0,
+ debug => 0,
+ cache_dir => 'index',
+ releases_only_from_authors => 1,
+ });
+}
+
+sub slurp {
+ my ( $self, $filename ) = @_;
+ return do { local (@ARGV, $/) = $filename; <> };
+}
+
+sub template_filename_for {
+ my ( $self, $name ) = @_;
+ return $self->config->{'template_dir'} . "/${name}.html";
+}
+
+sub layout_zoom {
+ my $self = shift;
+ return $self->{'template_zoom_for_template'}{'layout'} ||= HTML::Zoom->from_file(
+ $self->template_filename_for('layout')
+ );
+}
+
+sub template_zoom_for {
+ my ( $self, $template_name ) = @_;
+ $self->{'template_zoom_for_template'}{$template_name} ||= do {
+ my @body;
+ HTML::Zoom->from_file(
+ $self->template_filename_for($template_name)
+ )->select('#content')->collect_content({ into => \@body })->run;
+ $self->layout_zoom
+ ->select('#content')->replace_content(\@body)
+ ->memoize;
+ };
+}
+
+sub error_404 {
+ my $self = shift;
+ return $self->slurp( $self->template_filename_for('error_404') );
+}
+
+sub html_response {
+ my ( $self, $args ) = @_;
+ my ( $header, $body ) = @$args{qw/header body/};
+ return [ 200, [
+ $header ? ( %$header ) : (),
+ 'Content-type' => 'text/html',
+ ], ref $body ? $body->to_fh : [ $body ] ];
+}
+
+sub add_listing {
+ my ( $self, $resultset, $row_data_cb ) = @_;
+ my $req_base = $self->req->base;
+ my $i = 1;
+ return sub {
+ $_->select('.main-list')
+ ->repeat_content([
+ map { my $row = $_;
+ my ( $name, $label, $href ) = $self->$row_data_cb($row);
+ sub {
+ my $zoom = $_;
+ $zoom = $zoom->select('li')->add_to_attribute(class => 'even')
+ if $i++ % 2 == 0;
+ if ( $href =~ m/http/i ) {
+ $zoom = $zoom->select('a')->add_to_attribute(href => $href)
+ ->then
+ ->add_to_attribute(target => '_blank')
+ ->then;
+ }
+ else {
+ $zoom = $zoom->select('a')->add_to_attribute(
+ href => $req_base . "${href}/${name}/"
+ )->then;
+ }
+ $zoom->replace_content($label);
+ }
+ } ( ref $resultset eq 'ARRAY' ? @$resultset : $resultset->all )
+ ]);
+ };
+}
+
+sub add_paging_ordering {
+ my ( $self, $pager, $ordering_options ) = @_;
+ return sub {
+ $_->apply($self->add_paging($pager))
+ ->apply($self->add_ordering($ordering_options));
+ };
+}
+
+sub add_paging {
+ my ( $self, $pager ) = @_;
+ my ( $curr_page, $curr_page_size )
+ = ( $pager->current_page, $pager->entries_per_page );
+ my $paging_uri = $self->req->uri;
+ return sub {
+ $_->select('#pages')
+ ->repeat_content([
+ map { my $page_number = $_;
+ $page_number == 0 ?
+ sub {
+ $_->select('span')->replace_content('...');
+ }
+ : sub {
+ $paging_uri->query_form({
+ $paging_uri->query_form,
+ page => $page_number,
+ rows => $curr_page_size,
+ });
+ $_->select('a')->add_to_attribute(href => $paging_uri)
+ ->then
+ ->replace_content($page_number);
+ }
+ } $pager->navigations
+ ])
+ ->select('.paging-desc')
+ ->replace_content(
+ join(q{ }, 'Page', $curr_page, 'of', $pager->last_page) . q{.}
+ )
+ ->select('.entries')
+ ->replace_content($pager->total_entries . ' entries.')
+ ->select('.page-size-options')
+ ->repeat_content([
+ map {
+ my $page_size = $_; sub {
+ $paging_uri->query_form({
+ $paging_uri->query_form,
+ page => $curr_page,
+ rows => $page_size,
+ });
+ $_->select('a')->add_to_attribute(href => $paging_uri)
+ ->then
+ ->replace_content($page_size);
+ }
+ } qw/10 20 30 50 100 200/
+ ]);
+ };
+}
+
+sub add_ordering {
+ my ( $self, $options ) = @_;
+ my $ordering_uri = $self->req->uri;
+ return sub {
+ $_->select('.ordering-options')
+ ->repeat_content([
+ map { my $order_by = $_; sub {
+ $ordering_uri->query_form({
+ $ordering_uri->query_form,
+ order_by => $order_by,
+ });
+ my $order_by_label = join(q{ }, map ucfirst, split(/\_/, $order_by));
+ $_->select('a')->add_to_attribute(href => $ordering_uri)
+ ->then
+ ->replace_content($order_by_label);
+ }
+ } @$options
+ ]);
+ };
+}
+
+sub index_page_content {
+ my $self = shift;
+ return $self->template_zoom_for('index')
+ ->apply($self->add_listing(scalar $self->releases, sub {
+ return ((map { $_[1]->$_ } qw/dist distvname/), 'distribution');
+ }));
+}
+
+sub validate_paging_params {
+ my ( $self, $args ) = @_;
+ my ( $page, $rows ) = @$args{qw/page rows/};
+ $page = 1 unless $page && $page =~ /^\d+$/;
+ $rows = 25 unless $rows && $rows =~ /^\d+$/;
+ return ( $page, $rows );
+}
+
+sub releases {
+ my ( $self, $args ) = @_;
+ my ( $order_by, $page, $rows )
+ = ( $args->{'order_by'}, $self->validate_paging_params($args) );
+ return $self->backpan_index->releases->search({}, {
+ order_by => { -desc => 'date' },
+ page => $page,
+ rows => $rows,
+ });
+}
+
+sub releases_page_content {
+ my ( $self, $release_rs ) = @_;
+ return $self->template_zoom_for('listing')
+ ->apply($self->add_listing($release_rs, sub {
+ return ((map { $_[1]->$_ } qw/dist distvname/), 'distribution');
+ }))
+ ->apply($self->add_paging($release_rs->pager));
+}
+
+sub dists {
+ my ( $self, $args ) = @_;
+ my ( $order_by, $page, $rows )
+ = ( $args->{'order_by'}, $self->validate_paging_params($args) );
+ return $self->backpan_index->dists->search({}, {
+ order_by => 'name',
+ page => $page,
+ rows => $rows,
+ });
+}
+
+sub get_dist { return shift->backpan_index->dist(@_) }
+
+sub format_dist_name { return join(q{::}, split /-/, $_[1] ) }
+
+sub dists_page_content {
+ my ( $self, $dist_rs ) = @_;
+ return $self->template_zoom_for('listing')
+ ->apply($self->add_listing($dist_rs, sub {
+ my $dist_name = $_[1]->name;
+ return (
+ $dist_name, $self->format_dist_name($dist_name), 'distribution'
+ );
+ }))
+ ->apply($self->add_paging($dist_rs->pager));
+}
+
+sub dist_info_page_content {
+ my ( $self, $dist, $query_params ) = @_;
+ my ( $page, $rows ) = $self->validate_paging_params($query_params);
+ my $release_rs = $dist->releases->search({}, {
+ order_by => { -desc => 'date' },
+ page => $page,
+ rows => $rows,
+ });
+ my ( $f_release, $l_release )
+ = ( $dist->first_release, $dist->latest_release );
+ my @maints = $dist->authors;
+ my $config = $self->config;
+ my ( $backpan_url, $cpan_search_url )
+ = ( $config->{'backpan_url'}, $config->{'cpan_search_url'} );
+ return $self->template_zoom_for('dist')
+ ->select('#dist')->template_text_raw({
+ name => $self->format_dist_name($dist->name),
+ num_releases => $dist->num_releases,
+ f_release_label => $f_release->distvname,
+ l_release_label => $l_release->distvname,
+ })
+ ->select('.f_rel_link')->add_to_attribute(
+ href => $backpan_url . $f_release->path->path,
+ )
+ ->select('.l_rel_link')->add_to_attribute(
+ href => $backpan_url . $l_release->path->path,
+ )
+ ->select('.maintainer-list')->repeat_content([
+ map { my $cpanid = $_; sub {
+ $_->select('a')->add_to_attribute(
+ href => $cpan_search_url . lc "~${cpanid}"
+ )->then
+ ->add_to_attribute(target => '_blank')
+ ->then
+ ->replace_content($cpanid);
+ }
+ } @maints
+ ])
+ ->apply($self->add_listing($release_rs, sub {
+ my $release = $_;
+ return (
+ $release->distvname,
+ join(q{ | }, $release->distvname,
+ DateTime->from_epoch({ epoch => $release->date })
+ ->strftime('%b %d, %Y - %T')),
+ $backpan_url . $release->path->path,
+ );
+ }))
+ ->apply($self->add_paging($release_rs->pager));
+}
+
+sub authors {
+ my ( $self, $args ) = @_;
+ my ( $page, $rows ) = $self->validate_paging_params($args);
+ my @authors = $self->backpan_index->releases->search({}, {
+ group_by => 'cpanid',
+ order_by => 'cpanid',
+ })->get_column('cpanid')->all;
+ my $pager = Data::Page->new;
+ $pager->total_entries(scalar @authors);
+ $pager->entries_per_page($rows);
+ if ( $page > $pager->last_page ) {
+ return undef;
+ }
+ else {
+ $pager->current_page($page);
+ return {
+ list => [ splice @authors, ($page-1) * $rows, $rows ],
+ pager => $pager,
+ };
+ }
+}
+
+sub authors_page_content {
+ my ( $self, $authors ) = @_;
+ return $self->template_zoom_for('listing')
+ ->apply($self->add_listing($authors->{'list'}, sub {
+ my $cpanid = $_[1];
+ return (
+ $cpanid, $cpanid,
+ $self->config->{'cpan_search_url'} . lc "~${cpanid}"
+ );
+ }))
+ ->apply($self->add_paging($authors->{'pager'}));
+}
+
+sub search {
+ my ( $self, $q, $query_params ) = @_;
+ my $query = lc "%$q%";
+ return $self->dists($query_params)->search({
+ -or => [
+ { 'LOWER(me.name)' => { -like => $query } },
+ { 'LOWER(me.first_author)' => { -like => $query } },
+ { 'LOWER(me.latest_author)' => { -like => $query } },
+ ],
+ });
+}
+
+dispatch {
+ subdispatch sub () {
+ $self->_build_request_obj_from($_[+PSGI_ENV]);
+ my $body;
+ [
+ sub (/) {
+ $self->html_response({ body => $self->index_page_content });
+ },
+
+ sub ( /about|/about/ ) {
+ my $about_filename = $self->template_filename_for('about');
+ my $about_st = stat($about_filename)
+ or $self->log(error_die => "No $about_filename: $!");
+ $self->html_response({
+ header => {
+ 'Last-Modified' => $about_st->mtime,
+ },
+ body => $self->slurp($about_filename),
+ });
+ },
+
+ sub ( /releases|/releases/ + ?* ) {
+ my $release_rs = $self->releases($_[1]);
+ if ( $release_rs->count ) {
+ $body = $self->releases_page_content($release_rs)
+ ->select('#nav-releases')->add_to_attribute(class => 'active');
+ }
+ else {
+ $body = $self->error_404;
+ }
+ $self->html_response({ body => $body });
+ },
+
+ sub ( /dists|/dists/ + ?* ) {
+ my $dist_rs = $self->dists($_[1]);
+ if ( $dist_rs->count ) {
+ $body = $self->dists_page_content($dist_rs)
+ ->select('#nav-dists')->add_to_attribute(class => 'active');
+ }
+ else {
+ $body = $self->error_404;
+ }
+ $self->html_response({ body => $body });
+ },
+
+ sub ( /distribution/*|/distribution/*/ + ?* ) {
+ if ( my $dist = $self->get_dist($_[1]) ) {
+ $body = $self->dist_info_page_content($dist, $_[2]);
+ }
+ else {
+ $body = $self->error_404;
+ }
+ $self->html_response({ body => $body });
+ },
+
+ sub ( /authors|/authors/ + ?* ) {
+ if ( my $authors = $self->authors($_[1]) ) {
+ $body = $self->authors_page_content($authors)
+ ->select('#nav-authors')->add_to_attribute(class => 'active');
+ }
+ else {
+ $body = $self->error_404;
+ }
+ $self->html_response({ body => $body });
+ },
+
+ sub ( /search|/search/ + ?q=&* ) {
+ my $dist_rs = $self->search(@_[1,2]);
+ if ( $dist_rs->count ) {
+ $body = $self->dists_page_content($dist_rs);
+ }
+ else {
+ $body = $self->error_404;
+ }
+ $self->html_response({ body => $body });
+ },
+ ],
+ },
+};
+
+sub as_psgi_app {
+ my $class = shift;
+ my $app = $class->SUPER::as_psgi_app;
+ return builder {
+ enable_if { $ENV{PLACK_ENV} ne 'deployment' }
+ sub {
+ my $mw_prefix = 'Plack::Middleware';
+ my $mw_class = Plack::Util::load_class('Static', $mw_prefix);
+ $app = $mw_class->wrap($app,
+ path => qr{^/static},
+ root => './root/',
+ );
+ $mw_class = Plack::Util::load_class('Debug', $mw_prefix);
+ $app = $mw_class->wrap($app,
+ panels => [qw(DBITrace Memory Timer Environment Response)],
+ );
+ $app;
+ };
+ enable 'ContentLength';
+ enable 'ConditionalGET';
+ enable 'ErrorDocument',
+ 500 => 'root/html/error_500.html',
+ 404 => 'root/html/error_404.html';
+ enable 'HTTPExceptions';
+ enable 'Head';
+ enable 'AccessLog',
+ format => 'combined',
+ logger => sub { get_logger('accesslog')->info(@_) };
+ enable 'Log4perl', conf => 'log/log.conf';
+ $app;
+ };
+}
+
+=head1 AUTHOR
+
+Wallace Reis, C<< <wreis at cpan.org> >>
+
+=head1 LICENSE AND COPYRIGHT
+
+Copyright 2010 Wallace Reis.
+
+=cut
+
+__PACKAGE__->run_if_script;
--- /dev/null
+package Parse::BACKPAN::Packages;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.39';
+
+use parent qw(Class::Accessor::Fast);
+
+use BackPAN::Index;
+
+__PACKAGE__->mk_accessors(qw(
+ _delegate
+));
+
+sub new {
+ my $class = shift;
+ my $options = shift;
+
+ # Translate from PBP options to BackPAN::Index
+ $options->{update} = 1 if $options->{no_cache};
+ $options->{releases_only_from_authors} = $options->{only_authors};
+
+ my $backpan = BackPAN::Index->new($options);
+ return $class->SUPER::new({ _delegate => $backpan });
+}
+
+our $AUTOLOAD;
+sub AUTOLOAD {
+ my $self = shift;
+ my($method) = $AUTOLOAD =~ /:: ([^:]+) $/x;
+
+ # Skip things like DESTROY
+ return if uc $method eq $method;
+
+ $self->_delegate->$method(@_);
+}
+
+sub files {
+ my $self = shift;
+
+ my %files;
+ my $rs = $self->_delegate->files;
+ while( my $file = $rs->next ) {
+ $files{$file->path} = $file;
+ }
+
+ return \%files;
+}
+
+sub file {
+ my ( $self, $path ) = @_;
+
+ return $self->_delegate->files->single({ path => $path });
+}
+
+sub releases {
+ my($self, $dist) = @_;
+
+ return $self->_delegate->releases($dist)->all;
+}
+
+
+sub distributions {
+ my $self = shift;
+
+ # For backwards compatibilty when releases() was distributions()
+ return $self->releases(shift) if @_;
+
+ return [$self->_delegate->distributions->get_column("name")->all];
+}
+
+sub distributions_by {
+ my ( $self, $author ) = @_;
+ return unless $author;
+
+ my $dists = $self->_dbh->selectcol_arrayref(q[
+ SELECT DISTINCT dist
+ FROM releases
+ WHERE cpanid = ?
+ ORDER BY dist
+ ],
+ undef,
+ $author
+ );
+
+ return @$dists;
+}
+
+sub authors {
+ my $self = shift;
+
+ my $authors = $self->_dbh->selectcol_arrayref(q[
+ SELECT DISTINCT cpanid
+ FROM releases
+ ORDER BY cpanid
+ ]);
+
+ return @$authors;
+}
+
+sub size {
+ my $self = shift;
+
+ my $size = $self->_dbh->selectcol_arrayref(q[
+ SELECT SUM(size) FROM files
+ ]);
+
+ return $size->[0];
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Parse::BACKPAN::Packages - Provide an index of BACKPAN
+
+=head1 SYNOPSIS
+
+ use Parse::BACKPAN::Packages;
+ my $p = Parse::BACKPAN::Packages->new();
+ print "BACKPAN is " . $p->size . " bytes\n";
+
+ my @filenames = keys %$p->files;
+
+ # see Parse::BACKPAN::Packages::File
+ my $file = $p->file("authors/id/L/LB/LBROCARD/Acme-Colour-0.16.tar.gz");
+ print "That's " . $file->size . " bytes\n";
+
+ # see Parse::BACKPAN::Packages::Release
+ my @acme_colours = $p->releases("Acme-Colour");
+
+ my @authors = $p->authors;
+ my @acmes = $p->distributions_by('LBROCARD');
+
+=head1 DESCRIPTION
+
+Parse::BackPAN::Packages has been B<DEPRECATED>. Please use the
+faster and more flexible L<BackPAN::Index>.
+
+The Comprehensive Perl Archive Network (CPAN) is a very useful
+collection of Perl code. However, in order to keep CPAN relatively
+small, authors of modules can delete older versions of modules to only
+let CPAN have the latest version of a module. BACKPAN is where these
+deleted modules are backed up. It's more like a full CPAN mirror, only
+without the deletions. This module provides an index of BACKPAN and
+some handy functions.
+
+The data is fetched from the net and cached for an hour.
+
+=head1 METHODS
+
+=head2 new
+
+The constructor downloads a ~1M index file from the web and parses it,
+so it might take a while to run:
+
+ my $p = Parse::BACKPAN::Packages->new();
+
+By default it caches the file locally for one hour. If you do not
+want this caching then you can pass in:
+
+ my $p = Parse::BACKPAN::Packages->new( { no_cache => 1 } );
+
+=head2 authors
+
+The authors method returns a list of all the authors. This is meant so
+that you can pass them into the distributions_by method:
+
+ my @authors = $p->authors;
+
+=head2 distributions
+
+ my $distributions = $p->distributions;
+
+The distributions method returns an array ref of the names of all the
+distributions in BackPAN.
+
+=head2 releases
+
+The releases method returns a list of objects representing all
+the different releases of a distribution:
+
+ # see Parse::BACKPAN::Packages::Release
+ my @acme_colours = $p->releases("Acme-Colour");
+
+=head2 distributions_by
+
+The distributions_by method returns a list of distribution names
+representing all the distributions that an author has uploaded:
+
+ my @acmes = $p->distributions_by('LBROCARD');
+
+=head2 file
+
+The file method finds metadata relating to a file:
+
+ # see Parse::BACKPAN::Packages::File
+ my $file = $p->file("authors/id/L/LB/LBROCARD/Acme-Colour-0.16.tar.gz");
+ print "That's " . $file->size . " bytes\n";
+
+=head2 files
+
+The files method returns a hash reference where the keys are the
+filenames of the files on CPAN and the values are
+Parse::BACKPAN::Packages::File objects:
+
+ my @filenames = keys %$p->files;
+
+=head2 size
+
+The size method returns the sum of all the file sizes in BACKPAN:
+
+ print "BACKPAN is " . $p->size . " bytes\n";
+
+=head1 AUTHOR
+
+Leon Brocard <acme@astray.com>
+
+=head1 COPYRIGHT
+
+Copyright (C) 2005-9, Leon Brocard
+
+=head1 LICENSE
+
+This module is free software; you can redistribute it or modify it under
+the same terms as Perl itself.
+
+=head1 SEE ALSO
+
+L<BackPAN::Index>, L<CPAN::DistInfoname>
--- /dev/null
+log4perl.rootLogger = DEBUG, GlobalLog, GlobalMail
+
+log4perl.appender.GlobalLog = Log::Log4perl::Appender::File
+log4perl.appender.GlobalLog.filename = log/debug.log
+log4perl.appender.GlobalLog.mode = append
+log4perl.appender.GlobalLog.layout = Log::Log4perl::Layout::PatternLayout
+log4perl.appender.GlobalLog.layout.ConversionPattern=[%d] [%p] %m%n
+
+log4perl.appender.GlobalMail = Log::Dispatch::Email::MailSend
+log4perl.appender.GlobalMail.to = wallace@reis.org.br
+log4perl.appender.GlobalMail.from = logger@backpan.org
+log4perl.appender.GlobalMail.subject = BackPAN.org reported an error
+log4perl.appender.GlobalMail.min_level = warning
+log4perl.appender.GlobalMail.layout = Log::Log4perl::Layout::PatternLayout
+log4perl.appender.GlobalMail.layout.ConversionPattern=[%d] [%p] %m | From %l%n
+
+log4perl.logger.accesslog = INFO, AccessLog
+
+log4perl.appender.AccessLog = Log::Log4perl::Appender::File
+log4perl.appender.AccessLog.filename = log/access.log
+log4perl.appender.AccessLog.mode = append
+log4perl.appender.AccessLog.layout = Log::Log4perl::Layout::PatternLayout
+log4perl.appender.AccessLog.layout.ConversionPattern=%m%n
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+ <head>
+ <title>BackPAN</title>
+ <meta http-equiv="content-type" content="text/html;charset=UTF-8" />
+ <link rel="stylesheet" href="/static/main.css" type="text/css" />
+ </head>
+<body>
+<div class="container">
+ <div id="search">
+ <form action="/search" method="GET">
+ <input type="text" id="q" name="q" />
+ <input type="submit" id="searchbtn" value="Search" />
+ </form>
+ </div>
+ <div id="logo">
+ <a href="/"><h1>BackPAN.org</h1><a>
+ </div>
+ <div id="menu">
+ <div class="nav">
+ <ul>
+ <li><a id="nav-releases" href="/releases">Releases</a></li>
+ <li><a id="nav-dists" href="/dists">Distributions</a></li>
+ <li><a id="nav-authors" href="/authors">Authors</a></li>
+ <li><a id="nav-about" class="active" href="/about">About</a></li>
+ </ul>
+ </div>
+ </div>
+ <div id="header">
+ <p>A Complete History of CPAN.</p>
+ </div>
+ <div id="content">
+ <div id="plain-text">
+ <p>The <a href="http://cpan.org" target="_blank">Comprehensive Perl Archive Network (CPAN)</a> is a very useful
+ collection of Perl code. However, authors of modules can delete older versions of modules to only
+ let CPAN have the latest version of a module and BackPAN is where these deleted modules are backed up.</p>
+ <p>BackPAN.org is a project created by <a href="http://search.cpan.org/~wreis/" target="_blank">Wallace Reis</a>
+ using <a href="http://search.cpan.org/perldoc?Web::Simple" target="_blank">Web::Simple</a> and
+ <a href="http://search.cpan.org/perldoc?HTML::Zoom" target="_blank">HTML::Zoom</a>. Kindly hosted by
+ <a href="http://shadowcat.co.uk" target="_blank">Shadowcat Systems</a>. Website design developed by
+ <a href="http://paulovitor.com" target="_blank">Paulo Vitor</a>.</p>
+ <p>Please send any corrections, suggestions or comments to wreis at cpan.org.</p>
+ </div>
+ </div>
+</div>
+<div id="footer">
+ <p>Created by <a href="http://search.cpan.org/~wreis/" target="_blank">Wallace Reis</a></p>
+ <p>Hosted by <a href="http://shadowcat.co.uk" target="_blank">Shadowcat Systems</a></p>
+</div>
+</body>
+</html>
--- /dev/null
+<div id="content">
+ <div id="dist">
+ <span>Name: [% name %]</span><br />
+ <span>Number of releases: [% num_releases %]</span><br />
+ <span>Maintainers:</span><br />
+ <ul class="maintainer-list">
+ <li><a>Name</a></li>
+ </ul><br />
+ <span>First release: <a class="f_rel_link">[% f_release_label %]</a></span><br />
+ <span>Latest release: <a class="l_rel_link">[% l_release_label %]</a></span><br />
+ </div>
+ <div id="list">
+ <span>Releases:</span><br />
+ <ul class="main-list">
+ <li><a>Name</a></li>
+ </ul>
+ <div id="paging">
+ <div id="pages">
+ <span><a>Page Number</a></span>
+ </div>
+ <span class="paging-desc" />
+ <span class="entries" />
+ </div>
+ </div>
+</div>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+ <head>
+ <title>BackPAN</title>
+ <meta http-equiv="content-type" content="text/html;charset=UTF-8" />
+ <link rel="stylesheet" href="/static/main.css" type="text/css" />
+ </head>
+<body>
+<div class="container">
+ <div id="search">
+ <form action="/search" method="GET">
+ <input type="text" id="q" name="q" />
+ <input type="submit" id="searchbtn" value="Search" />
+ </form>
+ </div>
+ <div id="logo">
+ <a href="/"><h1>BackPAN.org</h1><a>
+ </div>
+ <div id="menu">
+ <div class="nav">
+ <ul>
+ <li><a id="nav-releases" href="/releases">Releases</a></li>
+ <li><a id="nav-dists" href="/dists">Distributions</a></li>
+ <li><a id="nav-authors" href="/authors">Authors</a></li>
+ <li><a id="nav-about" href="/about">About</a></li>
+ </ul>
+ </div>
+ </div>
+ <div id="header">
+ <p>A Complete History of CPAN.</p>
+ </div>
+ <div id="content">
+ <div id="plain-text">
+ <p>Sorry, not found!</p>
+ <p>Whatever it was you were looking for, it's not here.</p>
+ <p>Please send any corrections, suggestions or comments to wreis at cpan.org.</p>
+ </div>
+ </div>
+</div>
+<div id="footer">
+ <p>Created by <a href="http://search.cpan.org/~wreis/" target="_blank">Wallace Reis</a></p>
+ <p>Hosted by <a href="http://shadowcat.co.uk" target="_blank">Shadowcat Systems</a></p>
+</div>
+</body>
+</html>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+ <head>
+ <title>BackPAN</title>
+ <meta http-equiv="content-type" content="text/html;charset=UTF-8" />
+ <link rel="stylesheet" href="/static/main.css" type="text/css" />
+ </head>
+<body>
+<div class="container">
+ <div id="search">
+ <form action="/search" method="GET">
+ <input type="text" id="q" name="q" />
+ <input type="submit" id="searchbtn" value="Search" />
+ </form>
+ </div>
+ <div id="logo">
+ <a href="/"><h1>BackPAN.org</h1><a>
+ </div>
+ <div id="menu">
+ <div class="nav">
+ <ul>
+ <li><a id="nav-releases" href="/releases">Releases</a></li>
+ <li><a id="nav-dists" href="/dists">Distributions</a></li>
+ <li><a id="nav-authors" href="/authors">Authors</a></li>
+ <li><a id="nav-about" href="/about">About</a></li>
+ </ul>
+ </div>
+ </div>
+ <div id="header">
+ <p>A Complete History of CPAN.</p>
+ </div>
+ <div id="content">
+ <div id="plain-text"><p>Ooooops! Sorry, we couldn't process your request.</p></div>
+ </div>
+</div>
+<div id="footer">
+ <p>Created by <a href="http://search.cpan.org/~wreis/" target="_blank">Wallace Reis</a></p>
+ <p>Hosted by <a href="http://shadowcat.co.uk" target="_blank">Shadowcat Systems</a></p>
+</div>
+</body>
+</html>
--- /dev/null
+<div id="content">
+ <span>New releases</p>
+ <div id="list">
+ <ul class="main-list">
+ <li><a>Name</a></li>
+ </ul>
+ </div>
+</div>
--- /dev/null
+<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
+<html>
+ <head>
+ <title>BackPAN</title>
+ <meta http-equiv="content-type" content="text/html;charset=UTF-8" />
+ <link rel="stylesheet" href="/static/main.css" type="text/css" />
+ </head>
+<body>
+<div class="container">
+ <div id="search">
+ <form action="/search" method="GET">
+ <input type="text" id="q" name="q" />
+ <input type="submit" id="searchbtn" value="Search" />
+ </form>
+ </div>
+ <div id="logo">
+ <a href="/"><h1>BackPAN.org</h1><a>
+ </div>
+ <div id="menu">
+ <div class="nav">
+ <ul>
+ <li><a id="nav-releases" href="/releases">Releases</a></li>
+ <li><a id="nav-dists" href="/dists">Distributions</a></li>
+ <li><a id="nav-authors" href="/authors">Authors</a></li>
+ <li><a id="nav-about" href="/about">About</a></li>
+ </ul>
+ </div>
+ </div>
+ <div id="header">
+ <p>A Complete History of CPAN.</p>
+ </div>
+ <div id="content">
+ </div>
+</div>
+<div id="footer">
+ <p>Created by <a href="http://search.cpan.org/~wreis/" target="_blank">Wallace Reis</a></p>
+ <p>Hosted by <a href="http://shadowcat.co.uk" target="_blank">Shadowcat Systems</a></p>
+</div>
+</body>
+</html>
--- /dev/null
+<div id="content">
+ <div id="page-size">
+ <span>Page Size:</span>
+ <div class="page-size-options">
+ <span><a>Page Size</a></span>
+ </div>
+ </div>
+ <div id="ordering">
+ <span>Sort by:</span>
+ <div class="ordering-options">
+ <span><a>Name</a></span>
+ </div>
+ </div>
+ <div id="list">
+ <ul class="main-list">
+ <li><a>Name</a></li>
+ </ul>
+ </div>
+ <div id="paging">
+ <div id="pages">
+ <span><a>Page Number</a></span>
+ </div>
+ <span class="paging-desc" />
+ <span class="entries" />
+ </div>
+</div>
--- /dev/null
+* {
+margin:0;
+padding:0;
+list-style: none;
+}
+
+body {
+text-align: center;
+font-family: Arial, sans-serif;
+color: #333;
+}
+
+a { color:#004065; }
+
+.container {
+margin: 20px auto 40px auto;
+text-align: left;
+width: 900px;
+}
+
+#ordering, #header, #paging, #list { float: left; }
+#menu, #page-size, #search { float: right; }
+
+#search input#q {
+float: right;
+border: 1px solid #004065;
+padding: 1px 25px 1px 5px;
+font-size: 14px;
+background: url(searchbtn.png) no-repeat right;
+}
+
+#header {
+font-size: 12px;
+color: #999;
+}
+
+.nav ul li {
+display: inline;
+}
+
+.nav ul li a {
+font-size: 14px;
+padding: 0 15px;
+text-decoration: none;
+color: #004065;
+height: 30px;
+line-height: 30px;
+display: block;
+float: left;
+}
+
+.nav ul li a:hover {
+background: #004065;
+color: #FFF;
+text-shadow: 1px 1px 1px #333;
+}
+
+#content, #list, #footer { width: 100%; overflow: auto; }
+
+#content {
+margin-top: 30px;
+border-top: 5px solid #004065;
+}
+
+#page-size, #ordering { width: 245px; }
+#page-size span, #ordering span {
+float: left;
+font-size: 14px;
+padding-top: 6px;
+}
+
+.page-size-options span a, .ordering-options span a {
+text-decoration: none;
+margin-left: 2px;
+padding: 0 4px;
+margin-top: -6px;
+display: block;
+height: 28px;
+line-height: 28px;
+float: left;
+}
+.page-size-options span a:hover, .ordering-options span a:hover {
+background: url(arrow-down.gif) no-repeat center top;
+}
+
+a.active {
+background: url(arrow-up.gif) no-repeat center bottom;
+}
+
+.main-list {
+border-top: 1px solid #004065;
+border-bottom: 1px solid #004065;
+margin-top: 5px;
+}
+/* IExpression to the horror */
+.main-list li {
+display: table;
+width: 900px;
+}
+/* I Love IExplorer! */
+
+.main-list li a {
+display: block;
+font-size: 15px;
+color: #333;
+text-decoration: none;
+padding: 5px 30px;
+}
+.main-list li a:hover {
+color: #FFF;
+background: #004065;
+}
+.main-list li.even a { background: #eaeaea; }
+.main-list li.even a:hover {
+color: #FFF;
+background: #004065;
+}
+
+#paging span {
+font-size: 12px;
+}
+#pages span a {
+margin-left: 2px;
+padding: 2px;
+color: #004065;
+font-size: 14px;
+text-decoration: none;
+}
+
+#plain-text {
+min-height: 518px;
+}
+#plain-text a { text-decoration: none }
+#plain-text a:hover { text-decoration: underline }
+#plain-text p {
+padding: 20px 20px 5px 20px;
+}
+
+#footer {
+min-height: 40px;
+background: #004065;
+color: #fff;
+}
+#footer a {
+text-decoration: none;
+text-shadow: 1px 1px 1px #333;
+color: #FFF;
+}
+#footer a:hover { text-decoration: underline }
--- /dev/null
+use strict;
+use warnings;
+
+use BackPAN::Index;
+BackPAN::Index->new({
+ update => 1,
+ debug => 1,
+ cache_dir => 'index',
+ releases_only_from_authors => 1,
+});
--- /dev/null
+use lib 'lib';
+use Test::More tests => 1;
+
+BEGIN {
+ use_ok( 'BackPAN::Web' ) || print "Bail out!";
+}
+
+diag( "Testing BackPAN::Web $BackPAN::Web::VERSION, Perl $], $^X" );
--- /dev/null
+use strict;
+use warnings;
+use lib 'lib';
+use BackPAN::Web;
+use Plack::Test;
+use HTTP::Request::Common;
+use Test::More;
+use Devel::Cycle;
+use Data::Dumper;
+use Devel::Events::Handler::ObjectTracker;
+use Devel::Events::Filter::RemoveFields;
+use Devel::Events::Generator::Objects;
+
+$ENV{PLACK_ENV} = 'test';
+
+my $tracker = Devel::Events::Handler::ObjectTracker->new();
+
+my $gen = Devel::Events::Generator::Objects->new(
+ handler => Devel::Events::Filter::RemoveFields->new(
+ fields => [qw/generator/],
+ handler => $tracker,
+),
+);
+
+
+my $app = BackPAN::Web->as_psgi_app;
+
+my $run = sub {
+ $gen->enable();
+ test_psgi app => $app,
+ client => sub {
+ my $cb = shift;
+ foreach my $path (qw{/ /releases /dists /authors /about}) {
+ for (1..1000) {
+ my $res = $cb->(GET $path);
+ ok($res->code == 200) or diag($res->code);
+ }
+ }
+ };
+ $gen->disable();
+};
+$run->();
+
+my @leaked_objects = keys %{ $tracker->live_objects };
+
+print "leaked ", scalar(@leaked_objects), " objects\n";
+
+foreach my $object ( @leaked_objects ) {
+ print "Leaked object: $object\n";
+
+ # the event that generated it
+ #print Dumper( $object, $tracker->live_objects->{$object} );
+
+ find_cycle( $object );
+}
+
+done_testing();
projects / catagits/BackPAN-Web.git / commitdiff
