知らないことがあってもへっちゃらさ

Date::Calc とりあえずこれだけは

Date::Calc は Perl に標準で付いてきて、日付関係の計算をあれこれしてくれる非常に便利なモジュールなんですが・・・、よく使う割にはいつも使い方を忘れるので、その “よく使うところ” をまとめてみました。

use Date::Calc qw(:all);

# 現在の日付を取得（年月日）
($year, $month, $day) = Today();

# 現在の日付と時刻を取得（年月日時分秒）
($year, $month, $day, $hour, $min, $sec) = Today_and_Now();

# 指定した日付の曜日を数字で取得（戻り値：月曜日が1で日曜日が7）
$DoW = Day_of_Week($year,$month,$day);

# 日付の足し算引き算（第４引数は加減算する日数）
($Dyear, $Dmonth, $Dday) = Add_Delta_Days($year, $month, $day, $Dd);
($Dyear, $Dmonth, $Dday) = Add_Delta_Days($year, $month, $day, -1); # １日前の日付
($Dyear, $Dmonth, $Dday) = Add_Delta_Days($year, $month, $day, 2);  # ２日後の日付

# 指定した月の最終日を取得
$lastday = Days_in_Month($year, $month);

# 指定した日付が実在するかを確認（戻り値：真なら1、偽なら0）
$check = check_date($year, $month, $day);
 

参照リンク
　・Date::Calc - search.cpan.org

Perl で切り下げを計算する関数を書いてみた

Perl で数値を切り上げる関数（RoundDown）を書いてみました。正の数を切り下げる場合は int を使えばいいのですが、負の数字を int で処理すると切り上げになってしまうんですよね。

そんなわけで使い所としては、正の数を処理するのか負の数を処理するのかわからない場合に、確実に切り下げるため。というところでしょうか。

使い方は引数を１つ指定して

 
my $res = RoundDown($numeric);
 

のような感じで、ソースは以下の通りです。

sub RoundDown {
  my $numeric = shift;
  
  if(!defined($numeric) || $numeric =~ /[^0-9\.-]/){
    return undef;
  }
  
  my $int = int($numeric);
  if($numeric < 0){
    if($numeric < $int){
      $int -= 1;
    }
  }
  
  return $int;
}
 

数値以外の引数を渡すと、Undef（未定義値）を返します。

Enjoy!

関連エントリー
　・Perl で切り上げを計算する関数を書いてみた
　・四捨五入を計算するアルゴリズム（Perl によるサンプルプログラムあり）

Perl で変数が未定義か判定する関数を書いてみた

前のエントリーでは、Perl で変数が定義されているかの判定方法について書いたのですが、実際にプログラミングをしていると、「未定義かどうかを判定して、未定義だったら初期化する」 場合が殆どです。

というわけで、変数が未定義（undef）かどうか判定して、未定義なら “真” を返す関数を書いてみました。使い方は次のような感じで。

if(IsUndef($scalar)){
  # $scalar が未定義だった場合の処理
}
 

ソースは以下の通りです。

sub IsUndef {
  my $scalar = shift;
  my $val    = 1;
  
  if(defined $scalar){
    $val = 0;
  }
  
  return $val;
}
 

Enjoy!

関連エントリー
　・Perl で変数が定義されているか判定しよう

Perl で変数が定義されているか判定しよう

Perl で変数の中身の真偽を判定する場合、変数を if に放り込んでやるのが簡単です。

if($scalar){
  # 結果が真の場合の処理
}
 

この場合、結果が “偽” になるのは $scalar の値が 0（ゼロ）か空の文字列（""）か未定義（undef）の場合です。

いやいや、0 や空の文字列はいいんだよ、未定義の場合だけ拾いたいんだ。という場合には、defined を使います。使い方は以下の通り

if(defined $scalar){
  # $scalar が未定義でなかった場合の処理
}
 

データベースから取ったデータを扱っていると、戻り値が NULL だった場合 Perl では undef として扱われるので、そのチェックでよくお世話になります。

関連エントリー
　・Perl で変数が未定義か判定する関数を書いてみた

Perl で切り上げを計算する関数を書いてみた

Perl で数値を切り上げる関数（RoundUp）を書いてみました。引数は１つで、次のように使います。

 
my $res = RoundUp($numeric);
 

ソースは以下の通りです。

sub RoundUp {
  my $numeric = shift;
  
  if(!defined($numeric) || $numeric =~ /[^0-9\.-]/){
    return undef;
  }
  
  my $int = int($numeric);
  if($numeric > 0){
    if($numeric > $int){
      $int += 1;
    }
  }
  return $int;
}
 

数値以外の引数を渡すと、Undef（未定義値）を返します。

Enjoy!

関連エントリー
　・Perl で切り下げを計算する関数を書いてみた
　・四捨五入を計算するアルゴリズム（Perl によるサンプルプログラムあり）

Windows上の ActivePerl に Jcodeモジュールをインストールしよう

Perl で書かれた古いプログラムを新しい環境で動かそうしたんですが、「Jcode モジュールが無いよ」 と言われて動きませんでした・・・orz

ちなみに、新しい環境に入っているのは ActivePerl 5.10 です。ちなみにその古いコードが書かれたのは、ActivePerl 5.2 の時代だったりします。このプログラム、どんだけ長生きねん（苦笑）。

もちろん、Encode モジュールを使うようにプログラムを書き直すという手もありますが、ちょ～っと面倒なのでここは Jcode モジュールをインストールする方向で何とかしたいところです。

具体的な方法は、まず The CPAN Search Site - search.cpan.org の Jcodeのページから、モジュールの入ったファイル（Jcode-*.**.tar.gz）をダウンロードしてきます。

次にをダウンロードしてきたファイルを解凍して、出てきた Jcode.pm と Jcode フォルダを、ライブラリパスの通っているフォルダ（例： C:Perl\lib\ ）にコピーしてやればＯＫです。

なお、この方法は にしし ふぁくとりー の Jcode.pmをWindows上のPerlにインストールする というページを参考にさせていただいました。感謝。

参照リンク
　・Jcode.pmをWindows上のPerlにインストールする - Sakura scope
　・Dan Kogai / Jcode-2.07 - search.cpan.org
　・Jcode.pm - jcode.pl の後継、Encode.pm への架け橋

Perlの連想配列から任意の要素を削除したい

Perl の連想配列（ハッシュ）から、任意の要素（キー）を削除するには、delete を使います。

#!/usr/bin/perl

use strict;
use warnings;

my %hash = ('key1' => 'red', 'key2' => 'blue', 'key3' => 'green');

delete $hash{'key2'}; # 要素を削除

for my $key (sort keys %hash){
  print "$key => $hash{$key}\n";
}
 

サンプルソースを test.pl というファイル名で保存して実行すると・・・

C:\tmp>test.pl
key1 => red
key3 => green
 

'key2' の要素が削除されているのが確認できます。

PerlでJANコードのチェックデジットを計算しよう（8桁版）

前回は 13桁の JANコードのチェックデジットを計算する関数を書いてみたのですが、「そう言えば、８桁の JAN もあったよなぁ」 というわけで、7桁の数字を渡すと、チェックデジットを計算して 8桁の JANコードにしてを返す Perl の関数（サブルーチン）も書いたので公開します。

sub CheckDigitCalc_JAN8 {
  my $seed = shift;
  
  chomp($seed);
  $seed =~ s/^\s+//;
  $seed =~ s/\s+$//;
  
  return undef if (length($seed) < 7 || substr($seed, 0, 7) =~ /[^0-9]/);
  
  my $strD = 0;
  my $strC = 0;
  my $strB = 0;
  my $strA = 0;
  my $str9 = 0;
  my $str8 = substr($seed, 0, 1);
  my $str7 = substr($seed, 1, 1);
  my $str6 = substr($seed, 2, 1);
  my $str5 = substr($seed, 3, 1);
  my $str4 = substr($seed, 4, 1);
  my $str3 = substr($seed, 5, 1);
  my $str2 = substr($seed, 6, 1);
  
  my $sumENN = $str2+$str4+$str6+$str8+$strA+$strC;
  my $sumONN = $str3+$str5+$str7+$str9+$strB+$strD;
  
  my $digit = 10 - substr(($sumENN * 3) + $sumONN, -1);
  $digit = 0 if $digit > 9;
  
  return(substr($seed, 0, 7).$digit);
}

Enjoy!

１３桁用はこちら
　・PerlでJANコードのチェックデジットを計算しよう（13桁版）

参考リンク
　・チェックデジット計算方式 |JANコード登録│ 一般財団法人流通システム開発センター

PerlでJANコードのチェックデジットを計算しよう（13桁版）

12桁の数字を渡すと、チェックデジットを計算して 13桁の JANコードにしてを返す Perl の関数（サブルーチン）を書いたので公開します。

sub CheckDigitCalc_JAN13 {
  my $seed = shift;
  
  chomp($seed);
  $seed =~ s/^\s+//;
  $seed =~ s/\s+$//;
  
  return undef if (length($seed) < 12 || substr($seed, 0, 12) =~ /[^0-9]/);
  
  my $strD = substr($seed,  0, 1);
  my $strC = substr($seed,  1, 1);
  my $strB = substr($seed,  2, 1);
  my $strA = substr($seed,  3, 1);
  my $str9 = substr($seed,  4, 1);
  my $str8 = substr($seed,  5, 1);
  my $str7 = substr($seed,  6, 1);
  my $str6 = substr($seed,  7, 1);
  my $str5 = substr($seed,  8, 1);
  my $str4 = substr($seed,  9, 1);
  my $str3 = substr($seed, 10, 1);
  my $str2 = substr($seed, 11, 1);
  
  my $sumENN = $str2+$str4+$str6+$str8+$strA+$strC;
  my $sumONN = $str3+$str5+$str7+$str9+$strB+$strD;
  
  my $digit = 10 - substr(($sumENN * 3) + $sumONN, -1);
  $digit = 0 if $digit > 9;
  
  return(substr($seed, 0, 12).$digit);
}

Enjoy!

８桁用はこちら
　・PerlでJANコードのチェックデジットを計算しよう（8桁版）

参考リンク
　・【流通工房】8桁JAN・短縮JAN・13桁JAN・JANコード体系・チェックデジット－要件定義
　・チェックデジット計算方式 |JANコード登録│ 一般財団法人流通システム開発センター

PerlでCGIモジュール（CGI.pm）を使ってcookieを操作する覚え書き

久々に CGI なプログラムを書こうとしたら、すっかり忘れていたので。

まずは cookie を設定する場合。

#!/usr/bin/perl

use strict;
use warnings;

use CGI;

my $q = new CGI;

# cookie を作成
my $cookie = $q->cookie(-name    => "hoge", # cookie名
                        -value   => "fuga", # 値
                        -expires => "+30d"  # 有効期限
                       );  

# cookie を HTTPヘッダにセットして発行
print $q->header(-type    => 'text/html', 
                 -charset => 'UTF-8',     
                 -cookie  => $cookie    
                );

# 以下略・・・

有効期限については、整数と時間の単位の組み合わせで指定します。使える時間の単位は、s（秒）, m（分）, h（時間）, d（日）, M（月）, y（年） が使えます。有効期限を指定しなかった場合は、ブラウザを閉じるまで有効な cookie が発行されます。また整数部分にマイナスの値を指定した場合、cookie は削除されます。

複数の cookie を一度にセットしたい場合は、配列に放り込んでからそのリファレンスを渡せばＯＫです。

# 複数のcookieを用意して・・・
my $cookie1 = $q->cookie(-name    => "hoge", 
                         -value   => "hogehoge", 
                         -expires => "+30d" 
                        );  

my $cookie2 = $q->cookie(-name    => "fuga", 
                         -value   => "fugafuga", 
                         -expires => "+1h"  
                        );  

# 配列に入れる場合は
my @cookies = ($cookie1, $cookie2);
print $q->header(-type    => 'text/html', 
                 -charset => 'UTF-8',     
                 -cookie  => \@cookies    
                );

# 無名配列を使う場合は
print $q->header(-type    => 'text/html', 
                 -charset => 'UTF-8',     
                 -cookie  => [$cookie1, $cookie2]    
                );

cookie 作成時のパラメータとしては、他に -dommain （取得可能なドメインの範囲の指定）や -path （取得可能なパスの指定）、-secure （プロトコルによる利用の制限）なんかもありますが、たぶん必要になる事は無いと思うので今回は割愛します（おぃ！）。

最後に、cookie を読み出す場合はこんな感じで。

#!/usr/bin/perl

use strict;
use warnings;

use CGI;

my $q = new CGI;
my $cookie_hoge = $q->cookie('hoge');

# 以下略・・・