#!/usr/bin/perl
use strict;
use CGI;
use CGI::Carp qw/fatalsToBrowser/;
use Time::Local;
use Encode qw/from_to/;
use lib qw(./ D:/sitedata/Domains/mot-school.jp/ROOT/Inetpub/wwwroot/cgi-bin);
use Topics;
use Topics::Conf;
use utf8;
binmode STDOUT, ':utf8';
my $WEB_BASE = '/';
my $query = new CGI;
my $cgi = {};
$cgi->{GENRE_ID} = $query->param('GENRE_ID');
$cgi->{GENRE_ID} = undef unless $cgi->{GENRE_ID} =~ /^\d+$/;
$cgi->{GENRE_ID} ||= 3;
$cgi->{TOPICS_ID} = $query->param('TOPICS_ID');
$cgi->{TOPICS_ID} = 0 unless $cgi->{TOPICS_ID} =~ /^\d+$/;
my %GENRE_ATTR = (
2 => [ 'common', '全 般', '01' ]
,3 => [ 'osaka', '大阪校', '02' ]
,4 => [ 'tokyo', '東京校', '04' ]
,5 => [ 'nagoya', '名古屋校', '03' ]
);
my $dbh = &dbh;
my $get_topics = $dbh->prepare( <{TOPICS_ID} ) {
$get_topics->execute( $tid );
$get_topics->bind_columns( undef, \( $t_id, $t_date, $t_title, $t_sdate, $t_edate, $t_desc, $t_cont, $t_dlink, $t_link) );
my $topics = $get_topics->fetchrow_arrayref();
$t_id = undef unless $t_title;
# if ( $t_sdate && ( time < to_epoch( $t_sdate ) ) ) {
# $t_id = undef;
# }
# if ( $t_edate && ( time > to_epoch( $t_edate, [(59,59,23)] ) ) ) {
# $t_id = undef;
# }
$t_date =~ s/ \d\d:\d\d:\d\d(\.\d\d\d)?//;
$t_date =~ s/\-/./g;
# from_to( $t_title, 'sjis', 'utf-8' );
# from_to( $t_desc, 'sjis', 'utf-8' );
# from_to( $t_cont, 'sjis', 'utf-8' );
$t_cont =~ s/\x0D\x0A|\x0D|\x0A/
/g;
$t_cont = make_link( $t_cont );
$d_link = <>> 詳細はこちら
EOF
}
#$body ||= <{GENRE_ID} != 2 ? <
EOF1
EOF2
$t_title ||= '最新情報(詳細)';
my $html = <
$t_title|MOT(技術経営)スクールの大阪ガスビジネスクリエイト株式会社
$t_date$GENRE_ATTR{$cgi->{GENRE_ID}}->[1]
$t_title
$t_cont
$d_link
EOF1
EOF2
print $html;
$dbh->disconnect;
1;
sub to_epoch {
my ( $ymd, $hms ) = @_;
$hms ||= [ 0, 0, 0 ];
my ( $y, $m, $d );
if ( $ymd =~ /^(\d\d\d\d)[^\d](\d\d)[^\d](\d\d)/ ) {
( $y, $m, $d ) = ( $1, $2, $3 );
}
return undef unless $y && $m && $d;
$_ = timelocal( @$hms, $d, $m - 1, $y - 1900 );
}
sub make_link {
my $str = shift;
my $http_URL_regex =
q{\b(?:https?|shttp)://(?:(?:[-_.!~*'()a-zA-Z0-9;:&=+$,]|%[0-9A-Fa-f} .
q{][0-9A-Fa-f])*@)?(?:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.)} .
q{*[a-zA-Z](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.?|[0-9]+\.[0-9]+\.[0-9]+\.} .
q{[0-9]+)(?::[0-9]*)?(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f]} .
q{[0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-} .
q{Fa-f])*)*(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f} .
q{])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*)} .
q{*)?(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])} .
q{*)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*} .
q{)?};
my $ftp_URL_regex =
q{\bftp://(?:(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*} .
q{(?::(?:[-_.!~*'()a-zA-Z0-9;&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)?@)?(?} .
q{:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?\.)*[a-zA-Z](?:[-a-zA-} .
q{Z0-9]*[a-zA-Z0-9])?\.?|[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+)(?::[0-9]*)?} .
q{(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*(?:/(?} .
q{:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*(?:;type=[} .
q{AIDaid])?)?(?:\?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9} .
q{A-Fa-f])*)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A} .
q{-Fa-f])*)?};
my $mail_regex =
q{(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\} .
q{\[\]\000-\037\x80-\xff])|"[^\\\\\x80-\xff\n\015"]*(?:\\\\[^\x80-\xff][} .
q{^\\\\\x80-\xff\n\015"]*)*")(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x} .
q{80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff])|"[^\\\\\x80-} .
q{\xff\n\015"]*(?:\\\\[^\x80-\xff][^\\\\\x80-\xff\n\015"]*)*"))*@(?:[^(} .
q{\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,;:".\\\\\[\]\0} .
q{00-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[^\x80-\xff])*} .
q{\])(?:\.(?:[^(\040)<>@,;:".\\\\\[\]\000-\037\x80-\xff]+(?![^(\040)<>@,} .
q{;:".\\\\\[\]\000-\037\x80-\xff])|\[(?:[^\\\\\x80-\xff\n\015\[\]]|\\\\[} .
q{^\x80-\xff])*\]))*};
my $tag_regex_ = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))}; #'}}}}
my $comment_tag_regex =
'-]*(?:-[^>-]+)*?)??)*(?:>|$(?!\n)|--.*$)';
my $tag_regex = qq{$comment_tag_regex|<$tag_regex_};
my $text_regex = q{[^<]*};
my $result = ''; my $skip = 0;
while ($str =~ /($text_regex)($tag_regex)?/gso) {
last if $1 eq '' and $2 eq '';
my $text_tmp = $1;
my $tag_tmp = $2;
if ($skip) {
$result .= $text_tmp . $tag_tmp;
$skip = 0 if $tag_tmp =~ /^<\/[aA](?![0-9A-Za-z])/;
} else {
$text_tmp =~ s{($http_URL_regex|$ftp_URL_regex|($mail_regex))}
{my($org, $mail) = ($1, $2);
(my $tmp = $org) =~ s/"/"/g;
'$org"}ego;
$result .= $text_tmp . $tag_tmp;
$skip = 1 if $tag_tmp =~ /^<[aA](?![0-9A-Za-z])/;
if ($tag_tmp =~ /^<(XMP|PLAINTEXT|SCRIPT)(?![0-9A-Za-z])/i) {
$str =~ /(.*?(?:<\/$1(?![0-9A-Za-z])$tag_regex_|$))/gsi;
$result .= $1;
}
}
}
$result;
}