xaicron/gist:329273

## gistfile1.PL
#! C:/Perl/bin/perl
#
# $Id: ldbconv.pl,v 0.7 2009/03/20 08:52:09 xaicron Exp xaicron $
#
# livedoor blog用 script converter
# Perlスクリプトの色を変える
# 入力ファイルがutf8で書かれていることが前提
#
# *更新履歴*
#
# 2008/05/04 : コメント部分のみ作成
#
# 2008/05/16 : クォート部分と予約語に対応
#            : コメント部分のバグ修正
#
# 2008/05/17 : コメント内で「'」または「"」が一つだけ使われていた場合に
#              永久ループするバグを修正
#            : コメント内にクォートがあると読み飛ばされていた部分を修正
#            : コメント内のクォート装飾削除追加
#
# 2008/11/22 : クォート判定で無限ループが発生することがあったのを修正
#            : htmlタグ変換追加
#            : タブはすべてスペースに変換
#            : 予約語の処理をある程度厳密化
#
# 2008/11/23 : 予約語変換のアルゴリズム改善
#              先に正規表現オブジェクトを作成しておくことにより高速化
#
# 2008/12/16 : html部分をそこそこ変更
#
# 2009/02/04 : tableで出力する様に変更
#              一行ごとに色変えはコピペができなくなることにやっとこ気づいたのでやめ
#            : というのを更に止め。行数表示はずれるし難しい。
#
# 2009/02/19 : クォート判定を修正
#
# 2009/02/27 : ベアワード部分追加
#
# 2009/03/20 : クォート内のコメントをスキップし忘れていたのを修正
#              ベアワードに「-」を追加
# 2009/03/21 : 直後が「,」のときはベアワード認定してやんよ
#
# 2010/02/06 : シングルクォートを&#39;に置換
#

=pod
# * TODO *
#2 {
    qw()
    q{}
    s()()
    s[][]
    s{}{}
    とかむずすぎる
}
#3 {
    s/(\/\/\/)/sprintf "\/\/", "\/", '\/', qq{\/}/e
    とか死ねるんじゃないか
}
=cut

use strict;
use warnings;
use utf8;
use 5.010;
use File::Basename qw/basename/;
use Getopt::Std;
use Win32::Unicode::Native;

binmode STDOUT, ':utf8';

# 引数確認
unless ($ARGV[0]) {
    my $basename = basename $0;
    print "Usage : $basename [-cs] [-g=langtype] code-file\n";
    exit 0;
}

# オプション設定
getopts "csg:" => \my %Opt;

if ($Opt{g} and $Opt{g} eq 1) {
    print "Usage: option {g} google prettyprint lang-type\n";
    exit 0;
}

# html定義
my $block_start = '<div class="code">'; # コードブロック開始タグ
my $block_end   = '</div>';             # コードブロック終了タグ
my $com = '<span class="comment">';     # コメント
my $res = '<span class="res">';         # 予約語
my $qot = '<span class="qot">';         # クォート
my $bre = '<span class="bre">';         # ベアワード
my $lin = '<span class="normal">';      # 普通の文字色
my $end = '</span>';                    # 終了タグ

# 開始タグにマッチする正規表現
my $tags = qr'<span[ ]class="[a-z]+">';

# 予約語の正規表現作成
my $list = join '|', map {chomp; "(?:$_)"} sort {length $b <=> length $a} <DATA>;

open my $fh, '<:utf8', shift or die "file not found";

if ($Opt{c}) {
    print "$block_start\n";
}

else {
    print $Opt{g} ? qq/<pre class="prettyprint jang-$Opt{g}">/ : "<pre>", "\n";
}

my $pod;
my $END;
my $code;
while (<$fh>) {
    chomp;

    # タブをスペース4つに
    s/\t/    /g;

    # 空白行は飛ばす
    goto EOP if /^\s*$/;

    # htmlタグの変換
    s/([<>&"])(?!amp;)/'&'.{qw(< lt > gt & amp " quot)}->{$1}.';'/eg;

    # 置換スキップ
    goto EOP if $Opt{s};

    # 行頭がコメントの場合
    goto EOP if (s/^\s*\K(#.*?)$/$com$1$end/);

    # podコメント
    if (s#^(=pod)$#<strong>$1</strong>#) {
        $pod = 1;
        goto EOP;
    }
    if (!$END and s#^(=cut)$#<strong>$1</strong>#) {
        $pod = 0;
    }

    if ($pod) {
#        warn "POD $. : $_\n";
        $_ = "$com$_$end" ;
        goto EOP;
    }

    # END以降
    $END = 1 if (s#^(__END__|__DATA__)$#<strong>$1</strong>#);

    if ($END) {
#        warn "__END__ $. : $_\n";
        $_ = "$com$_$end";
        goto EOP;
    }

    # q//やs///などのクォート部分
    s%
        (                                               # $1 開始
            ^                                           # 先頭から
            (?: [^#'] | (?!&quot;))*                    # #とクォート以外の文字が続く
            (?: [\s,(){}~\[\];]                         # 式の中か区切りの後
                (?:
                    (?:s)                               # s///
                    |(?:q[qrw]?)                        # q// qq// qr// qw//
                    |(?:tr)                             # tr//
                    |(?:m)                              # m//
                )
            )                                           # クォートか正規表現
        )                                               # $1 終了
        (                                               # $2 開始
            (?<qoute>[^\w\s;,}\])_])                    # 開始タグ
            .*?                                         # クォートの中身 [TO DO #1]
            \k<qoute>                                   # 終了タグ
            (?:                                         #
                .*?                                     # 置換の中身 [TO DO #3]
                \k<qoute>                               # 終了タグ (s///)
            )?                                          #
        )                                               # $2 終了
        %$1$qot$2$end%gox;# and warn "$.\t: $2\n"; # TODO #2

    # クォート部分の置換
    s%
      (
          (?<!\\)(?:'(?:([^']*(?:\\')?)(?2))(?<!\\)')
          |
          (?<!\\)(?:&quot;(?:((?:(?!&quot;).)*(?:\\&quot;)?)(?3))(?<!\\)&quot;)
      )
     %$qot$1$end%gox; # TODO #3

    # 予約語の変換
    s%
      (?<![^\s,;\\([{=+*/-])  # スペース,カンマ,セミコロン\,(,[,{,=,-,*,/が直前の文字の
      ($list)                 # 予約語で
      (?=[\s;{(])             # 直後の文字がスペース,セミコロン,(,{のいずれかになっている
    %$res$1$end%gox;

    # クォート内の予約語装飾は削除
    s/($qot(?:(?!$end).)*?)(?:$res)($list)(?:$end)(.*?$end)/$1$2$3/go;

    # クォート内の#は飛ばす("",'')
    goto EOC if m|['"].*?#.*?['"]|;
#    goto EOC if m|$qot[^<]+#[^<]+$end|;
    goto EOC if m|$qot.*?#.*?$end|;

#    warn sprintf "%03d: $_", $.;

    # コメント部分の置換
    s/
        $end
        (?:
            (?! $end | $tags )
            .
        )*?\K
        (
            \#.*?
        )
        $
    /
#        warn sprintf "\t\$1 = $1\n\t\$& = $&";
        "$com$1$end";
    /goex or s/(#.*?)$/$com$1$end/;

    # コメント内のクォート装飾は削除
    s/$com#.*?\K$qot(.*?)$end/$1/go;

    # コメント内の予約語装飾除去
    s/$com#.*?\K$res(.*?)$end/$1/go;
EOC:

    # ベアワードの置換
    s#(?=.\G(?<!$com)|(?<!$qot))([\s{(\[])([\w_-]+)([\s,])(?!$end)#$1$bre$2$end$3#go;
    s#{\s*\K([\w_]+)(\s*})#$bre$1$end$2#go;

    # コメント内とクォート内のベアワード装飾は削除
    s/$com#.*?\K$bre(.*?)$end/$1/go;
    1 while s/$qot(?:(?!$end|$qot).)*?\K$bre(.*?)$end/$1/go;

    # useとsubのあとのベアワードは削除
    s/${res}(?:use|sub)$end\s*\K$bre(.*?)$end/$1/go;


EOP:
    s/'/&#39;/g;

    #***************
    # バッファリング
    #***************
    $code .= $Opt{c} && !/^\s*$/ ? sprintf "$lin%s$end\n", $_  : "$_\n";

    print "$_\n" unless $Opt{c};
}

if ($Opt{c}) {
    printf qq{<p class="header">[コードの説明を書くスペース]</p>\n%s\n%s</pre>\n}, $Opt{g} ? qq/<pre class="prettyprint lang-$Opt{g}">/ : "<pre>", $code;
    print "$block_end\n";
}

else{
    print "</pre>\n";
}

close $fh;

__END__
abs
accept
alarm
atan2
bind
binmode
bless
caller
chdir
chmod
chomp
chop
chown
chr
chroot
close
closedir
connect
continue
cos
crypt
dbmclose
dbmopen
defined
delete
die
do
dump
each
else
elsif
eof
eval
exec
exists
exit
exp
fcntl
fileno
flock
for
foreach
fork
format
formline
getc
getlogin
getpeername
getpgrp
getppid
getpriority
getsockname
getsockopt
glob
gmtime
goto
grep
hex
if
import
index
int
ioctl
join
keys
kill
last
lc
lcfirst
length
link
listen
local
localtime
log
lstat
map
mkdir
msgctl
msgget
msgrcv
msgsnd
my
next
no
oct
open
opendir
ord
our
pack
package
pipe
pop
pos
print
printf
prototype
push
quotemeta
rand
read
readdir
readline
readlink
readpipe
recv
redo
ref
rename
require
reset
return
reverse
rewinddir
rindex
rmdir
scalar
seek
seekdir
select
select
semctl
semget
semop
send
setpgrp
setpriority
setprotoent
setsockopt
shift
shmctl
shmget
shmread
shmwrite
shutdown
sin
sleep
socket
socketpair
sort
splice
split
sprintf
sqrt
srand
stat
study
sub
substr
symlink
syscall
sysopen
sysread
sysseek
system
syswrite
tell
telldir
tie
tied
time
times
truncate
uc
ucfirst
umask
undef
unless
unlink
unpack
unshift
untie
use
utime
values
vec
wait
waitpid
wantarray
warn
while
write
shift
and
or
eq
ne
gt
lt
ge
le
cmp
say
when
given
default
state
not
xor
	#! C:/Perl/bin/perl
	#
	# $Id: ldbconv.pl,v 0.7 2009/03/20 08:52:09 xaicron Exp xaicron $
	#
	# livedoor blog用 script converter
	# Perlスクリプトの色を変える
	# 入力ファイルがutf8で書かれていることが前提
	#
	# 更新履歴
	#
	# 2008/05/04 : コメント部分のみ作成
	#
	# 2008/05/16 : クォート部分と予約語に対応
	# : コメント部分のバグ修正
	#
	# 2008/05/17 : コメント内で「'」または「"」が一つだけ使われていた場合に
	# 永久ループするバグを修正
	# : コメント内にクォートがあると読み飛ばされていた部分を修正
	# : コメント内のクォート装飾削除追加
	#
	# 2008/11/22 : クォート判定で無限ループが発生することがあったのを修正
	# : htmlタグ変換追加
	# : タブはすべてスペースに変換
	# : 予約語の処理をある程度厳密化
	#
	# 2008/11/23 : 予約語変換のアルゴリズム改善
	# 先に正規表現オブジェクトを作成しておくことにより高速化
	#
	# 2008/12/16 : html部分をそこそこ変更
	#
	# 2009/02/04 : tableで出力する様に変更
	# 一行ごとに色変えはコピペができなくなることにやっとこ気づいたのでやめ
	# : というのを更に止め。行数表示はずれるし難しい。
	#
	# 2009/02/19 : クォート判定を修正
	#
	# 2009/02/27 : ベアワード部分追加
	#
	# 2009/03/20 : クォート内のコメントをスキップし忘れていたのを修正
	# ベアワードに「-」を追加
	# 2009/03/21 : 直後が「,」のときはベアワード認定してやんよ
	#
	# 2010/02/06 : シングルクォートを'に置換
	#

	=pod
	# * TODO *
	#2 {
	qw()
	q{}
	s()()
	s[][]
	s{}{}
	とかむずすぎる
	}
	#3 {
	s/(\/\/\/)/sprintf "\/\/", "\/", '\/', qq{\/}/e
	とか死ねるんじゃないか
	}
	=cut

	use strict;
	use warnings;
	use utf8;
	use 5.010;
	use File::Basename qw/basename/;
	use Getopt::Std;
	use Win32::Unicode::Native;

	binmode STDOUT, ':utf8';

	# 引数確認
	unless ($ARGV[0]) {
	my $basename = basename $0;
	print "Usage : $basename [-cs] [-g=langtype] code-file\n";
	exit 0;
	}

	# オプション設定
	getopts "csg:" => \my %Opt;

	if ($Opt{g} and $Opt{g} eq 1) {
	print "Usage: option {g} google prettyprint lang-type\n";
	exit 0;
	}

	# html定義
	my $block_start = '<div class="code">'; # コードブロック開始タグ
	my $block_end = '</div>'; # コードブロック終了タグ
	my $com = '<span class="comment">'; # コメント
	my $res = '<span class="res">'; # 予約語
	my $qot = '<span class="qot">'; # クォート
	my $bre = '<span class="bre">'; # ベアワード
	my $lin = '<span class="normal">'; # 普通の文字色
	my $end = '</span>'; # 終了タグ

	# 開始タグにマッチする正規表現
	my $tags = qr'<span[ ]class="[a-z]+">';

	# 予約語の正規表現作成
	my $list = join '\|', map {chomp; "(?:$_)"} sort {length $b <=> length $a} <DATA>;

	open my $fh, '<:utf8', shift or die "file not found";

	if ($Opt{c}) {
	print "$block_start\n";
	}

	else {
	print $Opt{g} ? qq/<pre class="prettyprint jang-$Opt{g}">/ : "<pre>", "\n";
	}

	my $pod;
	my $END;
	my $code;
	while (<$fh>) {
	chomp;

	# タブをスペース4つに
	s/\t/ /g;

	# 空白行は飛ばす
	goto EOP if /^\s*$/;

	# htmlタグの変換
	s/([<>&"])(?!amp;)/'&'.{qw(< lt > gt & amp " quot)}->{$1}.';'/eg;

	# 置換スキップ
	goto EOP if $Opt{s};

	# 行頭がコメントの場合
	goto EOP if (s/^\s\K(#.?)$/$com$1$end/);

	# podコメント
	if (s#^(=pod)$#<strong>$1</strong>#) {
	$pod = 1;
	goto EOP;
	}
	if (!$END and s#^(=cut)$#<strong>$1</strong>#) {
	$pod = 0;
	}

	if ($pod) {
	# warn "POD $. : $_\n";
	$_ = "$com$_$end" ;
	goto EOP;
	}

	# END以降
	$END = 1 if (s#^(__END__\|__DATA__)$#<strong>$1</strong>#);

	if ($END) {
	# warn "__END__ $. : $_\n";
	$_ = "$com$_$end";
	goto EOP;
	}

	# q//やs///などのクォート部分
	s%
	( # $1 開始
	^ # 先頭から
	(?: [^#'] \| (?!"))* # #とクォート以外の文字が続く
	(?: [\s,(){}~\[\];] # 式の中か区切りの後
	(?:
	(?:s) # s///
	\|(?:q[qrw]?) # q// qq// qr// qw//
	\|(?:tr) # tr//
	\|(?:m) # m//
	)
	) # クォートか正規表現
	) # $1 終了
	( # $2 開始
	(?<qoute>[^\w\s;,}\])_]) # 開始タグ
	.*? # クォートの中身 [TO DO #1]
	\k<qoute> # 終了タグ
	(?: #
	.*? # 置換の中身 [TO DO #3]
	\k<qoute> # 終了タグ (s///)
	)? #
	) # $2 終了
	%$1$qot$2$end%gox;# and warn "$.\t: $2\n"; # TODO #2

	# クォート部分の置換
	s%
	(
	(?<!\\)(?:'(?:([^']*(?:\\')?)(?2))(?<!\\)')
	\|
	(?<!\\)(?:"(?:((?:(?!").)*(?:\\")?)(?3))(?<!\\)")
	)
	%$qot$1$end%gox; # TODO #3

	# 予約語の変換
	s%
	(?<![^\s,;\\([{=+/-]) # スペース,カンマ,セミコロン\,(,[,{,=,-,,/が直前の文字の
	($list) # 予約語で
	(?=[\s;{(]) # 直後の文字がスペース,セミコロン,(,{のいずれかになっている
	%$res$1$end%gox;

	# クォート内の予約語装飾は削除
	s/($qot(?:(?!$end).)?)(?:$res)($list)(?:$end)(.?$end)/$1$2$3/go;

	# クォート内の#は飛ばす("",'')
	goto EOC if m\|['"].?#.?['"]\|;
	# goto EOC if m\|$qot[^<]+#[^<]+$end\|;
	goto EOC if m\|$qot.?#.?$end\|;

	# warn sprintf "%03d: $_", $.;

	# コメント部分の置換
	s/
	$end
	(?:
	(?! $end \| $tags )
	.
	)*?\K
	(
	\#.*?
	)
	$
	/
	# warn sprintf "\t\$1 = $1\n\t\$& = $&";
	"$com$1$end";
	/goex or s/(#.*?)$/$com$1$end/;

	# コメント内のクォート装飾は削除
	s/$com#.?\K$qot(.?)$end/$1/go;

	# コメント内の予約語装飾除去
	s/$com#.?\K$res(.?)$end/$1/go;
	EOC:

	# ベアワードの置換
	s#(?=.\G(?<!$com)\|(?<!$qot))([\s{(\[])([\w_-]+)([\s,])(?!$end)#$1$bre$2$end$3#go;
	s#{\s\K([\w_]+)(\s})#$bre$1$end$2#go;

	# コメント内とクォート内のベアワード装飾は削除
	s/$com#.?\K$bre(.?)$end/$1/go;
	1 while s/$qot(?:(?!$end\|$qot).)?\K$bre(.?)$end/$1/go;

	# useとsubのあとのベアワードは削除
	s/${res}(?:use\|sub)$end\s\K$bre(.?)$end/$1/go;


	EOP:
	s/'/'/g;

	#***************
	# バッファリング
	#***************
	$code .= $Opt{c} && !/^\s*$/ ? sprintf "$lin%s$end\n", $_ : "$_\n";

	print "$_\n" unless $Opt{c};
	}

	if ($Opt{c}) {
	printf qq{<p class="header">[コードの説明を書くスペース]</p>\n%s\n%s</pre>\n}, $Opt{g} ? qq/<pre class="prettyprint lang-$Opt{g}">/ : "<pre>", $code;
	print "$block_end\n";
	}

	else{
	print "</pre>\n";
	}

	close $fh;

	__END__
	abs
	accept
	alarm
	atan2
	bind
	binmode
	bless
	caller
	chdir
	chmod
	chomp
	chop
	chown
	chr
	chroot
	close
	closedir
	connect
	continue
	cos
	crypt
	dbmclose
	dbmopen
	defined
	delete
	die
	do
	dump
	each
	else
	elsif
	eof
	eval
	exec
	exists
	exit
	exp
	fcntl
	fileno
	flock
	for
	foreach
	fork
	format
	formline
	getc
	getlogin
	getpeername
	getpgrp
	getppid
	getpriority
	getsockname
	getsockopt
	glob
	gmtime
	goto
	grep
	hex
	if
	import
	index
	int
	ioctl
	join
	keys
	kill
	last
	lc
	lcfirst
	length
	link
	listen
	local
	localtime
	log
	lstat
	map
	mkdir
	msgctl
	msgget
	msgrcv
	msgsnd
	my
	next
	no
	oct
	open
	opendir
	ord
	our
	pack
	package
	pipe
	pop
	pos
	print
	printf
	prototype
	push
	quotemeta
	rand
	read
	readdir
	readline
	readlink
	readpipe
	recv
	redo
	ref
	rename
	require
	reset
	return
	reverse
	rewinddir
	rindex
	rmdir
	scalar
	seek
	seekdir
	select
	select
	semctl
	semget
	semop
	send
	setpgrp
	setpriority
	setprotoent
	setsockopt
	shift
	shmctl
	shmget
	shmread
	shmwrite
	shutdown
	sin
	sleep
	socket
	socketpair
	sort
	splice
	split
	sprintf
	sqrt
	srand
	stat
	study
	sub
	substr
	symlink
	syscall
	sysopen
	sysread
	sysseek
	system
	syswrite
	tell
	telldir
	tie
	tied
	time
	times
	truncate
	uc
	ucfirst
	umask
	undef
	unless
	unlink
	unpack
	unshift
	untie
	use
	utime
	values
	vec
	wait
	waitpid
	wantarray
	warn
	while
	write
	shift
	and
	or
	eq
	ne
	gt
	lt
	ge
	le
	cmp
	say
	when
	given
	default
	state
	not
	xor