package Header; #use warnings; use CGI::Carp qw(fatalsToBrowser warningsToBrowser); # エラー発生時にエラー内容を表示させる warningsToBrowser(1); # Copyright(C) Grandmaster since 2009. # 本モジュールで異常判定がちゃんとできるかどうかは判定していません。 # 本モジュールを使ったことによる不利益(誤った変換、プログラムの停止、パソコンの停止、暴走など) # が発生しても、責任は負えませんので、ご了承ください。 # 上記を踏まえて頂ければ、本スクリプトの転用・改編は自由に行ってもらってもかまいません。 # ver 0.1 2010/12/21 test01.pl でスタート # 1.0 12/26 header-lib.pl として、ヘッダ・printに絞って内容を決定 # 2.0 12/28 Header.pm に変更し、文字コードは EUC-JP+LFとした # 2.1 2011/ 1/ 9 コメント修正 # 2.2 1/11 strict でエラーが出ないように修正 # 2.3 1/13 readParse を追加 # 2.4 1/15 readParse に文字コード変換を追加 # 2.4.1 1/29 dallar2atを追加 # 2.4.2 1/30 read_data registを追加 # 2.4.3 2/ 3 todayYMD todayDate を追加 # 2.4.4 4/ 3 description を軽く修正 # 2.4.5 8/31 コメント修正 # 2.4.6 9/27 getProgramName を追加 # 2.4.7 12/ 2 drawNumber、lastSubstituteを追加 # 2.5 2012/ 3/11 maxData(),minData()を追加 # 2.5.1 3/13 makePなどを追加 # 2.5.2 11/21 いろいろ見直し # 2.6 2013/ 5/22 画像を変更 # 3.0 use warnings;をコメントアウト # Grandmaster use strict; use CGI; # readParse()で必要 use Jcode; # 漢字コード変換で必要 use Time::Local; # 時間関数で必要 use Calender; # 日付計算のため呼び出す師匠自作のモジュール use Exporter; # mainモジュールから直接関数名で呼出しができるようにする our @ISA = ("Exporter"); # strict では "Ecporter"と""が必要だった # 関数名、変数名、配列名などを、 半角スペース で区切って列挙する our @EXPORT = qw(header error errorback footer footer2nd printstart longprint printbr longpre readParse readParseOld changeKanji dallar2at read_data regist todayYMD todayDate preClass textareaClass getProgramName drawNumber lastSubstitute statSizeDate showHashTable makeHashTable makeHash2Table maxData minData splitYn makeOL makeUL makeP makePre makeTableTd separateComma makeTag printTag makeLink say) ; our $URL = "http://tancro.e-central.tv/grandmaster"; #------------------ # HTML head要素に、CSSや漢字コードを定義する #------------------ sub header { my ($titleH1,$title,$cssFile,$contents,$contents2,$kanjiCode) = @_; my $myName=moduleName(); # mainモジュールのファイル名を取り込む my $linkCss = ""; my $shortcutIcon=""; my $Favicon=""; if ( -e "../style.css") { $linkCss = ''; } else { $linkCss = ''; $shortcutIcon = ''; $Favicon = ''; } if ( $kanjiCode eq "" ) { $kanjiCode = "EUC-JP"; # 設定がなければ Perl はEUC-JPで記述することにする } # $title = "Perlで遊ぼう(".$title.")"; print "Content-type: text/html\n\n"; print <<"_HTML_"; $linkCss $title $shortcutIcon $Favicon

師匠の散歩

きままにPerlでも

$title

_HTML_ if ($contents ne "") { # 説明文があれば表示 print "

$contents"; } if ($contents2 ne "") { # 説明文2があれば表示 print " / $contents2"; } print "/ $myName

\n"; } # ----------------------------------------------------------- # 自分自身のファイル名、フォルダ1、フォルダ2、戻り先、リンク先などを設置 # ----------------------------------------------------------- sub footer { my ($author,$returnFile,$filename1,$filename2) = @_; my $myName=moduleName(); # mainモジュールのファイル名を取り込む print "
\n"; print "$myName\n"; if ($filename1){ print " <> $filename1 \n";} if ($filename2){print " <> $filename2 \n"; } if( -e "../style.css" ) { print " // Topに戻る\n"; print " // indexに戻る\n"; } else { print " // Topへ"; print " // 一覧へ\n"; } my $lastup = dateLastSaved(); # mainファイルの最終更新日付を求める my $thisYear = (localtime(time))[5] + 1900 ; print "
Copyright(C) since 2010 Grandmaster $lastup
\n"; print "\n"; print ""; } # ----------------------------------------------------------- # footer()に変数を入れなくても使えるようにした # ----------------------------------------------------------- sub footer2nd { my ($readFile,$writeFile) = @_; my $myName=moduleName(); # mainモジュールのファイル名を取り込む print "
\n"; print "$myName\n"; if( -e "../style.css" ) { print " // Topに戻る\n"; print " // indexに戻る\n"; } else { print " // Topへ"; print " // 一覧へ\n"; } my $lastup = dateLastSaved(); # mainファイルの最終更新日付を求める my $thisYear = (localtime(time))[5] + 1900 ; print "
Copyright(C) 2009-$thisYear Grandmaster $lastup
\n"; print "\n"; print ""; } sub moduleName{ my $myName=$0; # mainモジュールのファイル名を、特殊変数から取り込む if ($myName =~ /\\/ ) { # Windowsの場合、C\My Document\perl\myName.cgi を解決する $myName =~ m/.*\\([^\\]+)$/; $myName = $1; } return $myName; } #--------------- # エラー表示 #--------------- sub error{ my $programname=$0; if ($programname =~ /\\/ ) { $programname =~ m/.*\\([^\\]+)$/; $programname = $1; } print <<"_HTML_";
エラー発生、スクリプトを停止させました
$programname
  • $_[0]
  • $_[1]
_HTML_ exit; } #--------------- # エラー表示だけして戻る #--------------- sub errorback{ my $programname=$0; if ($programname =~ /\\/ ) { $programname =~ m/.*\\([^\\]+)$/; $programname = $1; } print <<"_HTML_";
エラー発生、メッセージを表示してリターンします
$programname
  • $_[0]
  • $_[1]
_HTML_ } # ----------------------------------------------------------- # html書き出しの初期化 header()を作成してからは使用ゼロになった # ----------------------------------------------------------- sub printstart { print "Content-type: text/html\n\n"; } # ----------------------------------------------------------- # print <<"etc"; 文章 etc の形式を省略する # ----------------------------------------------------------- sub longprint { my $msg = shift; print $msg; } # ----------------------------------------------------------- # 改行が欲しいときにタグを書くのを省略する ほぼ使用ゼロ # ----------------------------------------------------------- sub printbr { print "
\n"; } # ----------------------------------------------------------- # $0の最終更新日を求める ほぼ使用ゼロ # $0 = main のファイルになるためモジュールにおいてもOKになる # ----------------------------------------------------------- sub dateLastSaved{ my ($min,$sec,$hour,$day,$month,$year) = localtime((stat $0)[9]); $year += 1900; $month++; return " Last up : ".sprintf ("%0.4d/%0.2d/%0.2d",$year,$month,$day); } # ----------------------------------------------------------- # ''で区切ったデータを表示する ほぼ使用ゼロ # ----------------------------------------------------------- sub longpre { my ($data,$css) = @_; if ($css eq "") { $css=""; } else { $css=" class=".$css; } print "".$data.""; } # -------------------------------------------------------------- # フォームデータを読み出し、ハッシュに格納して戻す # use CGI; 必須 # -------------------------------------------------------------- sub readParse { my %hash = (); # グローバル変数は用いない $CGI::POST_MAX = 1024 * 100; # 最大読み込みするデータ量、new CGI();より前に置く my $form = new CGI(); # インスタンス化 my @query = $form->param(); # FORMデータを取り出す if ( @query eq "") { # データが無ければ、連想配列を空白のまま戻す return %hash; } my ($key,$contents,$data); foreach (@query){ # パラメータ全てについて $key = jcode($_)->h2z->euc; # keyの文字コードをEUC-JPに変換 $data = $form->param("$_"); # contentsを取り出す $contents = jcode($data)->h2z->euc; # contentsの文字コードをEUC-JPに変換 $hash{"$key"} = $contents # hash に格納 } return %hash; # hashを戻す } # ----------------------------------------------------------- # 初期版:文字コード変換なし(参考に残す) # ----------------------------------------------------------- sub readParseOld { my %hash; # グローバル変数は用いない $CGI::POST_MAX = 1024 * 100; # new CGI();より前に置く、最大読み込みするデータ量を規定する my $form = new CGI(); # インスタンス化 my @query = $form->param(); # CGIからパラメータを取り出す foreach (@query){ # パラメータ全てについて $hash{"$_"} = $form->param("$_"); # hash へ格納 } return %hash; # 受け手側で、my または our ハッシュで受け取る } # ----------------------------------------------------------- # 指定した漢字コードに変換して返す 最近は利用少ない # 入力が配列でなければ、一回行われるだけで、区別は不要 # ----------------------------------------------------------- sub changeKanji { my ($kanji,@bun) = @_; # 漢字コード+データ配列(変数) foreach (@bun) { if(($kanji eq "sjis") || ($kanji =~ /hift/) ) { # Shift_JISと間違う場合を許容 $_ = jcode($_)->h2z->sjis; } elsif ($kanji =~ /utf/ ){ # utf8 と「8」を付け忘れるのを許容 $_ = jcode($_)->h2z->utf8; } elsif ($kanji =~ /euc/){ # euc-jpと不要な文字列が追加されるのを許容 $_ = jcode($_)->h2z->euc; } elsif ($kanji eq "jis"){ # そのまま $_ = jcode($_)->h2z->jis; } else { error("変換できる漢字コードが指定されていません","changeKanji stopped"); } } return @bun; } #---------------------------------------- # dallar2at関数 # ヒアドキュメントを改行で分けて配列に変換 # 末尾の対応 2020/1/23 #---------------------------------------- sub dallar2at { my $dallar=shift; # 引数を取り出す $dallar = $dallar."\n"; # 末尾に改行を付けてあげる my @files=(); # 格納配列の宣言 if ($dallar =~ /\n/){ # \nがない場合に対応 while ($dallar =~ /\n/) { # 改行コードがあれば push (@files, $`."\n"); # 一番左のマッチした前半を配列に入れる $dallar = $'; # マッチした後半を対象にする } } else { push(@files,$dallar."\n"); # 行末に改行コードをつけて配列に格納 } return @files; } #----------------------------------------------------------------------# #ファイルロード #----------------------------------------------------------------------# sub read_data { my $fileName = shift; my @gpxdata; open(IN,"$fileName") || error("ファイル読み出しできません $fileName"); @gpxdata = ; close(IN); return @gpxdata ; } #----------------------------------------------------------------------# # 配列の書き込み #----------------------------------------------------------------------# sub regist { my($fileName, @data) = @_ ; open (OUT,">$fileName") || error('書き込みエラー',$fileName); print OUT (@data); close (OUT); } # ----------------------------------------------------------- # 今日の日付を 2010-01-23 の形式で返す 最近は利用せず # ----------------------------------------------------------- sub todayYMD { my @datetime = getLocalTime(time); my $year = 1900 + $datetime[5]; my $month = $datetime[4] + 1; my $day = $datetime[3]; return sprintf("%04d-%02d-%02d",$year,$month,$day); } sub todayDate { my @datetime = getLocalTime(time); my $ji = $datetime[2]; my $fun = $datetime[1]; my $byo = $datetime[0]; return sprintf("%02d:%02d:%02d",$ji,$fun,$byo); } # ----------------------------------------------------------- # css定義したPRE要素で配列を表示する # ----------------------------------------------------------- sub preClass { my ($css,@bun) = @_; print "
\n";
  foreach(@bun) {
   $_ =~ s//>/g ;
   print;
  }
  print "
\n"; } # ----------------------------------------------------------- # css定義したTEXTAREA要素で、配列を表示する 最近は利用せず # ----------------------------------------------------------- sub textareaClass { my ($css,@bun) = @_; print ""; } # ------------------------------ # メインルーチンのプログラム名を取得 # Windowsで走らせたときにも対応 # ------------------------------ sub getProgramName{ my $programname=$0; # Windowsの場合、プログラム名がC\から始まるので、最後の\以降を取り出す if ($programname =~ /\\/ ) { # エスケープ文字がある場合 $programname =~ m/.*\\([^\\]+)$/; # 最後のエスケープ文字以降を取り出す $programname = $1; # } return $programname; } # ----------------------------------------------------------- # 4桁の数字を表示する # ----------------------------------------------------------- sub drawNumber { my $n=shift; printf "%04d : ", $n; # 行番号表示 } # ----------------------------------------------------------- # 最後の文字列を置換する # $word 変換対象文字列 # $before 置換前文字列 # $after 置換後文字列 # 文字列にエスケープ文字が含まれた場合。。。 # ----------------------------------------------------------- sub lastSubstitute{ my ($word,$before,$after) = @_; $word =~ s/(^.*)$before(.*$)/$1$after$2/; return $word; } # ----------------------------------------------------------- # ファイルのサイズと日付を求める # -> ファイル名 # <- ファイルサイズ(バイト)、作成した日付のエポック秒 # ----------------------------------------------------------- sub statSizeDate { my $fileName=shift(@_); my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = stat($fileName); return ($size,$mtime); } # ------------------------------------ # ハッシュ を表示する # ------------------------------------ sub showHashTable { my %hash = @_; # ハッシュのままデータを受け取る my $n = keys( %hash ); # ハッシュの要素数を取り込む my @key = keys( %hash ); # ハッシュのキーを取得する # my @value = values( %hash ); # ハッシュのデータを配列に取り込む @key = sort (@key) ; print <<"_HTML_"; _HTML_ for (my $i=0 ; $i<$n ; $i++){ print "\n"; } print "
no.keycontent
$i$key[$i]$hash{$key[$i]}
\n"; } #-------------------- #-------------------- sub makeHashTable { my %hash = @_; # ハッシュのままデータを受け取る my $n = keys( %hash ); # ハッシュの要素数を取り込む my @key = keys( %hash ); # ハッシュのキーを取得する # my @value = values( %hash ); # ハッシュのデータを配列に取り込む @key = sort (@key) ; my $data = <<_HTML_; _HTML_ for (my $i=0 ; $i<$n ; $i++){ $data.= "\n"; } $data .= "
no.keycontent
$i$key[$i]$hash{$key[$i]}
\n"; return $data; } # ------------------------------------ # ハッシュ を表にして配列で返す # ------------------------------------ sub makeHash2Table{ my %hash = @_; my $n = keys( %hash ); # ハッシュの要素数を取り込む my @key = keys( %hash ); # ハッシュのキーを取得する # my @value = values( %hash ); # ハッシュのデータを配列に取り込む @key = sort (@key) ; my $line = <<"_HTML_"; _HTML_ my @hashArray = dallar2at($line); for (my $i=0 ; $i<$n ; $i++){ push(@hashArray,"\n"); } push (@hashArray,"
no.keycontent
$i$key[$i]$hash{$key[$i]}
\n"); return @hashArray; } # ------------------------------------ # -- モジュールを利用(Perl5.8以降) --# # ------------------------------------ sub maxData { return( (sort {$b <=> $a} @_)[0] ); } # ------------------------------------ # -- モジュールを利用(Perl5.8以降) --# # ------------------------------------ sub minData { return( (sort {$a <=> $b} @_)[0] ); } # ------------------------------------ # split \n # ------------------------------------ sub splitYn{ my $data = shift; my @data = split(/\n/,$data); return @data; } # ------------------------------------ # OL要素 # ------------------------------------ sub makeOL{ my @line = "
    "; foreach (@_) { chomp; if ($_ ne ""){ push(@line, "
  1. ".$_."\n"); } } push(@line,"
\n"); return @line; } # ------------------------------------ # UL要素 # ------------------------------------ sub makeUL{ my @line = "\n"); return @line; } # ------------------------------------ # P要素 # ------------------------------------ sub makeP{ my @line = "
"; foreach (@_) { if ($_){ push(@line,$_); } } push(@line,"
\n"); return @line; } # ------------------------------------ # Pre要素 # ------------------------------------ sub makePre{ my @line = "
";
  foreach (@_) {
    chomp;
    if($_){
      push(@line, $_);
    }
  }
  push(@line,"
\n"); return @line; } # ------------------------------------ # table td で表を作成する # ------------------------------------ sub makeTableTd { my @csv; push(@csv,"\n"); my @data; foreach(@_){ print ""; @data = split(/\,/); foreach(@data){ push(@csv,""); } push(@csv,"\n"); } push(@csv,"
".$_."
\n"); return @csv; } # ------------------------------------ # 小数にも対応でき1行で記述できる # ------------------------------------ sub separateComma { $_=shift; s/\G((?:^[-+])?\d{1,3})(?=(?:\d\d\d)+(?!\d))/$1,/g; return $_; } # ------------------------------------ # < と > を < > に変更する # ------------------------------------ sub makeTag{ foreach(@_){ s//>/g; } return @_; } # -------------------------- # <>を%lt;%gt;に変換しPRE要素で表示する # -------------------------- sub printTag{ print "
";
  foreach(@_){
    $_ =~ s/\?//g;
    $_ =~ s//\>\;/g;
    print $_;
  }
  print "
"; } # ------------------------------------ # http/ftpで始まるとリンクを、@があるとメールを作成する # ------------------------------------ sub makeLink{ $_ = shift; $_ =~ s/([^=^\"]|^)((http|ftp):[!#-9\?=A-~]+)/$1$2<\/a>/g; $_ =~ s/([\w\-\_]+\@[\w\-\_\.]+)/$1<\/a>/g; return($_); } # ------------------------------------ # use 5.010; を使わなくても say 関数を使えるようにする # ------------------------------------ sub say{ print @_; print "\n"; } # #---------------------------------------------------------------------------------------- # モジュールには最後の1が必須、1;を消さないこと! 1; # return true