最終更新：2004-08-30 05:02:13
FSWikiLite用の共通ライブラリ（Utilパッケージ）を拡張する、私家版ライブラリ集。
- 自作プラグイン向けに作った関数群
- 公式のプラグイン投稿に投稿されたものを取り込む
構成
方針を考える。
バージョン1
FSWikiLiteが動くところならば同様に動作することが期待できる。具体的には＠niftyでも動作可能な実装。
- まずはこの範囲の実装レベルを念頭に置く。
バージョン2
標準ライブラリ（5.005、5.6.1もしくは5.8.0。どれがいいだろう）と、非XSモジュールを利用していて、FTPでアップロードして使える。
- 上記とは別パッケージでまとめる。
バージョン3
全てのCPANモジュールが利用可能で、それ以外のXSを含むモジュールも利用可能。バージョン依存の機能を利用している。RDBMSなどを利用している。
- このような実装はしない方針。
ソース
まだ整理されていないです。名前やインターフェイスが随時変更される、不安定バージョンです。
- 2004-06-27 修正 abs_url(), site_base_uri(), site_base_dir()
package Util;
#===============================================================================
# 以下はプラグインなどから利用することができるユーティリティ
#===============================================================================
# package Util::Plugin::naoto;
#=============================================================================
# テーマの設定を一時的に上書きする
#=============================================================================
# いしだなおと 2004-05-05
# tDiaryと同じ配置でテーマが配置されていることが前提になります。
# {theme_dir}/{theme}/{theme}.css
# 有効なテーマ名が与えられた場合のみ、変更する。
# THEME_DIRの設定がない場合には、存在チェックができない。（「/」ではじまる絶対URLの場合に対応できないため）
sub set_tdiary_theme {
my $select = shift || return 0, qq!error: theme name was required!;
my $theme = $main::THEME_URL;
# テーマ名を抽出＆サニタイズ
$select = &Util::escapeHTML($select);
$select =~ s/[\Q&;:|<>\/\E]//g;
$select =~ s/\.(?:\.+)//g;
if ($main::THEME_DIR) {
# THEME_DIRに指定のテーマがあるか調べる
$main::THEME_DIR =~ s!(/*)$!!;
$theme = "$main::THEME_DIR/$select/${select}.css";
return 0, qq!error: file not found: $theme! unless (-e $theme);
} else {
# 元の設定からテーマのあるディレクトリを調べ、新しいテーマのURIを組み立てる
$theme =~ m!^(.+?)/(\w+?)/\2.css$!;
$theme = "$1/$select/${select}.css";
my $themefile = &Util::site_base_dir() . $theme;
return 0, qq!error: file not found: $theme! unless (-e $themefile);
}
# グローバル変数にセット
$main::THEME_URL = $theme;
# 成功時の返値は、テーマのURI
return $theme;
}
#===============================================================================
# epochを受取り、W3C-DTF形式に変換した文字列を返す
#===============================================================================
# いしだなおと 2003-12-24
sub time2dcdate {
# TimeZoneは、setup.plになければ決め打ち
my $tz = $main::TIME_ZONE || '+09:00';
my($time) = @_;
my($sec,$min,$hour,$mday,$mon,$year) = (localtime($time))[0..5];
$year += 1900;
$mon++;
my $dcdate = sprintf("%04d-%02d-%02dT%02d:%02d:%02d", $year, $mon, $mday, $hour, $min, $sec);
$dcdate .= $tz;
return $dcdate;
}
#===============================================================================
# 指定文字数で切り詰め、（あれば）「…」などの文字をつけて返す
#===============================================================================
sub trim_euc {
## via: http://nais.to/~yto/tools/jbuncut/
## via: http://www.din.or.jp/~ohzaki/perl.htm
# 文字を一文字ずつ処理（日本語対応。漢字コードはEUCとする）
my $str = shift;
my $limit = shift || 252;
my $limit_hard = 4096;
my $continue = shift;
my($ret, $i) = ('', '0');
while ($str =~ /([\xa1-\xfe]{2}|\x8e[\xa1-\xdf]|\x8f[\xa1-\xfe]{2}|.)/g) {
$ret .= $1;
if ($1 =~ /(。|．)/) {
$ret .= "\n";
last if $i++ > int($limit);
}
last if $i++ > int($limit_hard);
}
if ($continue) {
$ret .= length($ret) < int($limit) ? '' : $continue;
}
return $ret
}
sub site_base_uri {
my $uri = $ENV{'SCRIPT_NAME'};
$uri =~ s!^(.*?)(?:[\./]+?)(?:\w+\.cgi|\w+\.pl|/)$!$1!;
return 'http://' . $ENV{'HTTP_HOST'} . $uri;
}
sub site_base_dir {
my $dir = $ENV{'SCRIPT_FILENAME'};
$dir =~ s!^(.*?)(?:[\./]+?)(?:\w+\.cgi|\w+\.pl|/)$!$1!;
return $dir;
}
#===============================================================================
# ページ名を受取り、絶対URLを返す。リストコンテキストでは、TrackBack Ping URLも一緒に返す
#===============================================================================
# いしだなおと 2003-12-24
sub abs_url {
my $page = shift || $main::in{"p"} || 'FrontPage';
# 拒否リストのページにはundefを返す
my $deny_tb = '';
my %special_page = ();
foreach (@$main::WB_DENY_PAGE) {$special_page{$_} = 1;}
if ($special_page{$page}) {$deny_tb = 1;}
my $enc_page = &Util::url_encode($page);
$page = &Util::escapeHTML($page);
# my $wikiurl = &main::MyBaseUrl();
my $wikiurl = &Util::site_base_uri();
my $url = "/${main::MAIN_SCRIPT}?p=$enc_page";
$url =~ s!^//!/!;
# $url =~ s!/\?!?!;
$url = $wikiurl . $url;
$url = &Util::escapeHTML($url);
# setup.plで設定されていなければ規定値（tb.cgi）を使う
my $tb_script = $main::TB_SCRIPT || 'tb.cgi';
my $tb_url = "/$tb_script/$enc_page";
$tb_url =~ s!^//!/!;
$tb_url = $wikiurl . $tb_url;
$tb_url = &Util::escapeHTML($tb_url);
return $url if $deny_tb;
return wantarray ? ($url, $tb_url) : $url;
}
#===============================================================================
# 受取った文字列が汎用属性であるかチェクする。
#===============================================================================
sub check_attribute {
my $ref_check_attrib = shift;
my @check_attrib = ref($ref_check_attrib) ? @$ref_check_attrib : @{[$ref_check_attrib]};
my @allow_attrib = ref($_[0]) ? @{$_[0]} : @_;
push(@allow_attrib, @{&Util::html_generic_attribute});
my $allow_attrib_regex = join('|', @allow_attrib);
my @res;
map {s/^($allow_attrib_regex)/ push(@res, lc($1)) /ie;} @check_attrib;
return wantarray ? @res : $res[$#res];
}
sub html_generic_attribute {
return [
'id',
'class',
'style',
'title',
'dir',
'lang',
'xml:lang',
];
}
#===============================================================================
# スカラー値の参照のリストを受け取り、それらの実体である文字列をエスケープします。
#===============================================================================
sub escapeXML {
foreach my $refs (@_) {
$$refs =~ s/"/"/g;
$$refs =~ s/'/'/g;
$$refs =~ s/</</g;
$$refs =~ s/>/>/g;
$$refs =~ s/&/&/g;
$$refs =~ s/&/&/g;
$$refs =~ s/</</g;
$$refs =~ s/>/>/g;
$$refs =~ s/\"/"/g;
$$refs =~ s/\'/'/g;
}
}
sub delete_tag2 {
my $str = shift;
my $ignore_br = shift;
# <br />タグを保存する
$str =~ s/(<|<)\s*[b|B][r|R].*?(>|>)/\0/g unless $ignore_br;
## via: http://www.din.or.jp/~ohzaki/perl.htm
# HTMLタグの正規表現 $tag_regex
my $tag_regex_ = q{[^"'<>]*(?:"[^"]*"[^"'<>]*|'[^']*'[^"'<>]*)*(?:>|(?=<)|$(?!\n))}; #'}}}}
my $comment_tag_regex = '<!(?:--[^-]*-(?:[^-]+-)*?-(?:[^>-]*(?:-[^>-]+)*?)??)*(?:>|$(?!\n)|--.*$)';
my $tag_regex = qq{$comment_tag_regex|<$tag_regex_};
my $text_regex = q{[^<]*};
# $str の中のタグを削除した $result を作る
my $result = '';
while ($str =~ /($text_regex)($tag_regex)?/gso) {
last if (defined $1 and $1 eq '' and defined $2 and $2 eq '');
$result .= $1;
my $tag_tmp = $2 || '';
if ($tag_tmp =~ m/^<(XMP|PLAINTEXT|SCRIPT)(?![0-9A-Za-z])/i) {
$str =~ /(.*?)(?:<\/$1(?![0-9A-Za-z])$tag_regex_|$)/gsi;
(my $text_tmp = $1) =~ s/</</g;
$text_tmp =~ s/>/>/g;
$result .= $text_tmp;
}
}
$result =~ tr/\0/\n/ unless $ignore_br;
return $result;
}
sub trim_space {
foreach my $refs (@_) {
$$refs =~ tr/\x0D\x0A//;
$$refs =~ s/[\r\n]//g;
$$refs =~ s/[\f\t\a\b]//g;
$$refs =~ s/^\s+(.*?)\s+$/$1/;
$$refs =~ s/\s+/ /g;
}
}
#=============================================================================
# カテゴリを調べる
#=============================================================================
sub get_category_from_souce {
my $source = shift;
foreach my $line (split(/\n/,$$source)){
# コメントか整形済テキストの場合は飛ばす
next if($line =~ /^(\t| |\/\/)/);
# カテゴリにマッチしたらリスティング
while($line =~ /{{category\s+(.+?)}}/g){
return $1;
}
}
return undef;
}
sub get_category_from_page {
my $source = &Wiki::get_page($_[0]);
return get_category_from_souce(\$source);
}
#==============================================================================
# http日付(rfc1123)
#==============================================================================
# Qz
sub format_date_http {
my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[0]);
sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat')[$wday],
$mday,
( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' )[$mon],
$year+1900, $hour, $min, $sec );
}
#==============================================================================
# クッキー発行
#==============================================================================
# Qz
sub set_cookie {
my @arg = @_;
my %cook = %{$arg[0]};
my @cook;
while (my($n, $v) = each(%cook)) {
push @cook, "$n\t$v";
}
my $expires = Util::format_date_http(time + $arg[1] * 24 * 60 * 60);
$cook = join ",", @cook;
$cook =~ s/([^0-9A-Za-z_ ])/'%'.unpack('H2',$1)/ge;
$cook =~ s/\s/+/g;
print "Set-Cookie: WIKI=$cook; expires=$expires\n";
}
#==============================================================================
# クッキー取得
#==============================================================================
# Qz
sub get_cookie {
my($n, $v, %dummy, $cookie, %cook);
$cookie = $ENV{'HTTP_COOKIE'};
if (defined $cookie) {
$cookie =~ tr/+/ /;
$cookie =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
foreach (split(/;/, $cookie)) {
($n, $v) = split(/=/, $_);
$n =~ s/ //g;
$dummy{$n} = $v;
}
foreach (split(/,/, $dummy{WIKI})) {
($n, $v) = split(/\t/, $_);
$cook{$n} = $v;
}
}
return %cook;
}
1;
関数説明
About
メンテナ
- いしだなおと
コミットメント、取り込み
- Qzさん作のプラグイン集から
- BugTrack-plugin/112 【FSWikiLite】プラグイン集(include,footernote,bbs,comment) から、3つの関数を拝借しました。
ライセンス
GNU GPL
（要検討）
フィードバック
※修正は「編集」メニューからしてください。
いしだなおと it＠isnot.jp