view release on metacpan or  search on metacpan

lib/App/lcpan/Cmd/doc.pm  view on Meta::CPAN

                push @where, "path LIKE '%.pm'";
            } elsif ($ext eq 'pod') {
                push @where, "path LIKE '%.pod'";
            }
            push @where, ("NOT(file.name LIKE '%-Lumped-%')"); # tmp
            $row = $dbh->selectrow_hashref("SELECT
  content.path content_path,
  file.cpanid author,
  file.name release
FROM content
LEFT JOIN file ON content.file_id=file.id
".(@where ? " WHERE ".join(" AND ", @where) : "")."
ORDER BY content.size DESC
LIMIT 1", {}, @bind);
            last LOOK if $row;

            if ($ext eq 'pod') {
                # .pod doesn't always declare package so we also try to guess
                # from content path
                $name =~ s!::!/!g; $name .= ".pod";
                @where = ("content.path LIKE ?");
                push @where, ("NOT(file.name LIKE '%-Lumped-%')"); # tmp
                @bind = ("%$name");

                my $sth = $dbh->prepare("SELECT
  content.path content_path,
  file.cpanid author,
  file.name release
FROM content
LEFT JOIN file ON content.file_id=file.id
".(@where ? " WHERE ".join(" AND ", @where) : "")."
ORDER BY content.size DESC");
                $sth->execute(@bind);
                while (my $r = $sth->fetchrow_hashref) {
                    if ($r->{content_path} =~ m!^[^/]+/\Q$name\E$!) {
                        $row = $r;
                        last LOOK;
                    }
                }
            }

        } elsif ($look eq 'script') {

            push @where, "script.name=?";
            push @where, ("NOT(file.name LIKE '%-Lumped-%')"); # tmp
            $row = $dbh->selectrow_hashref("SELECT
  content.path content_path,
  file.cpanid author,
  file.name release
FROM script
LEFT JOIN file ON script.file_id=file.id
LEFT JOIN content ON script.content_id=content.id
".(@where ? " WHERE ".join(" AND ", @where) : "")."
ORDER BY content.size DESC
LIMIT 1", {}, @bind);
            last LOOK if $row;

        }
    }

    return [404, "No such module/POD/script"] unless $row;

    my $path = App::lcpan::_fullpath(
        $row->{release}, $state->{cpan}, $row->{author});

    # XXX needs to be refactored into common code
    my $content;
    if ($path =~ /\.zip$/i) {
        require Archive::Zip;
        my $zip = Archive::Zip->new;
        $zip->read($path) == Archive::Zip::AZ_OK()
            or return [500, "Can't read zip file '$path'"];
        $content = $zip->contents($row->{content_path});
    } else {
        require Archive::Tar;
        my $tar;
        eval {
            $tar = Archive::Tar->new;
            $content = $tar->read($path); # can still die untrapped when out of mem
        };
        return [500, "Can't read tar file '$path': $@"] if $@;
        my ($obj) = $tar->get_files($row->{content_path});
        $content = $obj->get_content;
    }

    if ($content =~ /^=encoding\s+(utf-?8)/im) {
        # doesn't seem necessary
        #$content = decode('utf8', $content, Encode::FB_CROAK);
    }

    if ($args{format} eq 'raw') {
        return [200, "OK", $content, {
            "cmdline.page_result"=>1,
            'cmdline.skip_format'=>1,
        }];
    } elsif ($args{format} eq 'html') {
        require Browser::Open;
        require File::Slurper;
        require File::Temp;
        require File::Util::Tempdir;

        my $tmpdir = File::Util::Tempdir::get_tempdir();
        my $cachedir = File::Temp::tempdir(CLEANUP => 1);
        my $name = $name; $name =~ s/:+/_/g;
        my ($infh, $infile) = File::Temp::tempfile(
            "$name.XXXXXXXX", DIR=>$tmpdir, SUFFIX=>".pod");
        my $outfile = "$infile.html";
        File::Slurper::write_binary($infile, $content);
        system(
            "pod2html",
            "--infile", $infile,
            "--outfile", $outfile,
            "--cachedir", $cachedir,
        );
        return [500, "Can't pod2html: $!"] if $?;
        my $err = Browser::Open::open_browser("file:$outfile");
        return [500, "Can't open browser"] if $err;
        [200];
    } else {
        return [200, "OK", $content, {
            "cmdline.page_result"=>1,