#!/usr/local/bin/perl -w # bbs2web: translate bbs' article to html and insert it to plain text database # # written by fcamel 2004/08/03 # # last update: 2005/05/31 # fixed bug : regexp for
in sprint # ############################################################################## # # fixed bug: # big5 problem => use perl 5.8.1 or higher's feature (use encoding 'big5') # hyper link => add RE rule # ############################################################################## use strict; use encoding 'big5'; #, STDIN => 'big5', STDOUT => 'big5'; sub usage { print </>/g; } return @t; } # normal print, simular to print sub nprint { print POUT @_; } # space print, output   for / +/ sub pprint { my $pat = $_[0]; #$pat =~ s/ /$space/g; nprint $pat; } # special print, output some html tags if need # support: # hyper link : # ==+ :
# [note] : colorful sub sprint { my $pat = $_[0]; if ($pat =~ m#(^\S+?://.*)(\s+)(.*)#) { nprint ""; pprint $1; nprint ""; pprint $2; nprint $3; } elsif ($pat =~ m#(^\S+?://.*)#) { nprint ""; pprint $1; nprint ""; } elsif ($pat =~ m#(.*\s+)(.+://.*)(\s+)(.*)#) { pprint $1; nprint ""; pprint $2; nprint ""; pprint $3; nprint $4; } elsif ($pat =~ m#(.*\s+)(.+://.*)#) { pprint $1; nprint ""; pprint $2; nprint ""; } elsif ($pat =~ /^==+/) { nprint "
"; } elsif ($pat =~ /\[note\](.*)/i) { nprint "[NOTE]"; pprint "$1"; } else { pprint "$pat"; } } # input: ANSI color argus, ex: 1;33;46 (ignore error argument) # like ANSI color, it won't reset untill you set it, or give no argument my $isLight = 0; my $fg = 7; my $bg = 16; sub color { my $format = $_[0]; my $hasArgu = 0; @_ = split /\;/, $format; nprint ""; foreach (sort @_) { if ($_ eq "") { # null field, reset ($isLight, $fg, $bg) = (0, 7, 16); } ($isLight, $hasArgu) = (1, 1) if $_ eq 1; ($fg, $hasArgu) = ($_%10, 1) if /3\d/; ($bg, $hasArgu) = ($_%10+16, 1) if /4\d/; } $fg |= 8 if $isLight; # check if no argu (reset) ($isLight, $fg, $bg) = (0, 7, 16) if $hasArgu == 0; nprint ""; } # output html header and pre-setting sub header { nprint < TITLE_TO_SUBSTITUDE
EOF } # output html tailer and post-setting sub tailer { nprint <
EOF } # read mail header, set environment value sub initSetting { # check permission my $ok = 1; $ok = 0 if $is_secure; while () { last if /^From.+@.+/i; } eof and die "cannot find 'From....'\n"; foreach my $s (@sender) { $ok = 1 if /^From.*$s.*/i; } chomp; die "$_: not permitted\n" if $ok == 0; # check destination $ok = 0; while () { last if /^To.+@.+/i; } my $i = 0; for ($i=0; $i<=$#receiver; $i++) { if (/^To.*$receiver[$i].*/i) { $ok = 1; last; } } chomp; die "$_: can't find receiver\n" if ($ok == 0 && $is_insert_db); return $i; } # read from stdin, write to stdout($tmpfile) # translate bbs article to html sub bbs2web { my $pre = ""; if ($is_insert_db) { $pre = $prefix[initSetting]; -d $pre or die "$pre not found or not a directory\n"; } my $class; my $title; open POUT, ">:encoding(big5)", $tmpfile or die "cannot open $tmpfile\n"; # find start position while () { last if /^作者.*看板.*/; } # # init html # header; nprint "\n"; # 作者 看板 nprint ""; chomp; if (/^作者:?(.*)看板:?(.*)/) { my ($ta, $tb) = html_sc $1, $2; nprint ""; pprint ""; nprint ""; pprint "\n"; } else { pprint "$_
\n"; } nprint "\n"; # 標題 [分類] nprint "\n"; $_ = || die "input format error, title?\n"; chomp; if (/^標題:?(.*?)\[(.*?)\](.*)/) { my ($ta, $tb, $tc) = html_sc $1, $2, $3; $class = $2; # non-modified $title = $ta . $tc; nprint ""; pprint "\n"; } elsif (/^標題:?(.*)/) { # not classified yet my ($ta) = html_sc $1; $class = "etc"; $title = $ta; nprint ""; pprint "\n"; } else { pprint "$_
\n"; } nprint "\n"; # 時間 nprint "\n"; $_ = || die "input format error, date?\n"; chomp; if (/^時間:?(.*)/) { my ($ta) = html_sc $1; color "34"; nprint ""; color "37"; pprint "\n"; } else { my ($ta) = html_sc $_; pprint "$ta
\n"; } nprint "\n"; nprint "
"; pprint " 作者"; pprint " $ta"; pprint " 看板 "; pprint " $tb
"; pprint " 標題$ta"; nprint " [$tb] "; pprint " $tc"; pprint " 標題$ta
 時間 $ta
\n"; nprint "
"; # # context # #nprint "\n
";
	nprint "\n
";
	nprint "";	# global font size setting
	nprint "";

	while () {
		chomp;
		# drop texts after "--"
		last if /^--$/;
		# if reply article
		color ";32;40" if /^(>|※).*/;
		# if include ANSI color
		while (/(.*?)\033\[(.*?)m(.*)/) {
			my ($ta) = html_sc $1;
			sprint $ta;
			color $2;
			$_ = $3;
		}
		my ($ta) = html_sc $_;
		sprint $ta;
		color "" if /^(>|※).*/;
		nprint "\n";
	}

	nprint "";
	nprint "
\n";
	tailer;

	close POUT;

	return ($pre, $class, $title);
}

# insert $tmpfile to plain text "database"
sub insertDB
{
	my ($pre, $class, $title) = @_;

	$class =~ tr/A-Z/a-z/;
	# if $class don't exist, create it
	if (! -d "$pre/$class") {
		mkdir "$pre/$class";
		system "echo 1 > $pre/$class/.sn";
		system "touch $pre/$class/.db";
	}
	# read/update serial number
	open SN, "<$pre/$class/.sn" or die "cannot open $pre/$class/.sn for read\n";
	my $sn = ;
	chomp $sn;
	close SN;
	open SN, ">$pre/$class/.sn" or die "cannot open $pre/$class/.sn for write\n";
	print SN $sn+1;
	close SN;
	# rename and update .db
	system "mv $tmpfile $pre/$class/$sn.htm" 
		and die "rename $tmpfile to $pre/$class/$sn.htm failed\n";
	open DB, ">>:encoding(big5)", "$pre/$class/.db" or die "cannot open $pre/$class/.db for append\n";
	$title =~ s/\s*(.*)\s*/$1/;	# truncate leading and tail space
	print DB "$sn\t$title\t0\n";
	close DB;
}

# pass2, set html title
sub setTitle
{
	my $title = $_[0];
	open TMPIN, "encoding(big5)", "$tmpfile.tmp" or die "cannot open $tmpfile.tmp for write\n";
	while () {
		if (/.*title.*TITLE_TO_SUBSTITUDE.*\/title.*/) {
			print TMPOUT "$title\n";
		} else {
			print TMPOUT;
		}
	}
	close TMPIN;
	close TMPOUT;
	system "mv -f $tmpfile.tmp $tmpfile" 
		and die "rename $tmpfile.tmp to $tmpfile failed\n";
}

#
# main
#
if ($#ARGV >= 0) {
	for (my $i=0; $i<=$#ARGV; $i++) {
		$is_secure = 1 if $ARGV[$i] eq "-p";	
		$is_insert_db = 1 if $ARGV[$i] eq "-i";	
		(usage or exit 0) if  $ARGV[$i] eq "-h";
	}
}
my ($pre, $class, $title) = bbs2web;
# set title (can't set it during first pass)
setTitle $title;

if ($is_insert_db) {
	insertDB $pre, $class, $title;
} else {
	system "cat $tmpfile" and die "cat $tmpfile failed\n";
	unlink $tmpfile || die "cannot unlink $tmpfile\n";
}