view release on metacpan or  search on metacpan

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

                $sth_set_file_status->execute("err", $la_res->[1], time(), $la_res->[3]{'func.file_id'});
                $sth_set_meta_status->execute("err", "file err", time(), $la_res->[3]{'func.file_id'});
                next FILE;
            }
            my @members = @{ $la_res->[2] };
            my $zip = $la_res->[3]{'func.zip'};
            my $tar = $la_res->[3]{'func.tar'};

            my $code_is_script = sub {
                my $name = shift;
                unless ($name =~ m!\A
                                   (?:\./)?
                                   (?:[^/]+/)?
                                   (?:s?bin|scripts?)/
                                   ([^/]+)
                                   \z!x) {
                    return (undef);
                }
                my $script_name = $1;
                if ($script_name =~ /\A\./ # e.g. "bin/.exists"
                        || $script_name =~ /\A(?:README(?:\.\w+)?)\z/) { # probably not a script
                    return (undef);
                }
                return ($script_name);
            };

            my $code_is_pm_or_pod = sub {
                my $name = shift;
                # flat, *.pm in top-level
                if ($name =~ m!\A
                               (?:\./)?
                               (?:[^/]+/)? # enclosing dir
                               [^/]+\.(?:pm|pod)?
                               \z
                              !ix) {
                    return 1;
                }
                # *.pm under lib
                if ($name =~ m!\A
                               (?:\./)?
                               (?:[^/]+/)? # enclosing dir
                               lib/
                               (?:[^/]+/)*
                               [^/]+\.(?:pm|pod)?
                               \z
                              !ix) {
                    return 1;
                }
                return 0;
            };

            if (!$file->{file_status}) {
                # list contents & scripts and insert into database
                my %script_names;
                if ($zip) {
                    for my $member (@members) {
                        # skip directory/symlinks
                        next if $member->{isSymbolicLink} || $member->{fileName} =~ m!/\z!;
                        my $now = time();
                        $sth_ins_content->execute(
                            $file->{id}, $member->{fileName}, $member->{lastModFileDateTime}, $member->{uncompressedSize},
                            $now,$now);
                        my $content_id = $dbh->last_insert_id("","","","");
                        my ($script_name) = $code_is_script->($member->{fileName});
                        if (defined $script_name) {
                            unless ($script_names{$script_name}++) {
                                my $now = time();
                                $sth_ins_script->execute($script_name, $file->{cpanid}, $content_id, $file->{id},
                                                         $now,$now);
                            }
                        }
                    }
                } else {
                    my %mem; # tar allows duplicate path?
                    for my $member (@members) {
                        next if $member->{full_path} =~ m!/\z!;
                        next if !$member->{size};
                        next if $mem{$member->{full_path}}++;
                        my $now = time();
                        $sth_ins_content->execute(
                            $file->{id}, $member->{full_path}, $member->{mtime}, $member->{size},
                            $now,$now);
                        my $content_id = $dbh->last_insert_id("","","","");
                        my ($script_name) = $code_is_script->($member->{full_path});
                        if (defined $script_name) {
                            unless ($script_names{$script_name}++) {
                                my $now = time();
                                $sth_ins_script->execute($script_name, $file->{cpanid}, $content_id, $file->{id},
                                                     $now,$now);
                            }
                        }
                    }
                }
                $sth_set_file_status->execute("ok", undef, time(), $file->{id});
                $file->{file_status} = 'ok';
            }

            next FILE if $file->{file_status} ne 'ok';

            my $meta;
          GET_META:
            {
                last if $file->{meta_status};
                my ($has_metajson, $has_metayml, $has_makefilepl, $has_buildpl);
                if ($zip) {
                    $has_metajson   = (first { $_ =~ $re_metajson } @members) ? 1:0;
                    $has_metayml    = (first { $_ =~ $re_metayml  } @members) ? 1:0;
                    $has_makefilepl = (first {m!^[/\\]?(?:[^/\\]+[/\\])?Makefile\.PL$!} @members) ? 1:0;
                    $has_buildpl    = (first {m!^[/\\]?(?:[^/\\]+[/\\])?Build\.PL$!} @members) ? 1:0;
                } else {
                    $has_metajson   = (first { $_->{full_path} =~ $re_metajson } @members) ? 1:0;
                    $has_metayml    = (first { $_->{full_path} =~ $re_metayml  } @members) ? 1:0;
                    $has_makefilepl = (first {$_->{full_path} =~ m!/([^/]+)?Makefile\.PL$!} @members) ? 1:0;
                    $has_buildpl    = (first {$_->{full_path} =~ m!/([^/]+)?Build\.PL$!} @members) ? 1:0;
                }

                my $gm_res = _get_meta($la_res);
                if ($gm_res->[0] == 200) {
                    $meta = $gm_res->[2];
                } else {
                    log_warn("  error in meta: %s", $gm_res->[1]);