#!/usr/bin/perl

#    jsRSS++  jsRSS.cgi 3.15
#
#  Copyright(C) 2004-2005 by 大黒屋
#   http://www.daikoku-ya.org/
#    webmaster@daikoku-ya.org

# Jcode がサーバにインストールされている場合は use lib './'; をコメントアウト
# インストールされていない場合は Jcode.pm のあるディレクトリを use lib './lib'; で指定(ディレクトリ名は任意)

#use lib './lib';
use Jcode;
use Socket;

my $dir_feed = 'feed';          # RSSデータを保存するディレクトリ
my $check    = 60;              # 更新間隔(分)
my $TimeZone = +9;              # 設置するサーバのタイムゾーン

my $dir_temp = 'temp';          # RSS表示用テンプレートのあるディレクトリ
my $def_temp = 'jsRSS.tmp';     # デフォルトのテンプテート

my $CDATA    = 'cut';           # <![CDATA[ ]]> タグを削除する場合は 'cut' 
my $HTMLTAG  = 'cut';           # html のタグを削除する場合は 'cut'、無効化は 'off' に

my @callfrom = (                # 呼び出しを許可するサーバ名を '〜','〜',と列挙する
'http://www.daikoku-ya.org/',
'http://127.0.0.1/',
);

my $CR = 'no';                # 下部のスクリプト名(+リンク)の表示

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # 

my $VER = 3.15;
my %utf8 = (
'jis'  => 'ISO-2022-JP',
'sjis' => 'Shift_JIS',
'euc'  => 'EUC-JP',
'utf8' => 'UTF-8'
);

my $SCRIPT = $ENV{SCRIPT_NAME};
my $ROOT   = $ENV{DOCUMENT_ROOT};
my $SERVER = $ENV{SERVER_NAME};

my %q = ();
my $str    = $ENV{QUERY_STRING};
my @str = split(/::/,$str);
for(@str)
  {
  my($nam,$val) = split(/=/,$_,2);
  $nam =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2",$1)/eg;
  $val =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("H2",$1)/eg;
  $q{$nam} = $val;
  }

my $line = $q{line} || 5;
my $enc  = $q{enc}  || 'euc';
my $temp = $q{temp} || $def_temp;
my $len  = ($q{len}  > 0) ? $q{len}  * 2 : '';
my $tlen = ($q{tlen} > 0) ? $q{tlen} * 2 : '';
my $url  = $q{url};

my %RSS = ();
my $RSS = '';
my @data = ();
my %site = ();

(my $cache = $url) =~ s|\?|_|;
$cache =~ s|http://||;
$cache =~ s|\.||g;
$cache =~ s|/||g;
$cache = "$dir_feed/$cache" . '.dat';

if((grep /$SERVER/,@callfrom) == 0)
  { $RSS = qq(<div>Bad Call!!</div>) }
elsif(length($url) == 0)
  { $RSS = qq(<div>RSSのurlを指定してください</div>) }
elsif(!(-e "$dir_temp/$temp"))
  { $RSS = qq(<div>テンプレートファイルがありません</div>) }
elsif(!(-e $cache))
  {
  my $tmp = &sock('GET','');
  my $rdf = ${$tmp};
  my $status = (split(/\r\n/,$rdf))[0];
  if($status =~ /404/)
    { $RSS = qq(<div>指定されたurlのファイルは存在しません</div>) }
  elsif($status =~ /403/)
    { $RSS = qq(<div>指定されたurlにはアクセス出来ません</div>) }
  elsif($status =~ /401/)
    { $RSS = qq(<div>指定されたurlにはアクセス認証が必要です</div>) }
  elsif($status =~ /500/ || $status !~ /200/)
    { $RSS = qq(<div>指定されたurlでサーバエラーが起きました</div>) }
  else
    {
    my($site,$data) = &parse_rdf($rdf);
    %site = %{$site};
    @data = @{$data};
    &save_cache(\@data);
    }
  }
else
  {
  my %mod_time = ();
  my $now = (time);
  my $checktime = 60 * $check;

  $mod{cache} = (stat $cache)[9];
  $mod{check} = $mod{cache} + $checktime;
  $mod{jst}   = localtime($mod{cache});
  $mod{gmt}   = gmtime($mod{cache});
  $mod{check_gmt}   = gmtime($mod{cache} - (60 * 60 * $TimeZone) + $checktime);

  if($now > $mod{check})
    {
    my $tmp = &sock('HEAD',$mod{check_gmt});
    my $head = ${$tmp};
    my $status = (split(/\r\n/,$head))[0];

    if($status !~ /304/)
      {
      my $tmp = &sock('GET','');
      my $rdf = ${$tmp};
      my($site,$data) = &parse_rdf(${$tmp});
      %site = %{$site};
      @data = @{$data};
      &save_cache(\@data);
      }
    else
      {
      my $tmp = &read_cache;
      @data = @{$tmp};
      }
    }
  else
    {
    my $tmp = &read_cache;
    @data = @{$tmp};$a += 4;
    }
  }

if($RSS eq '')
  {
  chomp @data;

  local $/ = undef;
  open(IN,"<$dir_temp/$temp") or die "$!";
  my $TEMP = <IN>;
  close(IN);
  $TEMP = Jcode -> new(\$TEMP) -> $enc if($enc ne 'euc');

  $TEMP =~ s/\r\n/\n/g;
  $TEMP =~ s/\r/\n/g;
  eval($TEMP);
  
  my($ver,$title,$link,$dsc,$cre,$day) = split(/\t/,$data[0]);

  for('header','footer')
    {
    $RSS{$_} =~ s/#Version#/$ver/g;
    $RSS{$_} =~ s/#SiteTitle#/$title/g;
    $RSS{$_} =~ s/#SiteLink#/$link/g;
    $RSS{$_} =~ s/#SiteDescription#/$dsc/g;
    $RSS{$_} =~ s/#SiteCreator#/$cre/g;
    $RSS{$_} =~ s/#SiteDate#/$day/g;
    }

  $RSS .= $RSS{header};

  my($y,$m,$d,$H,$M,$S) = (localtime(time - 60 * 60 *  $new_entry))[5,4,3,2,1,0];
  my $new_check = sprintf("%04d%02d%02d%02d%02d%02d",$y +1900,$m +1,$d,$H,$M,$S);

  for(1..$line)
    {
    last if(length($data[$_]) < 1);

    my $repeat = $RSS{repeat};
    my($dat,$ttl,$lnk,$sbj,$cre,$dsc) = split(/\t/,$data[$_]);

    if($CDATA eq 'cut')
      {
      $dsc =~ s|<\!\[CDATA\[||gs;
      $dsc =~ s|\]\]>||gs;
      }

    if($HTMLTAG eq 'cut')
      {
      $dsc =~ s/<[^>]*>//g;
      $ttl =~ s/<[^>]*>//g;
      }
    elsif($HTMLTAG eq 'off')
      {
      $dsc =~ s/&/&amp;/g ;
      $dsc =~ s/</&lt;/g ;
      $dsc =~ s/>/&gt;/g ;
      $ttl =~ s/&/&amp;/g ;
      $ttl =~ s/</&lt;/g ;
      $ttl =~ s/>/&gt;/g ;
      }

    if($len != 0)
      {
      my @dsc = jcode($dsc) -> jfold($len);
      $dsc = $dsc[0];
      }

    if($tlen != 0)
      {
      my @ttl = jcode($ttl) -> jfold($tlen);
      $ttl = $ttl[0];
      }

    my $ts = '';
    if($dat ne '')
      {
      my $yyyy = substr($dat,0,4);
      my $mm   = substr($dat,4,2);
      my $dd   = substr($dat,6,2);
      my $HH   = substr($dat,8,2);
      my $MM   = substr($dat,10,2);
      my $SS   = substr($dat,12,2);

      $ts = $time_format;
      $ts =~ s/y/$yyyy/;
      $ts =~ s/m/$mm/;
      $ts =~ s/d/$dd/;
      $ts =~ s/H/$HH/;
      $ts =~ s/M/$MM/;
      $ts =~ s/S/$SS/;
      }

    my $whatsnew = ($new_check <= $dat) ? $new_mark : '';
    my $wnfront  = ($new_check <= $dat) ? $whatsnew_front : '';
    my $wnback   = ($new_check <= $dat) ? $whatsnew_back : '';

    $repeat =~ s/#TimeStamp#/$ts/g;
    $repeat =~ s/#WhatsNew#/$whatsnew/g;
    $repeat =~ s/#WhatsNewFront#/$wnfront/g;
    $repeat =~ s/#WhatsNewBack#/$wnback/g;
    $repeat =~ s/#Title#/$ttl/g;
    $repeat =~ s/#Link#/$lnk/g;
    $repeat =~ s/#Subject#/$sbj/g;
    $repeat =~ s/#Creator#/$cre/g;
    $repeat =~ s/#Description#/$dsc/g;

    $RSS .= $repeat;
    }

  $RSS .= $RSS{footer};
  $RSS .= qq(<div style="font-size:9pt;text-align:center;"><a href="http://www.daikoku-ya.org/?jsRSS$VER" target="_blank">jsRSS++ $VER</a></div>\n) if($CR ne 'no');
  }

$RSS = Jcode -> new(\$RSS) -> $enc if($enc ne 'euc');
@RSS = split(/\n/,$RSS);
for(@RSS) { $_ = "'$_',\n" }
$RSS = join("",@RSS) . "''";

print <<_SRC;
Content-Type: text/html; charset=$enc{enc}

document.write($RSS);
_SRC

exit;

sub parse_rdf
{
my $rdf = shift;
my @data = ();
my %site = ();

$rdf = (getcode($rdf) eq 'euc') ? $rdf : Jcode -> new(\$rdf) -> euc;
$rdf =~ s|\t||g;

my $ent = 'item';
my $dsc = 'description';
my $cre = 'creator';
my $day = 'date';

if   ($rdf =~ m|/atom/| && $rdf =~ m|(?:version="(.+?)".*>)|is)   { $site{VER} = 'atom' . $1; $ent = 'entry'; }
elsif($rdf =~ m|<.*rss.*version="(.+?)"|is)                       { $site{VER} = 'rss' . $1; }
elsif($rdf =~ m|<.*feed.*version="(.+?)"|is)                      { $site{VER} = 'rss' . $1; }
elsif($rdf =~ m|xmlns.*?/purl.org/rss/(.*?)/|is)                  { $site{VER} = 'rss' . $1; }

if($rdf =~ m|encoding="(.+?)"|is)                                 { $site{ENC} = $1; }

my($HEAD,$BODY) = split(/$ent/,$rdf,2);

$HEAD =~ s|\r\n|\n|g;
$HEAD =~ s|\r|\n|g;
$HEAD =~ s|\n||g;

$BODY = "<$ent" . $BODY;

if   ($HEAD =~ m|(?:<title>(.*?)</title>)|is)               { $site{TITLE} = $1 }

if   ($HEAD =~ m|(?:<link>(.+?)</link>)|is)                 { $site{LINK}  = $1 }
elsif($HEAD =~ m|(?:<link.*?href="(.+?)".*? />)|is)         { $site{LINK}  = $1 }

if   ($HEAD =~ m|(?:<description>(.+?)</description>)|is)   { $site{DSC} = $1 }
elsif($HEAD =~ m|(?:<tagline>(.+?)</tagline>)|is)           { $site{DSC} = $1 }

if   ($HEAD =~ m|(?:<.*?creator>(.+?)</.*creator>)|is)      { $site{CRE} = $1 }
elsif($HEAD =~ m|(?:<.*?webMaster>(.+?)</.*webMaster>)|is)  { $site{CRE} = $1 }
elsif($HEAD =~ m|(?:<.*?copyright>(.+?)</.*copyright>)|is)  { $site{CRE} = $1 }

if   ($HEAD =~ m|(?:<.*date>(.+?)</.*date>)|is)             { $site{DAY}  = $1 }
elsif($HEAD =~ m|(?:<.*modified>(.+?)</.*modified>)|is)     { $site{DAY}  = $1 }

for(keys %site)
  {
  $site{$_} =~ s/'/&apos;/g; #'
  $site{$_} =~ s/"/&quot;/g; #"
  }
push @data,join("\t",$site{VER},$site{TITLE},$site{LINK},$site{DSC},$site{CRE},$site{DAY}) . "\n";

$BODY =~ s|<items>.*</items>||is;

my @ENTRY = ($BODY =~ m!<$ent.*?>(.*?)</$ent>!isg);

for(@ENTRY)
  {
  my %entry = ();
  $_ =~ s|\r\n|\n|g;
  $_ =~ s|\r|\n|g;
  $_ =~ s|\n|<br />|g;

  if   ($_ =~ m|(?:<title>(.*?)</title>)|is)                    { $entry{title} = $1 }

  if   ($_ =~ m|(?:<link>(.+?)</link>)|is)                      { $entry{link} = $1  }
  elsif($_ =~ m|(?:<link.*?href="(.+?)".* />.*?)|is)            { $entry{link} = $1  }

  if   ($_ =~ m|(?:<description>(.+?)</description>)|is)        { $entry{description} = $1 }
  elsif($_ =~ m|(?:<summary.*?>(.+?)</summary>)|is)             { $entry{description} = $1 }
  elsif($_ =~ m|(?:<content:encoded>(.+?)</content:encoded>)|is){ $entry{description} = $1 }

  if   ($_ =~ m|(?:<.*subject.*?>(.+?)</.*subject>)|is)         { $entry{subject} = $1 }

  if   ($_ =~ m|(?:<.*creator.*?>(.+?)</.*creator>)|is)         { $entry{creator} = $1 }
  elsif($_ =~ m|(?:<author>.*<name>(.+?)</name>.*</author>)|is) { $entry{creator} = $1 }

  if   ($_ =~ m|(?:<.*date.*?>(.+?)</.*date>)|is)               { $entry{date} = $date = $1 }
  elsif($_ =~ m|(?:<.*issued.*?>(.+?)</.*issued>)|is)           { $entry{date} = $date = $1 }

  if($entry{date} =~ m!(\d+).(\w+).(\d{4}).(\d+):(\d+):(\d+)!) #Y!
    {
    my %MON = ('Jan' => 1,'Feb' => 2,'Mar' => 3,'Apr' => 4,'May' => 5,'Jun' => 6,'Jul' => 7,'Aug' => 8,'Sep' => 9,'Oct' => 10,'Nov' => 11,'Dec' => 12);
    $entry{date} = sprintf("%04d%02d%02d%02d%02d%02d",$3,$MON{$2},$1,$4,$5,$6);
    }
  else
    {
    $entry{date} =~ s![+|-]\d\d:\d\d!!;
    $entry{date} =~ s![-|:|T]!!g;
    }

  while(length($entry{date}) < 14 && length($entry{date}) > 1) { $entry{date} .= '0' }

  my $new_data = join("\t",$entry{date},$entry{title},$entry{link},$entry{subject},$entry{creator},$entry{description}) ."\n";

  $new_data =~ s/'/&apos;/g; #'
  $new_data =~ s/"/&quot;/g; #"
  push @data,$new_data;
  }
return \%site,\@data;
}

sub read_cache
{
open(IN,"<$cache") or die "$!";
my @data = <IN>;
close(IN);
return \@data;
}

sub save_cache
{
my @data = @{$_[0]};
open(OUT,">$cache") or die "$! :: ";
print OUT @data;
close(OUT);
}

sub sock
{
my($method,$last_mod) = @_;
my $rss = '';
my $URL = $url;
$URL =~ m|http://([^:/]*)(:(\d+))?(/.*)?|;
$host = $1;
($port = $3) || ($port = 80);
($path = $4) || ($path = '/');

$ipaddr = inet_aton($host);

socket(SOCK,PF_INET,SOCK_STREAM,getprotobyname('tcp')) or die "$!";
connect(SOCK,sockaddr_in($port,$ipaddr)) or die "Cannot Connect to $host:\n$!";
select(SOCK); $| = 1;
select(STDOUT);

$request  = "$method $path HTTP/1.0\r\n";
$request .= "Host: $host\r\n";
$request .= "User-Agent: jsRSS++/$VER (http://www.daikoku-ya.org/)\r\n";
$request .= "If-Modified-Since: $last_mod\r\n" if($method eq 'HEAD');
$request .= "\r\n";

print SOCK $request;
while(<SOCK>) { $rss .= $_ }
close(SOCK);

return \$rss;
}