シリコンバレー在住エンジニアの、Perl、PHP、AJAX、Drupal、Java の小枝集です。( 7,833,031 since 2005.02.20 )
Perl で、メールサーバに送られてきたメールを処理する
Procmail を利用すればサーバに送られてきたメールが標準入力から Perl スクリプトに渡すことができる。ここでは Procmail の詳細は割愛するが、以下は標準入力に入っているメールを処理する関数。
使用するクラス
Procmail を利用すればサーバに送られてきたメールが標準入力から Perl スクリプトに渡すことができる。ここでは Procmail の詳細は割愛するが、以下は標準入力に入っているメールを処理する関数。
使用するクラス
use MIME::Parser; use MIME::Base64; use Mail::Address;
use MIME::Parser;
use MIME::Base64;
use Mail::Address;
use Unicode::Japanese;
my ($mail) = &parse;
print "From: " . $mail->{sender} . "\n";
print "To: " . $mail->{recipient} . "\n";
print "Subject: " . $mail->{subject} . "\n";
sub parse {
my ($mail);
# Parser Setting
my $parser = new MIME::Parser;
$parser->output_to_core(1); # Keeps body analyzed internally
$parser->tmp_recycling (1); # Recycles the temporary stuff
my $entity = $parser->parse(\*STDIN) or die "Parse Error in __FILE__\n";
# Headers
$mail->{sender } = $entity->head->get('from' );
$mail->{subject } = $entity->head->get('subject');
$mail->{recipient} = $entity->head->get('to' );
$mail->{recipient} =~ s/\n//g;
# From
@addrs = Mail::Address->parse($mail->{sender});
foreach $addr (@addrs) {
$mail->{sender} = $addr->address if $addr->address; # USE CAUTION, for the multiple address
}
# Subject
my $subject = $mail->{subject};
$lws = '(?:(?:\x0D\x0A|\x0D|\x0A)?[ \t])+';
$ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?=';
$subject =~ s/\n//g;
$subject =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio;
$subject =~ s/$lws/ /go;
$subject =~ s/$ew_regex/decode_base64($1)/egio;
$subject = Unicode::Japanese->new($subject, 'auto')->sjis_imode;
$mail->{subject} = $subject;
# Get MIME
($mail->{body}, $mail->{filename}, $mail->{mimetype}, $mail->{object}) = &getEntities($entity);
$mail->{body } = Unicode::Japanese->new($mail->{body}, 'auto')->sjis_imode;
$mail->{body } =~ s/[ \n\r]+$//g; # Delete the white spaces in the end of the line
$mail->{subject} =~ s/[ \n\r]+$//g; # Delete the white spaces in the end of the line
return $mail;
}
sub getEntities {
my $entity = shift;
my $body, $filename, $mimetype, $object;
# BODY
my @parts = $entity->parts;
if (@parts) { # multipart...
my $i;
foreach $i (0 .. $#parts) { # dump each part...
&getEntities($parts[$i]);
}
} else { # single part...
# Get MIME type, and display accordingly...
my ($type, $subtype) = split('/', $entity->head->mime_type);
my $bodyhandle = $entity->bodyhandle;
if ($type =~ /^(text|message)$/) { # text
$body .= $bodyhandle->as_string;
} else { # binary
$filename= $entity->head->recommended_filename;
$mimetype = $entity->head->mime_type;
$object = $bodyhandle->as_string;
binmode($object);
# if we want to store it as BASE64, you can continue the processs here
}
}
return ($body, $filename, $mimetype, $object);
}
1;use MIME::Parser; use MIME::Base64; use Mail::Address;
use MIME::Parser;
use MIME::Base64;
use Mail::Address;
use Unicode::Japanese;
my ($mail) = &parse;
print "From: " . $mail->{sender} . "\n";
print "To: " . $mail->{recipient} . "\n";
print "Subject: " . $mail->{subject} . "\n";
sub parse {
my ($mail);
# Parser Setting
my $parser = new MIME::Parser;
$parser->output_to_core(1); # Keeps body analyzed internally
$parser->tmp_recycling (1); # Recycles the temporary stuff
my $entity = $parser->parse(\*STDIN) or die "Parse Error in __FILE__\n";
# Headers
$mail->{sender } = $entity->head->get('from' );
$mail->{subject } = $entity->head->get('subject');
$mail->{recipient} = $entity->head->get('to' );
$mail->{recipient} =~ s/\n//g;
# From
@addrs = Mail::Address->parse($mail->{sender});
foreach $addr (@addrs) {
$mail->{sender} = $addr->address if $addr->address; # USE CAUTION, for the multiple address
}
# Subject
my $subject = $mail->{subject};
$lws = '(?:(?:\x0D\x0A|\x0D|\x0A)?[ \t])+';
$ew_regex = '=\?ISO-2022-JP\?B\?([A-Za-z0-9+/]+=*)\?=';
$subject =~ s/\n//g;
$subject =~ s/($ew_regex)$lws(?=$ew_regex)/$1/gio;
$subject =~ s/$lws/ /go;
$subject =~ s/$ew_regex/decode_base64($1)/egio;
$subject = Unicode::Japanese->new($subject, 'auto')->sjis_imode;
$mail->{subject} = $subject;
# Get MIME
($mail->{body}, $mail->{filename}, $mail->{mimetype}, $mail->{object}) = &getEntities($entity);
$mail->{body } = Unicode::Japanese->new($mail->{body}, 'auto')->sjis_imode;
$mail->{body } =~ s/[ \n\r]+$//g; # Delete the white spaces in the end of the line
$mail->{subject} =~ s/[ \n\r]+$//g; # Delete the white spaces in the end of the line
return $mail;
}
sub getEntities {
my $entity = shift;
my $body, $filename, $mimetype, $object;
# BODY
my @parts = $entity->parts;
if (@parts) { # multipart...
my $i;
foreach $i (0 .. $#parts) { # dump each part...
&getEntities($parts[$i]);
}
} else { # single part...
# Get MIME type, and display accordingly...
my ($type, $subtype) = split('/', $entity->head->mime_type);
my $bodyhandle = $entity->bodyhandle;
if ($type =~ /^(text|message)$/) { # text
$body .= $bodyhandle->as_string;
} else { # binary
$filename= $entity->head->recommended_filename;
$mimetype = $entity->head->mime_type;
$object = $bodyhandle->as_string;
binmode($object);
# if we want to store it as BASE64, you can continue the processs here
}
}
return ($body, $filename, $mimetype, $object);
}
1;
Perl で、RSS で配信されたエントリーの日付を処理する
HTTP::Date クラスを使うと RSS で配信されたエントリーの日付 (dc:date) を変換してくれる。この場合、RSS のソースによって米国から日本のニュースにアクセスした場合などは、時差 (タイムゾーン) を考慮する必要があるため注意する。
使用するクラス
HTTP::Date クラスを使うと RSS で配信されたエントリーの日付 (dc:date) を変換してくれる。この場合、RSS のソースによって米国から日本のニュースにアクセスした場合などは、時差 (タイムゾーン) を考慮する必要があるため注意する。
使用するクラス
use HTTP::Date;
#!/usr/bin/perl
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Date;
# 初期化
my $html;
my $timezone = 'JST';
my $url = 'https://www.yoursite.com/index.rdf';
my $rss = new XML::RSS;
my $proxy = new LWP::UserAgent; # UseAgent の作成
my $req = new HTTP::Request(GET=>$url);
my $res = $proxy->request($req); # $url にアクセスする
my $xml = $res->content; # コンテンツ (この場合は RSS/XML) を取得
# RSS を解析
eval {
$rss->parse($xml);
};
if($@) {
# $rss->parse が失敗したとき
}
# @{$rss->{items}} に、RSS のすべてのエントリー (item) が入る
foreach my $item ( @{$rss->{items}} ) {
my $date = HTTP::Date::str2time($item->{dc}->{date}, $timezone);
$html .= qq|<a href=$item->{link}>$item->{title}</a><br>\n|; # タイトルをリンクつきで出力
$html .= qq|$description<br>| if $item->{description}; # 概要 (description) を出力
$html .= qq|[<a href=$item->{link}>続きを読む</a>]<hr size=1>\n|;
}
print $html;
1;
参考リンク
use HTTP::Date;
#!/usr/bin/perl
use LWP::UserAgent;
use HTTP::Request;
use HTTP::Date;
# 初期化
my $html;
my $timezone = 'JST';
my $url = 'https://www.yoursite.com/index.rdf';
my $rss = new XML::RSS;
my $proxy = new LWP::UserAgent; # UseAgent の作成
my $req = new HTTP::Request(GET=>$url);
my $res = $proxy->request($req); # $url にアクセスする
my $xml = $res->content; # コンテンツ (この場合は RSS/XML) を取得
# RSS を解析
eval {
$rss->parse($xml);
};
if($@) {
# $rss->parse が失敗したとき
}
# @{$rss->{items}} に、RSS のすべてのエントリー (item) が入る
foreach my $item ( @{$rss->{items}} ) {
my $date = HTTP::Date::str2time($item->{dc}->{date}, $timezone);
$html .= qq|<a href=$item->{link}>$item->{title}</a><br>\n|; # タイトルをリンクつきで出力
$html .= qq|$description<br>| if $item->{description}; # 概要 (description) を出力
$html .= qq|[<a href=$item->{link}>続きを読む</a>]<hr size=1>\n|;
}
print $html;
1;
参考リンク
Perl で、HTML 文書中にあるリンクを置換する
以下は、HTML 文書中にあるリンクを任意の文字列に置換するスクリプトであるが、他のタグでもいろいろと応用が利くと思われる。
以下は、HTML 文書中にあるリンクを任意の文字列に置換するスクリプトであるが、他のタグでもいろいろと応用が利くと思われる。
#!/usr/bin/perl
use LWP::UserAgent;
use HTTP::Status;
use HTTP::Response;
our $URL = 'https://perltips.twinkle.cc/'; # アクセスする URL
my $proxy = new LWP::UserAgent;
$proxy->agent('your own created browser name here');
$proxy->timeout(60);
my $response = $proxy->request(HTTP::Request->new('GET' => $URL));
my $content = $response->content;
my %tags = (
'img' => 'src',
'a' => 'href',
'link' => 'href',
'td' => 'background',
'form' => 'action'
);
my $data = $content;
skip_others: while($data =~ s/<([^>]*)>// && $i++ < 10000) { # 無限ループに陥るのを防ぐ
my $in_brackets = $1;
foreach $key (keys %tags) {
if($in_brackets =~ /^\s*$key\s+/i) {
if($in_brackets =~ /\s+$tags{$key}\s*=\s*["']([^"']*)["']/i
|| $in_brackets =~ /\s+$tags{$key}\s*=\s*([^\s]+)/i ) {
my $link = $1;
$link =~ s/[\n\r]//g;
$link =~ s/\./\\./g;
$link =~ s/\?/\\?/g;
$content =~
s/\s*=\s*["']*$link["']*/=<<<ここに置換文字列を書く>>>/
if $link !~ m/mailto:/i
&& $link !~ m/javascript/i;
next skip_others;
}
}
}
}
1;#!/usr/bin/perl
use LWP::UserAgent;
use HTTP::Status;
use HTTP::Response;
our $URL = 'https://perltips.twinkle.cc/'; # アクセスする URL
my $proxy = new LWP::UserAgent;
$proxy->agent('your own created browser name here');
$proxy->timeout(60);
my $response = $proxy->request(HTTP::Request->new('GET' => $URL));
my $content = $response->content;
my %tags = (
'img' => 'src',
'a' => 'href',
'link' => 'href',
'td' => 'background',
'form' => 'action'
);
my $data = $content;
skip_others: while($data =~ s/<([^>]*)>// && $i++ < 10000) { # 無限ループに陥るのを防ぐ
my $in_brackets = $1;
foreach $key (keys %tags) {
if($in_brackets =~ /^\s*$key\s+/i) {
if($in_brackets =~ /\s+$tags{$key}\s*=\s*["']([^"']*)["']/i
|| $in_brackets =~ /\s+$tags{$key}\s*=\s*([^\s]+)/i ) {
my $link = $1;
$link =~ s/[\n\r]//g;
$link =~ s/\./\\./g;
$link =~ s/\?/\\?/g;
$content =~
s/\s*=\s*["']*$link["']*/=<<<ここに置換文字列を書く>>>/
if $link !~ m/mailto:/i
&& $link !~ m/javascript/i;
next skip_others;
}
}
}
}
1;
Perl で、URL を抽出したい。
URI::Find で URL を抜き出して、さらに正規表現を使って正確に取得している。
使用するモジュール
URI::Find で URL を抜き出して、さらに正規表現を使って正確に取得している。
使用するモジュール
use URI::Find
#/usr/bin/perl
my $text = 'https://twinkle.cc/i/';
my $url = getURL($text);
sub getURL {
use URI::Find;
my $text = shift;
my $finder = URI::Find->new(
sub {
my($uri, $orig_uri) = @_;
return $uri;
});
$finder->find(¥$text);
my $http_URL_regex =
q{¥b(?:https?|shttp)://(?:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])} .
q{?¥.)*[a-zA-Z](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?¥.?|[0-9]+¥.[0-9]+¥.[0-9} .
q{]+¥.[0-9]+)(?::[0-9]*)?(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-F} .
q{a-f][0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0} .
q{-9A-Fa-f])*)*(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-} .
q{Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])} .
q{*)*)*(?:¥?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f} .
q{])*)?)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-} .
q{f])*)?(?![-_.!~*'()a-zA-Z0-9;/?:@&=+$,#])}; #}}
return $text =~ /($http_URL_regex)/ ? $1 : '';
}
1;use URI::Find
#/usr/bin/perl
my $text = 'https://twinkle.cc/i/';
my $url = getURL($text);
sub getURL {
use URI::Find;
my $text = shift;
my $finder = URI::Find->new(
sub {
my($uri, $orig_uri) = @_;
return $uri;
});
$finder->find(¥$text);
my $http_URL_regex =
q{¥b(?:https?|shttp)://(?:(?:[a-zA-Z0-9](?:[-a-zA-Z0-9]*[a-zA-Z0-9])} .
q{?¥.)*[a-zA-Z](?:[-a-zA-Z0-9]*[a-zA-Z0-9])?¥.?|[0-9]+¥.[0-9]+¥.[0-9} .
q{]+¥.[0-9]+)(?::[0-9]*)?(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-F} .
q{a-f][0-9A-Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0} .
q{-9A-Fa-f])*)*(?:/(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-} .
q{Fa-f])*(?:;(?:[-_.!~*'()a-zA-Z0-9:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])} .
q{*)*)*(?:¥?(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f} .
q{])*)?)?(?:#(?:[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-} .
q{f])*)?(?![-_.!~*'()a-zA-Z0-9;/?:@&=+$,#])}; #}}
return $text =~ /($http_URL_regex)/ ? $1 : '';
}
1;