File Coverage

blib/lib/CPAN/Mini/Webserver.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1 2     2   53161 use strict;
  2         5  
  2         76  
2 2     2   10 use warnings;
  2         4  
  2         110  
3              
4             package CPAN::Mini::Webserver;
5              
6             # ABSTRACT: Search and browse Mini CPAN
7              
8             our $VERSION = '0.58'; # VERSION
9              
10 2     2   1689 use App::Cache;
  2         419354  
  2         58  
11 2     2   4060 use Archive::Peek 0.33;
  0            
  0            
12             use CPAN::Mini::App 0.565;
13             use CPAN::Mini::Webserver::Index;
14             use CPAN::Mini::Webserver::Templates;
15             use CPAN::Mini::Webserver::Templates::CSS;
16             use CPAN::Mini::Webserver::Templates::Images;
17             use Encode;
18             use File::Spec::Functions qw( canonpath catfile );
19             use File::Type;
20             use List::MoreUtils qw(uniq);
21             use HTTP::Server::Simple 0.34;
22             use HTTP::Server::Simple::CGI;
23             use Module::InstalledVersion;
24             use Moose;
25             use Parse::CPAN::Authors;
26             use Parse::CPAN::Packages 2.35;
27             use Parse::CPAN::Whois 0.02;
28             use Parse::CPAN::Meta;
29             use Pod::Simple::HTML;
30             use Path::Class;
31             use PPI;
32             use PPI::HTML;
33             use Safe;
34             use Template::Declare;
35             use Try::Tiny;
36              
37             Template::Declare->init( roots => [ 'CPAN::Mini::Webserver::Templates', 'CPAN::Mini::Webserver::Templates::CSS', 'CPAN::Mini::Webserver::Templates::Images', ] );
38              
39             if ( eval { require HTTP::Server::Simple::Bonjour } ) {
40                 extends 'HTTP::Server::Simple::Bonjour', 'HTTP::Server::Simple::CGI';
41             }
42             else {
43                 extends 'HTTP::Server::Simple::CGI';
44             }
45              
46             has hostname => ( is => 'rw', lazy_build => 1 );
47             has cgi => ( is => 'rw', isa => 'CGI', lazy_build => 1 );
48             has directory => ( is => 'rw', isa => 'Path::Class::Dir' );
49             has scratch => ( is => 'rw', isa => 'Path::Class::Dir' );
50             has author_type => ( is => 'rw' );
51             has parse_cpan_authors => ( is => 'rw' );
52             has parse_cpan_packages => ( is => 'rw', isa => 'Parse::CPAN::Packages' );
53             has pauseid => ( is => 'rw' );
54             has distvname => ( is => 'rw' );
55             has filename => ( is => 'rw' );
56             has index => ( is => 'rw', isa => 'CPAN::Mini::Webserver::Index' );
57             has config => ( is => 'ro', lazy_build => 1 );
58             has is_cgi => ( is => 'rw' );
59             has base_url => ( is => 'ro', lazy_build => 1 );
60              
61             sub service_name {
62                 "$ENV{USER}'s minicpan_webserver";
63             }
64              
65             sub get_file_from_tarball {
66                 die "Deprecated above 0.53. This function can now be found in Parse::CPAN::Packages.";
67             }
68              
69             sub checksum_data_for_author {
70                 my ( $self, $pauseid ) = @_;
71              
72                 my $file = file( $self->directory, 'authors', 'id', substr( $pauseid, 0, 1 ), substr( $pauseid, 0, 2 ), $pauseid, 'CHECKSUMS', );
73              
74                 return unless -f $file;
75              
76                 my ( $content );
77                 {
78                     local $/;
79                     open my $fh, "$file" or die "$file: $!";
80                     $content = <$fh>;
81                     close $fh;
82                 }
83              
84                 my $compmt = Safe->new;
85                 my $chksum = $compmt->reval( $content );
86              
87                 return $chksum;
88             }
89              
90             sub send_http_header {
91                 my $self = shift;
92                 my $code = shift;
93                 my %params = @_;
94              
95                 if ( ( defined $params{-charset} and $params{-charset} eq 'utf-8' )
96                     or ( defined $params{-type} and $params{-type} eq 'text/xml' ) )
97                 {
98                     binmode( STDOUT, ":encoding(utf-8)" );
99                 }
100                 elsif ( defined $params{-type} ) {
101                     binmode STDOUT, ":raw";
102                 }
103                 my $pre = "HTTP/1.0";
104                 $pre = "Status:" if $self->is_cgi;
105                 print "$pre $code\015\012";
106                 print $self->cgi->header( %params );
107             }
108              
109             sub _build_config {
110                 my %config = CPAN::Mini->read_config;
111                 return \%config;
112             }
113              
114             sub _build_base_url {
115                 my ( $self ) = @_;
116                 return $self->config->{base_url} || "/";
117             }
118              
119             sub _build_cgi {
120                 my ( $self ) = @_;
121                 return $self->cgi_class->new;
122             }
123              
124             sub _build_hostname {
125                 my ( $self ) = @_;
126                 return $self->cgi->virtual_host;
127             }
128              
129             # this is a hook that HTTP::Server::Simple calls after setting up the
130             # listening socket. we use it load the indexes
131             sub after_setup_listener {
132                 my ( $self, $cache_dir ) = @_;
133              
134                 my $directory = dir( glob $self->config->{local} );
135                 $self->directory( $directory );
136                 my $authors_filename = file( $directory, 'authors', '01mailrc.txt.gz' );
137                 my $packages_filename = file( $directory, 'modules', '02packages.details.txt.gz' );
138                 die "Please set up minicpan"
139                   unless defined( $directory )
140                       && ( -d $directory )
141                       && ( -f $authors_filename )
142                       && ( -f $packages_filename );
143              
144                 my %cache_opts = ( ttl => 60 * 60 );
145                 $cache_opts{directory} = $cache_dir if $cache_dir;
146                 $cache_opts{directory} = $self->config->{cache_dir} if $self->config->{cache_dir};
147                 my $cache = App::Cache->new( \%cache_opts );
148              
149                 my $whois_filename = file( $directory, 'authors', '00whois.xml' );
150                 my $parse_cpan_authors;
151                 if ( -f $whois_filename ) {
152                     $self->author_type( 'Whois' );
153                     $parse_cpan_authors = $cache->get_code( 'parse_cpan_whois', sub { Parse::CPAN::Whois->new( $whois_filename->stringify ) } );
154                 }
155                 else {
156                     $self->author_type( 'Authors' );
157                     $parse_cpan_authors = $cache->get_code( 'parse_cpan_authors', sub { Parse::CPAN::Authors->new( $authors_filename->stringify ) } );
158                 }
159                 my $parse_cpan_packages = $cache->get_code( 'parse_cpan_packages', sub { Parse::CPAN::Packages->new( $packages_filename->stringify ) } );
160              
161                 $self->parse_cpan_authors( $parse_cpan_authors );
162                 $self->parse_cpan_packages( $parse_cpan_packages );
163              
164                 my $scratch = dir( $cache->scratch );
165                 $self->scratch( $scratch );
166              
167                 my $index = CPAN::Mini::Webserver::Index->new(
168                     mini_dir => $self->directory,
169                     full_text => $self->config->{full_text},
170                     index_subs => $self->config->{index_subs},
171                 );
172                 $self->index( $index );
173                 $index->create_index( $parse_cpan_authors, $parse_cpan_packages );
174             }
175              
176             sub handle_request {
177                 my ( $self, $cgi ) = @_;
178              
179                 $self->cgi( $cgi ) if $cgi;
180              
181                 my $result = try {
182                     $self->_handle_request;
183                 }
184                 catch {
185                     $self->send_http_header( 500 );
186                     return "<h1>Internal Server Error</h1>", $self->cgi->escapeHTML( $_ );
187                 };
188                 print $result;
189              
190                 binmode STDOUT;
191              
192                 return;
193             }
194              
195             sub _handle_request {
196                 my ( $self ) = @_;
197              
198                 my $path = $self->cgi->path_info;
199              
200             # $raw, $download and $install should become $action?
201                 my ( $raw, $install, $download, $pauseid, $distvname, $filename, $prefix );
202                 if ( $path =~ m{^/~} ) {
203                     ( undef, $pauseid, $distvname, $filename ) = split( '/', $path, 4 );
204                     $pauseid =~ s{^~}{};
205                 }
206                 elsif ( $path =~ m{^/(raw|download|install)/~} ) {
207                     ( undef, undef, $pauseid, $distvname, $filename ) = split( '/', $path, 5 );
208              
209                     (
210                           $1 eq 'raw' ? $raw
211                         : $1 eq 'install' ? $install
212                         : $download
213                     ) = 1;
214                     $pauseid =~ s{^~}{};
215                 }
216                 elsif ( $path =~ m{^/((?:modules|authors)/.+$)} ) {
217                     $prefix = $1;
218                 }
219                 $self->pauseid( $pauseid );
220                 $self->distvname( $distvname );
221                 $self->filename( $filename );
222              
223                 return $self->dispatch( $path, $raw, $pauseid, $distvname, $filename, $install, $download, $prefix );
224             }
225              
226             sub dispatch {
227                 my ( $self, $path, $raw, $pauseid, $distvname, $filename, $install, $download, $prefix ) = @_;
228              
229                 return $self->index_page if $path eq '/';
230                 return $self->search_page if $path eq '/search/';
231              
232                 return $self->dispatch_by_author_id( $distvname, $raw, $filename, $install, $download ) if $pauseid;
233              
234                 return $self->pod_page if $path =~ m{^/perldoc};
235                 return $self->dist_page if $path =~ m{^/dist/};
236                 return $self->package_page if $path =~ m{^/package/};
237              
238                 return $self->download_cpan( $prefix ) if $prefix;
239              
240                 my @template_type_info = $self->get_template_type_info( $path );
241                 return $self->direct_to_template( @template_type_info ) if @template_type_info;
242              
243                 my ( $q ) = $path =~ m'/(.*?)/?$';
244                 return $self->not_found_page( $q );
245             }
246              
247             sub dispatch_by_author_id {
248                 my ( $self, $distvname, $raw, $filename, $install, $download ) = @_;
249              
250                 return $self->author_page if !$distvname;
251              
252                 return $self->raw_page if $filename and $raw;
253                 return $self->install_page if $filename and $install;
254                 return $self->download_file if $download;
255                 return $self->file_page if $filename;
256              
257                 return $self->distribution_page;
258             }
259              
260             sub get_template_type_info {
261                 my ( $self, $path ) = @_;
262                 return ( "css_screen", "text/css" ) if $path eq '/static/css/screen.css';
263                 return ( "css_print", "text/css" ) if $path eq '/static/css/print.css';
264                 return ( "css_ie", "text/css" ) if $path eq '/static/css/ie.css';
265                 return ( "images_logo", "image/png" ) if $path eq '/static/images/logo.png';
266                 return ( "images_favicon", "image/png" ) if $path eq '/static/images/favicon.png';
267                 return ( "images_favicon", "image/png" ) if $path eq '/favicon.ico';
268                 return ( "opensearch", "application/opensearchdescription+xml" ) if $path eq '/static/xml/opensearch.xml';
269                 return;
270             }
271              
272             sub index_page {
273                 my $self = shift;
274                 $self->send_http_header( 200, -charset => 'utf-8' );
275                 return $self->render(
276                     'index',
277                     {
278                         recents => $self->get_recent_dists,
279                         parse_cpan_authors => $self->parse_cpan_authors,
280                     }
281                 );
282             }
283              
284             sub get_recent_dists {
285                 my ( $self ) = @_;
286              
287                 my $recent_filename = catfile( $self->directory, 'RECENT' );
288                 return { count => 0 } if !-f $recent_filename;
289              
290                 my $fh = IO::File->new( $recent_filename ) || die $!;
291                 my @recent = <$fh>;
292                 @recent = grep m{authors/id/}, @recent;
293              
294                 my $recent_count = @recent;
295                 @recent = @recent[ 0 .. 19 ] if $recent_count > 20;
296                 @recent = map CPAN::DistnameInfo->new( $_ ), @recent;
297              
298                 return { count => $recent_count, display_list => \@recent };
299             }
300              
301             # TODO: not tested properly
302             sub not_found_page {
303                 my $self = shift;
304                 my $q = shift;
305                 my ( $authors, $dists, $packages ) = $self->_do_search( $q );
306                 $self->send_http_header( 404, -charset => 'utf-8' );
307                 return $self->render(
308                     '404',
309                     {
310                         parse_cpan_authors => $self->parse_cpan_authors,
311                         q => $q,
312                         authors => $authors,
313                         distributions => $dists,
314                         packages => $packages
315                     }
316                 );
317             }
318              
319             sub redirect {
320                 my ( $self, $url ) = @_;
321                 my $status = "HTTP/1.0 302";
322                 $status = "Status: 302" if $self->is_cgi;
323                 return "$status\015\012" . $self->cgi->redirect( $self->base_url . $url );
324             }
325              
326             sub search_page {
327                 my $self = shift;
328                 my $q = $self->cgi->param( 'q' );
329                 Encode::_utf8_on( $q ); # we know that we have sent utf-8
330              
331                 my ( $authors, $dists, $packages ) = $self->_do_search( $q );
332                 $packages = $self->_packages_with_search_preview( $packages, $q );
333                 $self->send_http_header( 200, -charset => 'utf-8' );
334                 return $self->render(
335                     'search',
336                     {
337                         parse_cpan_authors => $self->parse_cpan_authors,
338                         q => $q,
339                         authors => $authors,
340                         distributions => $dists,
341                         packages => $packages,
342                     }
343                 );
344             }
345              
346             sub _packages_with_search_preview {
347                 my ( $self, $packages, $q ) = @_;
348              
349                 my @packages = map $self->_add_search_preview( $_, $q ), @{$packages};
350              
351                 return \@packages;
352             }
353              
354             sub _add_search_preview {
355                 my ( $self, $package, $q ) = @_;
356              
357                 my $content = $package->file_content;
358                 my $parser = Pod::Simple::Text->new;
359                 $parser->no_whining( 1 );
360                 $parser->no_errata_section( 1 );
361                 $parser->output_string( \my $text );
362                 $parser->parse_string_document( $content );
363              
364                 $content = $text;
365                 $content =~ s/[\n\r]/ /g;
366                 $content =~ s/\s+/ /g;
367              
368                 my ( $match ) = ( $content =~ /($q)/i );
369                 my $length = length $match;
370                 my $pos = index $content, $match;
371              
372                 my $cap = ( 70 - $length ) / 2;
373              
374                 my $before = substr( $content, $pos - $cap, $cap );
375                 my $after = substr( $content, $pos + $length, $cap );
376              
377                 return { match => { before => $before, after => $after, match => $match }, pkg => $package };
378             }
379              
380             sub _do_search {
381                 my $self = shift;
382                 my $q = shift;
383                 my $index = $self->index;
384                 my @results = $index->search( $q );
385                 my $au_type = $self->author_type;
386              
387                 my @base = ( \@results, $q );
388              
389                 my @packages = $self->_filter_sort_results( @base, qr/\w-\w/, 'Parse::CPAN::Packages::Package', "::", "package" );
390              
391                 if ( $self->cgi->param( 'find_only_subs' ) ) {
392                     @packages = grep $_->has_matching_sub( qr/$q/i ), @packages;
393                     return ( [], [], \@packages );
394                 }
395              
396                 my @authors = $self->_filter_sort_results( @base, qr/\w(?:::|-)\w/, "Parse::CPAN::${au_type}::Author", " ", "name" );
397                 my @distributions = $self->_filter_sort_results( @base, qr/\w::\w/, 'Parse::CPAN::Packages::Distribution', "-", "dist" );
398              
399                 return ( \@authors, \@distributions, \@packages );
400             }
401              
402             sub _filter_sort_results {
403                 my ( $self, $results, $q, $skip_regex, $class, $split_chars, $attr ) = @_;
404              
405                 return if $q =~ $skip_regex;
406              
407                 my @filtered = uniq grep { $class eq ref $_ } @{$results};
408              
409                 @filtered = sort {
410                     my @a = $a->$attr =~ /$split_chars/g;
411                     my @b = $b->$attr =~ /$split_chars/g;
412                     scalar( @a ) <=> scalar( @b ) || $a->$attr cmp $b->$attr;
413                 } @filtered;
414              
415                 return @filtered;
416             }
417              
418             sub author_page {
419                 my $self = shift;
420                 my $pauseid = $self->pauseid;
421              
422                 my @distributions = sort { $a->distvname cmp $b->distvname }
423                   grep { $_->cpanid eq uc $pauseid } $self->parse_cpan_packages->distributions;
424                 my $author = $self->parse_cpan_authors->author( uc $pauseid );
425              
426                 my $checksum = $self->checksum_data_for_author( uc $pauseid );
427                 my %dates;
428                 if ( not $@ and defined $checksum ) {
429                     $dates{ $_->distvname } = $checksum->{ $_->filename }->{mtime} for @distributions;
430                 }
431              
432                 $self->send_http_header( 200, -charset => 'utf-8' );
433                 return $self->render(
434                     'author',
435                     {
436                         author => $author,
437                         pauseid => $pauseid,
438                         distributions => \@distributions,
439                         dates => \%dates,
440                     }
441                 );
442             }
443              
444             sub distribution_page {
445                 my $self = shift;
446                 my $pauseid = $self->pauseid;
447                 my $distvname = $self->distvname;
448              
449             # TODO: need to figure out how to handle dists missing here
450                 my ( $distribution ) = grep { $_->cpanid eq uc $pauseid && $_->distvname eq $distvname } $self->parse_cpan_packages->distributions;
451              
452                 my $filename = $distribution->distvname . "/META.yml";
453                 my $metastr = $distribution->get_file_from_tarball( $filename );
454                 my $meta = {};
455                 my @yaml = eval { Parse::CPAN::Meta::Load( $metastr ); };
456                 $meta = $yaml[0] if !$@;
457              
458                 my $checksum_data = $self->checksum_data_for_author( uc $pauseid );
459                 $meta->{'release date'} = $checksum_data->{ $distribution->filename }->{mtime};
460              
461                 my @filenames = $distribution->list_files;
462              
463                 $self->send_http_header( 200, -charset => 'utf-8' );
464                 return $self->render(
465                     'distribution',
466                     {
467                         author => $self->parse_cpan_authors->author( uc $pauseid ),
468                         distribution => $distribution,
469                         pauseid => $pauseid,
470                         distvname => $distvname,
471                         filenames => \@filenames,
472                         meta => $meta,
473                         pcp => $self->parse_cpan_packages,
474                     }
475                 );
476             }
477              
478             sub pod_page {
479                 my $self = shift;
480                 my ( $pkgname ) = $self->cgi->keywords;
481              
482                 my $m = $self->parse_cpan_packages->package( $pkgname );
483                 my $d = $m->distribution;
484              
485                 my ( $pauseid, $distvname ) = ( $d->cpanid, $d->distvname );
486                 my $url = "package/$pauseid/$distvname/$pkgname/";
487              
488                 $self->redirect( $url );
489             }
490              
491             sub install_page {
492                 my $self = shift;
493                 my $pauseid = $self->pauseid;
494                 my $distvname = $self->distvname;
495              
496                 my ( $distribution ) = grep { $_->cpanid eq uc $pauseid && $_->distvname eq $distvname } $self->parse_cpan_packages->distributions;
497              
498                 my $file = file( $self->directory, 'authors', 'id', $distribution->prefix );
499              
500                 $self->send_http_header( 200 );
501                 printf '<html><body><h1>Installing %s</h1><pre>', $distribution->distvname;
502              
503                 warn sprintf "Installing '%s'\n", $distribution->prefix;
504              
505                 require CPAN; # loads CPAN::Shell
506                 CPAN::Shell->install( $distribution->prefix );
507              
508                 printf '</pre><a href="/~%s/%s">Go back</a></body></html>', $self->pauseid, $self->distvname;
509             }
510              
511             sub file_page {
512                 my $self = shift;
513                 my $pauseid = $self->pauseid;
514                 my $distvname = $self->distvname;
515                 my $filename = $self->filename;
516              
517                 my ( $distribution ) = grep { $_->cpanid eq uc $pauseid && $_->distvname eq $distvname } $self->parse_cpan_packages->distributions;
518              
519                 my $contents = $distribution->get_file_from_tarball( $filename );
520              
521                 my $parser = Pod::Simple::HTML->new;
522                 $parser->perldoc_url_prefix( $self->base_url . 'perldoc?' );
523                 $parser->index( 1 );
524                 $parser->no_whining( 1 );
525                 $parser->no_errata_section( 1 );
526                 $parser->output_string( \my $html );
527                 $parser->parse_string_document( $contents );
528                 $html =~ s/^.*<!-- start doc -->//s;
529                 $html =~ s/<!-- end doc -->.*$//s;
530              
531                 $self->send_http_header( 200, -charset => 'utf-8' );
532                 return $self->render(
533                     'file',
534                     {
535                         author => $self->parse_cpan_authors->author( uc $pauseid ),
536                         distribution => $distribution,
537                         pauseid => $pauseid,
538                         distvname => $distvname,
539                         filename => $filename,
540                         contents => $contents,
541                         html => $html,
542                     }
543                 );
544             }
545              
546             sub download_file {
547                 my $self = shift;
548                 my $pauseid = $self->pauseid;
549                 my $distvname = $self->distvname;
550                 my $filename = $self->filename;
551              
552                 my ( $distribution ) = grep { $_->cpanid eq uc $pauseid && $_->distvname eq $distvname } $self->parse_cpan_packages->distributions;
553                 die "Distribution '$distvname' unknown for PAUSE id '$pauseid'." if !$distribution;
554              
555                 return $self->redirect( "authors/id/" . $distribution->prefix ) if !$filename;
556              
557                 my $contents = $distribution->get_file_from_tarball( $filename );
558                 $self->send_http_header(
559                     200,
560                     -type => 'text/plain',
561                     -content_length => length $contents,
562                     -charset => '',
563                 );
564              
565                 return $contents;
566             }
567              
568             sub raw_page {
569                 my $self = shift;
570                 my $pauseid = $self->pauseid;
571                 my $distvname = $self->distvname;
572                 my $filename = $self->filename;
573              
574                 my ( $distribution ) = grep { $_->cpanid eq uc $pauseid && $_->distvname eq $distvname } $self->parse_cpan_packages->distributions;
575              
576                 my $file = file( $self->directory, 'authors', 'id', $distribution->prefix );
577              
578                 my $contents = $distribution->get_file_from_tarball( $filename );
579              
580                 my $html;
581              
582                 if ( $filename =~ /\.(pm|pl|PL|t)$/ ) {
583                     my $document = PPI::Document->new( \$contents );
584                     my $highlight = PPI::HTML->new( line_numbers => 0 );
585                     my $pretty = $highlight->html( $document );
586              
587                     my $split = '<span class="line_number">';
588              
589             # turn significant whitespace into &nbsp;
590                     my @lines = map {
591                         $_ =~ s{</span>( +)}{"</span>" . ("&nbsp;" x length($1))}e;
592                         "$split$_";
593                     } split /$split/, $pretty;
594              
595             # remove the extra line number tag
596                     @lines = map { s{<span class="line_number">}{}; $_ } @lines;
597              
598             # remove newlines
599                     $_ =~ s{<br>}{}g for @lines;
600              
601             # link module names to ourselves
602                     @lines = map {
603                         $_ =~ s{<span class="word">([^<]+?::[^<]+?)</span>}{<span class="word"><a href="/perldoc?$1">$1</a></span>}g;
604                         $_;
605                     } @lines;
606                     $html = join '', @lines;
607                 }
608              
609                 $self->send_http_header( 200, -charset => 'utf-8' );
610                 return $self->render(
611                     'raw',
612                     {
613                         author => $self->parse_cpan_authors->author( uc $pauseid ),
614                         distribution => $distribution,
615                         filename => $filename,
616                         pauseid => $pauseid,
617                         distvname => $distvname,
618                         contents => $contents,
619                         html => $html,
620                     }
621                 );
622             }
623              
624             sub dist_page {
625                 my $self = shift;
626                 my ( $dist ) = $self->cgi->path_info =~ m{^/dist/(.+?)$};
627                 my $latest = $self->parse_cpan_packages->latest_distribution( $dist );
628                 if ( $latest ) {
629                     $self->redirect( "~" . $latest->cpanid . "/" . $latest->distvname );
630                 }
631                 else {
632                     $self->not_found_page( $dist );
633                 }
634             }
635              
636             sub package_page {
637                 my $self = shift;
638                 my $path = $self->cgi->path_info;
639                 my ( $pauseid, $distvname, $package_name ) = $path =~ m{^/package/(.+?)/(.+?)/(.+?)/$};
640              
641                 my ( $p ) = grep $self->is_package_for_package_page( $pauseid, $distvname, $package_name, $_ ), $self->parse_cpan_packages->packages;
642                 return $self->not_found_page( $package_name ) if !$p;
643              
644                 my $filename = $p->filename;
645                 my $url = "~$pauseid/$distvname/$filename";
646              
647             # TODO: duplicate results and no results here need to be handled (maybe search through contents of a dist in that case)
648              
649                 $self->redirect( $url );
650             }
651              
652             sub is_package_for_package_page {
653                 my ( $self, $pauseid, $distvname, $package_name, $package ) = @_;
654              
655                 return 0 if $package->package ne $package_name;
656                 return 0 if $package->distribution->distvname ne $distvname;
657                 return 0 if $package->distribution->cpanid ne uc $pauseid;
658              
659                 return 1;
660             }
661              
662             sub download_cpan {
663                 my ( $self, $prefix ) = @_;
664                 my $file_type = File::Type->new;
665                 my $file = file( $self->directory, canonpath( URI::Escape::uri_unescape( $prefix ) ) );
666              
667                 open my $fh, $file or return $self->not_found_page( $prefix );
668              
669                 my $content_type = $file_type->checktype_filename( $file );
670                 $content_type = 'text/plain' unless $file->basename =~ /\./;
671              
672                 $self->send_http_header(
673                     200,
674                     -type => $content_type,
675                     -content_disposition => "attachment; filename=" . $file->basename,
676                     -content_length => -s $fh,
677                     -charset => '',
678                 );
679                 while ( <$fh> ) {
680                     print;
681                 }
682                 $fh->close;
683              
684             }
685              
686             sub list_files {
687                 die "Deprecated above 0.53. This function can now be found in Parse::CPAN::Packages.";
688             }
689              
690             sub packages_as_tree {
691                 my ( $self ) = @_;
692              
693                 return {} if !$self->config->{side_bar};
694              
695                 my @packages = $self->parse_cpan_packages->packages;
696              
697                 my %tree;
698              
699                 for my $pkg ( @packages ) {
700                     my @parts = split /::/, $pkg->package;
701                     my $node = \%tree;
702                     $node = $node->{children}{$_} ||= { name => $_ } for @parts;
703                     $node->{package} = $pkg;
704                 }
705              
706                 $self->_convert_children_to_array( \%tree );
707              
708                 return \%tree;
709             }
710              
711             sub _convert_children_to_array {
712                 my ( $self, $node ) = @_;
713              
714                 my @children = sort { $a->{name} cmp $b->{name} } values %{ $node->{children} };
715                 $node->{children} = \@children;
716              
717                 $self->_convert_children_to_array( $_ ) for @children;
718              
719                 return;
720             }
721              
722             sub render {
723                 my ( $self, $template, $params ) = @_;
724              
725                 $params ||= {};
726                 $params->{packages_as_tree} ||= $self->packages_as_tree;
727                 $params->{base_url} ||= $self->base_url;
728                 $params->{doc_mode} ||= $self->config->{doc_mode};
729                 $params->{index} ||= $self->index;
730              
731                 return Template::Declare->show( $template, $params );
732             }
733              
734             sub process_single_cgi_request {
735                 my ( $self ) = @_;
736              
737                 $self->is_cgi( 1 );
738                 $self->after_setup_listener;
739                 $self->handle_request;
740              
741                 return;
742             }
743              
744             sub direct_to_template {
745                 my $self = shift;
746                 my $template = shift;
747                 my $mime = shift;
748              
749                 $self->send_http_header(
750                     200,
751                     -expires => '+1d',
752                     ( $mime ? ( -type => $mime ) : () ),
753                 );
754              
755                 return $self->render( $template );
756             }
757              
758             1;
759              
760              
761              
762             =pod
763            
764             =head1 NAME
765            
766             CPAN::Mini::Webserver - Search and browse Mini CPAN
767            
768             =head1 VERSION
769            
770             version 0.58
771            
772             =head1 SYNOPSIS
773            
774             % minicpan_webserver
775            
776             =head1 DESCRIPTION
777            
778             This module is the driver that provides a web server that allows you to search
779             and browse Mini CPAN. See L<minicpan_webserver> for details on its use.
780            
781             =head1 CURRENT MAINTAINER
782            
783             Christian Walde <walde.christian@googlemail.com>
784            
785             =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
786            
787             =head1 SUPPORT
788            
789             =head2 Bugs / Feature Requests
790            
791             Please report any bugs or feature requests through the issue tracker
792             at L<http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Mini-Webserver>.
793             You will be notified automatically of any progress on your issue.
794            
795             =head2 Source Code
796            
797             This is open source software. The code repository is available for
798             public review and contribution under the terms of the license.
799            
800             L<https://github.com/wchristian/cpan-mini-webserver>
801            
802             git clone https://github.com/wchristian/cpan-mini-webserver.git
803            
804             =head1 AUTHORS
805            
806             =over 4
807            
808             =item *
809            
810             Leon Brocard <acme@astray.com>
811            
812             =item *
813            
814             Christian Walde <walde.christian@googlemail.com>
815            
816             =back
817            
818             =head1 COPYRIGHT AND LICENSE
819            
820             This software is copyright (c) 2012 by Christian Walde.
821            
822             This is free software; you can redistribute it and/or modify it under
823             the same terms as the Perl 5 programming language system itself.
824            
825             =cut
826              
827              
828             __END__
829            
830