Perl/CGIスクリプト卸問屋は創業以来4,572,536,188名のお客様にご愛顧いただいております。

創業132年を誇る超老舗Perl/CGIスクリプト卸問屋へようこそ。当店では最先端技術駆使して作成したスクリプトを格安のパッケージにして販売するかもしれませんが現在は産地直送のため時価です。当社が持てる技術の粋を集めた7行シリーズをよろしく!(結構適当なのは内緒)

%ENV
@INC (キャッシュ更新中は激重になります)
適当に動かしてみる
ダウンロードとか
  1. ソース ダウンロード project/2ch/test/read.cgi
  2. ソース ダウンロード project/7lines/Storable.pm
  3. ソース ダウンロード project/7lines/_cms.cgi
  4. ソース ダウンロード project/7lines/analysis.cgi
  5. ソース ダウンロード project/7lines/calendar.cgi
  6. ソース ダウンロード project/7lines/counter.cgi
  7. ソース ダウンロード project/7lines/csv.cgi
  8. ソース ダウンロード project/7lines/excel.cgi
  9. ソース ダウンロード project/7lines/gc.cgi
  10. ソース ダウンロード project/7lines/hinomaru.cgi
  11. ソース ダウンロード project/7lines/http.cgi
  12. ソース ダウンロード project/7lines/httpd.pl
  13. ソース ダウンロード project/7lines/mail.cgi
  14. ソース ダウンロード project/7lines/navi.cgi
  15. ソース ダウンロード project/7lines/o.cgi
  16. ソース ダウンロード project/7lines/reverse.cgi
  17. ソース ダウンロード project/7lines/sum.cgi
  18. ソース ダウンロード project/7lines/tournament.cgi
  19. ソース ダウンロード project/7lines/upload.cgi
  20. ソース ダウンロード project/aabb.cgi
  21. ソース ダウンロード project/diary.cgi
  22. ソース ダウンロード project/download.cgi
  23. ソース ダウンロード project/explorer.cgi
  24. ソース ダウンロード project/gallery.cgi
  25. ソース ダウンロード project/mailer.cgi
  26. ソース ダウンロード project/message.cgi
  27. ソース ダウンロード project/mod_chat.cgi
  28. ソース ダウンロード project/research.cgi
  29. いらない ダウンロード project/rss.cgi
    #!/usr/local/bin/perl
    
    
    my $datafile  = './rss.dat';
    my $store_dir = './rdf/';
    my $lines     = 7;
    my $interval  = 60 * 60;
    my $agent     = 'Mozilla/4.0 (compatible; MSIE 7.0b; Windows NT 5.1)';
    my $mode      = 0644;
    my $timeout   = 10;
    my $htmlfiles = 0;
    
    # 設定はここまで。
    # $datafile の書き方はこのファイルの一番下にサンプルが書いてあります。
    # $interval で指定した間隔で取得しに行きますが遅いのでこのファイルを二つ設置し、
    # 1つを $interval = 0 に設定して cron とかで回せばいいと思う。
    # UTF-8 のままにしたい場合は下の use encoding の行をコメントにすればおっけー
    #
    # 追記
    # rss はコピーして使うために配信してくれていると思い込んでいたのですが
    # そうとも限らないようなので配信サイトをよく読んだほうがいいみたいです。
    
    
    use LWP::Simple qw/getstore is_error $ua/;
    use HTTP::Date qw/str2time/;
    use CGI qw/:standard/;
    $ua->agent($agent);
    $ua->timeout($timeout);
    use encoding 'utf8', STDOUT => 'cp932';
    
    sub get_url {
        my $filename = shift;
        my @url;
        if (open my $fh, $filename) {
            @url = grep length && !/^#/, map { s/^\s+//; s/\s+$//; $_ } <$fh>;
            close $fh;
        } else {
            warn $!;
        }
        wantarray ? @url : shift @url;
    }
    
    sub read_rss {
        my $filename = shift;
        my $rss = '';
        if (open my $fh, $filename) {
            binmode $fh;
            read $fh, $rss, -s $fh;
            close $fh;
        } else {
            warn $!;
        }
        $rss;
    }
    
    sub wrong_str_replace {
        my $str = shift;
        if (eval { utf8::is_utf8($str) }) {
            my @list = (
    #            "\x{005c}",
    #            "\x{007e}",
                "\x{00a2}",
                "\x{00a3}",
                "\x{00ac}",
                "\x{2015}",
                "\x{2016}",
                "\x{2212}",
                "\x{2225}",
                "\x{301c}",
                "\x{ff0d}",
                "\x{ff3c}",
                "\x{ff5e}",
                "\x{ffe0}",
                "\x{ffe1}",
                "\x{ffe2}",
    
                "\x{2014}",
                "\x{2717}",
            );
            my $pattern = join '|', @list;
            $str =~ s/($pattern)/'&#' . ord($1) . ';'/eg;
        }
        $str;
    }
    
    sub parse_rss {
        my $rss = shift;
        map scalar {/<(.+?)>\s*(.+?)\s*<\/\1>/g},
            $rss =~ /<rss\s+version="2(?:\.\d+)?".*?>/s
                ? $rss =~ /^(.+?)(?=<item\b)/s
                : $rss =~ /<channel\b.*?>(.+?)<\/channel>/s,
            $rss =~ /<item\b.*?>(.+?)<\/item>/gs;
    }
    
    sub save_html {
        my($dir, @schemas) = @_;
        my %data;
        my @ol = ('<ol class="rss">', '</ol>');
        mkdir $dir, 0700;
        for (1..$#schemas) {
            if (defined(my $t = str2time($schemas[$_]{'dc:date'} || $schemas[$_]{'pubDate'}))) {
                $data{
                        sprintf '%d%02d%02d', sub { $_[5] + 1900, $_[4] + 1, $_[3] }->(localtime $t)
                    }{
                        scalar li(
                            comment(sprintf('%010d', $t))
                                . comment(sprintf '%d-%02d-%02dT%02d:%02d:%02d+00:00', sub { $_[5] + 1900, $_[4] + 1, reverse @_[0..3] }->(gmtime $t))
                                . a({-href => $schemas[$_]{'link'}}, $schemas[$_]{'title'})
                        )
                    } = undef;
            }
        }
        foreach (keys %data) {
            my $path = "$dir/$_.html";
            if (-e $path) {
                if (open my $fh, "+< $path") {
                    eval { flock $fh, 2 };
                    binmode $fh;
                    @{$data{$_}}{map { s/\s+$//; $_ } grep /^<li\b/i, <$fh>} = ();
                    if (seek $fh, 0, 0) {
                        local $SIG{'__WARN__'} = sub {} unless $^W;
                        if (print $fh map "$_\n", $ol[0], sort(keys %{$data{$_}}), $ol[1]) {
                            truncate $fh, tell $fh;
                        }
                    } else {
                        warn $!;
                    }
                    close $fh;
                } else {
                    warn $!;
                }
            } elsif (open my $fh, "> $path") {
                eval { flock $fh, 2 };
                binmode $fh;
                local $SIG{'__WARN__'} = sub {} unless $^W;
                print $fh map "$_\n", $ol[0], sort(keys %{$data{$_}}), $ol[1];
                close $fh;
            } else {
                warn $!;
            }
        }
        wantarray ? %data : \%data;
    }
    
    sub schema2anchor {
        my $schema = shift;
        a {-href => $schema->{'link'}}, $schema->{'title'};
    }
    
    sub schemas2dl {
        my($lines, @schemas) = @_;
        dl
            {-class => 'rss'},
            dt(schema2anchor shift @schemas),
            dd ul map li(schema2anchor $_), splice @schemas, 0, $lines;
    }
    
    
    $store_dir =~ s/[\\\/]+$//;
    print header -charset => '';
    if (-d $store_dir) {
        my @errors;
        foreach (get_url $datafile) {
            if (m{^https?://(.+)$}) {
                my $filename = $1;
                $filename =~ s/\W/_/g;
                my $html_dir = "$store_dir/$filename";
                $filename = "$store_dir/$filename.rdf";
                my @schemas;
                if (((stat $filename)[9] || 0) + $interval < time) {
                    my $rc = getstore($_, $filename);
                    if (is_error($rc)) {
                        push @errors, "$_ => Status: $rc";
                    }
                    chmod $mode, $filename;
                    @schemas = parse_rss wrong_str_replace read_rss $filename;
                    if ($htmlfiles) {
                        save_html($html_dir, @schemas);
                    }
                } else {
                    @schemas = parse_rss wrong_str_replace read_rss $filename;
                }
                print schemas2dl($lines, @schemas);
            }
        }
        print ul [li \@errors] if @errors;
    } else {
        print p $!;
    }
    
    
    __END__
    
    #
    # rss.dat のサンプル。
    #
    # 1行に1つ URL を記述できます。
    # 空行は無視されます。
    # 行頭、行末の空白文字は削除されます。
    # シャープで始まっている行も無視されます。
    # URL の正当性はチェックしていません。
    # 以上です。
    #
    
    http://rss.fujitv.co.jp/fnnnews.xml
    http://japan.cnet.com/rss/index.rdf
    http://allabout.co.jp/rss/all/index.rdf
    #http://www.mysql.com/mysql.rss
    #http://example.com/notfound.rdf
使い方のようなもの
世界カレンダー?
Sister Projects

©2018 Perl/CGIスクリプト卸問屋