Selenium から Headless Chrome on Ubuntu 20.04 のサンプル (Perl の Selenium::Remote::Driver)

IDとパスワードでログインし、ログイン後の画面のスクリーンショットを撮るPerlのサンプルソース。 

Selenium::Remote::Driver は、ユーザhogehogeがcpanmでインストールした前提。

----- ここから -----
#!/usr/bin/env perl

use strict;
use warnings;

use lib '/home/hogehoge/perl5/lib/perl5';
use Selenium::Chrome;

my $logon_url = 'https://www.hogehoge.com/';
my $user_id = 'foobar';
my $password  = 'password';
my $png_path = 'sample.png';

my $driver = Selenium::Chrome->new(
  extra_capabilities => {
    'goog:chromeOptions' => {
      args => ['headless', 'disable-gpu', 'window-size=1920,1080', 'no-sandbox' ]
    }
  }
);

$driver->get($logon_url);

$driver->find_element_by_name('user_id')->send_keys($user_id);
sleep 1;

$driver->find_element_by_name('password')->send_keys($password);
sleep 1;

$driver->find_element("//input[\@type='submit']")->click();
sleep 5;

$driver->capture_screenshot("$png_path");

$driver->quit();

exit;

----- ここまで -----

以上。

Ubuntu 20.04 でPerl用モジュール Selenium::Remote::Driver をインストール

まず、Google Chrome と  Selenium 用chromedriver、IPA日本語フォントをインストール。
つぎに、cpanm を使えるようにするインストール。
そして、Selenium::Remote::Driver のdebパッケージはないので、cpanmでインストール。

最後に .bashrc にパスを追記。

$ sudo sh -c 'echo "deb http://dl.google.com/linux/chrome/deb/ stable main" >> /etc/apt/sources.list.d/google-chrome.list'
$ sudo apt -y install wget gnupg
$ sudo wget -q -O - https://dl-ssl.google.com/linux/linux_signing_key.pub | sudo apt-key add -
$ sudo apt update
$ sudo apt -y install google-chrome-stable chromium-chromedriver fonts-ipafont
$ fc-cache -fv
$
$ sudo apt -y install gcc make cpanminus
$ cpanm Selenium::Remote::Driver
$
$ vi .bashrc
　（以下を追記）
export PERL_CPANM_OPT="--local-lib=~/perl5"
export PATH=$HOME/perl5/bin:$PATH;
export PERL5LIB=$HOME/perl5/lib/perl5:$PERL5LIB;
$
$ source .bashrc

以上。

テキストファイルの文字コード、改行コードを変換

カレントディレクトリ以下のファイルの文字コードをシフトJISからUTF-8に、改行コードをCR+LFからLFに変換する。
また、ファイル内の文字列Windows-31JまたはShift_JISをUTF-8に置換する。

$ find . -type f -print0 | xargs -0 perl -MEncode -i.bak -pe 'Encode::from_to($_,"cp932","utf-8"); s/\r\n/\n/g; s/(Windows-31J|Shift_JIS)/UTF-8/g;'
$ find . -name "*.bak" -print0 | xargs -0 rm -f

初Mojolicious::Liteアプリサンプル

OS: CentOS 7.3
Perl: 5.24.0
Mojolicious: 7.14
DBI: 1.636
DBIx::Connector: 0.56
DBD::ODBC: 1.56

----- ここから -----
#!/usr/bin/env perl

use strict;
use warnings;

use Mojolicious::Lite;
use DBIx::Connector;

my $db_host   = 'db1';
my $dsn       = 'dbi:ODBC:' . $db_host;
my $db_name   = 'sample';
my $db_user   = 'db_user_name';
my $db_passwd = 'db_user_passwd';

# DB接続
my $conn = DBIx::Connector->new($dsn, $db_user, $db_passwd) or die $!;
helper db => sub { return $conn->dbh; };

# サイトID取得
helper get_site_id => sub {
    my $self = shift;
    my $stmt = "SELECT [site_id] FROM $db_name.$db_user.site";
    my $sth = $self->db->prepare($stmt) or die $self->db->errstr;
    $sth->{LongTruncOk}=1;
    $sth->{LongReadLen}=2000000;
    $sth->execute or die $self->db->errstr;
    my @site_ids = ();
    while (my @row = $sth->fetchrow_array) {
        push @site_ids, $row[0];
    }
    $sth->finish;
    return \@site_ids;
};

# サイトプロパティ取得
helper get_site_properties => sub {
    my $self = shift;
    $site_id = $_[0];
   
    if ($site_id) {
        my $stmt = "SELECT [property_key], [property_value], [description] FROM $db_name.$db_user.site_properties WHERE site_id = ?";
        my $sth = $self->db->prepare($stmt) or die $self->db->errstr;
        $sth->{LongTruncOk}=1;
        $sth->{LongReadLen}=2000000;
        $sth->execute($site_id) or die $self->db->errstr;
        my @properties = ();
        while (my @row = $sth->fetchrow_array) {
            push @properties, {'property_key' => $row[0], 'property_value' => $row[1], 'description' => $row[2]};
        }
        $sth->finish;
        return \@properties;
    }
};

# ベースルートの設定
any '/' => sub {
    my $self = shift;
    my $site_ids = $self->get_site_id();
    $self->stash( site_ids => $site_ids );
    $self->render('index');
};

# サイトプロパティ取得用ルートの設定
any '/site_properties' => sub {
    my $self = shift;
    my $site_id = $self->param('site_id');
    my $properties = $self->get_site_properties($site_id);
    $self->render(json => $properties);
};

app->start;

__DATA__

@@ index.html.ep

<!DOCTYPE html>
<html>
<head>
<meta charset="UTF-8" />
<meta http-equiv="X-UA-Compatible" content="IE=edge" />
<meta name="robots" content="noindex,nofollow" />
<meta http-equiv="Pragma" content="no-cache" />
<meta http-equiv="Cache-Control" content="no-cache" />
<meta http-equiv="Expires" content="0" />
<meta name="viewport" content="width=device-width, initial-scale=1, maximum-scale=1, user-scalable=no" />
<title>e2R Utilities</title>
<%= stylesheet '//www.foobar.com/common/css/bootstrap.min.css' %>
<%= stylesheet '//www.foobar.com/common/css/bootstrap-theme.min.css' %>
</head>
<body>
<div class="container">

<div class="row">
<div class="col-md-12">
<h3>ユーティリティ</h3>
</div>
</div>
<br />

<div class="row">
<div class="col-md-12">

<div class="well well-sm">
<form class="form-horizontal" role="form">
<div class="form-group">
<label for="site_id" class="col-sm-2 control-label">サイトID</label>
<div class="col-sm-6">
<select name="site_id" class="form-control">
<option value=""></option>
% foreach my $site_id (@$site_ids) {
<option value="<%= $site_id %>"><%= $site_id %></option>
% }
</select>
</div>
</div>
<div class="form-group">
<div class="col-sm-offset-2 col-sm-10">
<button type="button" id="site-property-btn" class="btn btn-primary">サイトプロパティ表示</button>
</div>
</div>
</form>
</div>

</div>
</div>
<br />

<div class="row">
<div class="col-md-12">
<div id="site-property-block">
<strong>サイトプロパティ</strong><br />
<table class="table table-bordered table-condensed">
<thead>
<tr>
<th>キー</th>
<th>値</th>
<th>説明</th>
</tr>
</thead>
<tbody id="site-property-list"></tbody>
</table>
</div>
</div>
</div>

</div>

<!-- template -->
<script type="text/template" id="property-list-template">
<tr>
<td>{{ property_key }}</td>
<td>{{ property_value }}</td>
<td>{{ description }}</td>
</tr>
</script>

<!-- javascript -->
%= javascript '//www.foobar.com/common/js/underscore.min.js';
%= javascript '//www.foobar.com/common/js/jquery.min.js';
%= javascript begin
(function() {

var root = this,
    _    = root._,
    $    = root.jQuery;

_.templateSettings = {
  interpolate: /\{\{(.+?)\}\}/g
};

$.ajaxSettings.contentType
  = 'application/x-www-form-urlencoded; charset=UTF-8';

var propertyListTemplate
  = _.template($("#property-list-template").html());

var escapeHtml = function(string) {
  if (typeof string !== 'string') {
    return string;
  }
  return string.replace(/[&'`"<>]/g, function(match) {
    return {
      '&': '&amp;',
      "'": '&#x27;',
      '`': '&#x60;',
      '"': '&quot;',
      '<': '&lt;',
      '>': '&gt;',
    }[match]
  });
};

$(function() {
  $('#site-property-block').hide();

  $('#site-property-btn').on('click', function() {
    $('#site-property-block').hide();

    if (!$('[name=site_id]').val()) {
      alert('サイトIDを選択してください。');
      return false;
    }

    $.ajax({
      url : '/app/site_properties',
      type : "POST",
      cache : false,
      dataType : "json",
      data : {
        "site_id" : $('[name=site_id]').val()
      }
    }).done(function(json) {
      var propertyListHtml = "";
      _.each(json, function(value) {
        propertyListHtml
          += propertyListTemplate({
               property_key : value["property_key"],
               property_value : escapeHtml(value["property_value"]),
               description : value["description"]
             });
      });
      $('#site-property-list').html(propertyListHtml);
      $('#site-property-block').show();
    }).fail(function() {
      alert("サイトプロパティの取得に失敗しました。");
      return false;
    });
  });
});

}).call(this);
% end

</body>
</html>

----- ここまで -----

Mojolicious::LiteのWebアプリを実行する環境設定

OSはCentOS 7.3。
アプリはStarman(PSGIサーバ)で実行する。

1. perlbrewのインストール

$ curl -kL http://install.perlbrew.pl | bash
$
$ echo "source ~/perl5/perlbrew/etc/bashrc" >> ~/.bashrc
$ source ~/.bashrc


2. 最新安定版Perlをperlbrewでインストール

$ perlbrew available
$
$ perlbrew install 5.24.0
$
$ perlbrew list
$ perlbrew switch 5.24.0
$ which perl
$ perl -v


3. cpanmのインストール

$ perlbrew install-cpanm


4. Mojoliciousのインストール

$ cpanm Mojolicious


5. DBD::ODBCとDBIx::Connectorのインストール

$ cpanm DBD::ODBC
$
$ cpanm DBIx::Connector


6. LWPのインストール

$ cpan Bundle::LWP


7. Starmanのインストール

$ cpanm Starman


8. Starman起動スクリプトサンプル

ログインIDがuser1、アプリのファイルmojo_test.plが/var/www/app/に配置されている前提。
/var/www/appにはuser1の実行・読み・書き権限があること。

----- ここから -----
#!/bin/sh

/usr/bin/su - user1 -c '/home/user1/perl5/perlbrew/perls/perl-5.24.0/bin/starman --port=3000 --daemonize --pid=/var/www/app/pid /var/www/app/mojo_test.pl'
----- ここまで -----

実行は

$ sudo starman_start.sh

のように行う。


9. Starman停止スクリプトサンプル

----- ここから -----
#!/bin/sh

/usr/bin/cat /var/www/app/pid | /usr/bin/xargs /usr/bin/kill
----- ここまで -----

実行は

$ sudo starman_stop.sh

のように行う。


10. Apacheのリバースプロキシの設定サンプル

$ sudo touch /etc/httpd/conf.d/starman.conf
$ sudo vi /etc/httpd/conf.d/starman.conf

----- ここから -----
ProxyRequests Off
ProxyPass /app http://localhost:3000
ProxyPassReverse /app http://localhost:3000
----- ここまで -----

LinuxからWindowsのSQL ServerにODBCで接続

以前にも似たような投稿をしているが、現時点で最新の環境であることと、以前とは少し設定が異なるので再度投稿。
LinuxはCentOS 7.3。

1. 各種RPMパッケージインストール

$ sudo yum install unixODBC*
$ sudo yum install freetds*
$ sudo yum install perl-DBI
$ sudo yum install perl-DBIx-Connector --enablerepo=epel
$ sudo yum install perl-DBD-ODBC


2. 設定ファイル編集、作成

$ sudo vi /etc/odbcinst.ini

末尾につぎの行を追加（odbc.iniで指定するドライバの設定）

----- ここから -----
[FreeTDS]
Description=FreeTDS ODBC
Driver=/usr/lib64/libtdsodbc.so
Setup=/usr/lib64/libtdsS.so
UsageCount=1
----- ここまで -----


$ sudo touch /etc/odbc.ini
$ sudo vi /etc/odbc.ini

つぎの行を追加（ホスト名でDSNの設定をする）

----- ここから -----
[db1]
Description=SQL Server 2012
Driver=FreeTDS
Trace=No
Server=192.168.10.1
Database=master
Port=1433
TDS_Version=8.0
ClientCharset=UTF-8
----- ここまで -----


3. 接続テスト

$ isql -v db1 db_user_name db_user_passwd


4. Perlサンプル

データベースsampleにカラム[group_id][user_id]を持つテーブルtest_tblがある前提。

----- ここから -----
#!/usr/bin/env perl

use strict;
use warnings;

use DBIx::Connector;

my $db_host   = 'db1';
my $dsn       = 'dbi:ODBC:' . $db_host;
my $db_name   = 'sample';
my $db_user   = 'db_user_name';
my $db_passwd = 'db_user_passwd';

my $test_user  = 'connect_test_user';
my $test_group = 'connect_test_group';

my $conn = DBIx::Connector->new($dsn, $db_user, $db_passwd) or die $!;
my $dbh  = $conn->dbh;

# test_tblに対象レコードがないことの確認（何も出力されない）
my $stmt = "SELECT * FROM $db_name.$db_user.test_tbl WHERE user_id = ?";
my $sth = $dbh->prepare($stmt) or die $dbh->errstr;
$sth->{LongTruncOk}=1;
$sth->{LongReadLen}=2000000;
$sth->execute($test_user) or die $dbh->errstr;
while (my @row = $sth->fetchrow_array) {
    print "select1:@row\n";
}
$sth->finish;

# test_tblにレコード作成
$stmt = "INSERT INTO $db_name.$db_user.test_tbl ([group_id], [user_id]) VALUES (?, ?)";
$sth = $dbh->prepare($stmt) or die $dbh->errstr;
my $rc = $sth->execute($test_group, $test_user) or die $dbh->errstr;
print "insert:$rc\n";
$sth->finish;

# test_tblに対象レコードがあることの確認
$stmt = "SELECT * FROM $db_name.$db_user.test_tbl WHERE user_id = ?";
$sth = $dbh->prepare($stmt) or die $dbh->errstr;
$sth->{LongTruncOk}=1;
$sth->{LongReadLen}=2000000;
$sth->execute($test_user) or die $dbh->errstr;
while (my @row = $sth->fetchrow_array) {
    print "select2:@row\n";
}
$sth->finish;

# test_tblからレコード削除
$stmt = "DELETE FROM $db_name.$db_user.test_tbl WHERE user_id = ?";
$sth = $dbh->prepare($stmt) or die $dbh->errstr;
$rc = $sth->execute($test_user) or die $dbh->errstr;
print "delete:$rc\n";
$sth->finish;

# test_tblに対象レコードがないことの確認（何も出力されない）
$stmt = "SELECT * FROM $db_name.$db_user.test_tbl WHERE user_id = ?";
$sth = $dbh->prepare($stmt) or die $dbh->errstr;
$sth->{LongTruncOk}=1;
$sth->{LongReadLen}=2000000;
$sth->execute($test_user) or die $dbh->errstr;
while (my @row = $sth->fetchrow_array) {
    print "select3:@row\n";
}
$sth->finish;

$conn->disconnect;

exit;
----- ここまで -----

CentOS7のDBD::Sybaseでレコードの更新に失敗する場合

insert文やdelete文を実行する前に

$dbh->do('SET ANSI_NULL_DFLT_ON, ANSI_NULLS, ANSI_PADDING, ANSI_WARNINGS, ARITHABORT, CONCAT_NULL_YIELDS_NULL, QUOTED_IDENTIFIER ON SET ANSI_NULL_DFLT_OFF, ARITHIGNORE, CURSOR_CLOSE_ON_COMMIT, IMPLICIT_TRANSACTIONS, NOCOUNT, XACT_ABORT , NUMERIC_ROUNDABORT OFF');

のようなクエリを実行する。
なお、確認したDBD::Sybaseのバージョンは、1.14。

メールのMIMEマルチパートの文字列をバイナリファイルに変換

メールの添付ファイル部分、例えば

--DC_BOUND_PRE_<1358488463.00267343d988> Content-Type: application/pdf; name="201301181454.pdf" Content-Transfer-Encoding: base64 Content-Disposition: attachment; filename="201301181454.pdf"

こんな行から

--DC_BOUND_PRE_<1358488463.00267343d988>--

こんな行までを仮にhoge.txtとして保存する。
WindowsならCygwinのコンソールで

perl -MMIME::Base64 -ne 'print decode_base64($_)' < hoge.txt > 201301181454.pdf

を実行する。

Perl: Linux -> SQLServer 画像ファイル格納

LinuxマシンからWindowsマシンのSQL ServerにはFreeTDSとunixODBCで接続できるようになっている前提。
データベース接続にはDBIとDBD::ODBCを使う。
DBD::Sybaseではプレースホルダーが使えない（？）のでDBD::ODBCしかないが、動きが怪しい。
レコードが存在する場合にupdateしようとしたがうまくいかない。
そこで、レコードが存在する場合deleteしてinsertすることにしたが、これも同一接続内ではうまくいかない。
仕方ないので、select、deleteで一旦切断し、insert用に再度接続するようにした。
以下サンプル。

#!/usr/bin/perl --

use MIME::Parser;
use DBI;
use warnings;
use strict;

my $dbname  = 'hoge';
my $user_id = "";
my $item_id = '10';

my $parser = new MIME::Parser;
$parser->output_to_core(1);
my $entity;

eval {
    local $SIG{ALRM} = sub { die "timeout" };
    alarm 10;
    $entity = $parser->parse(\*STDIN) or die;
    alarm 0;
};
alarm 0;
if ($@) { exit; }

my $from = $entity->head->get('from');
if ($from =~ /<(.+?\@.+?)>/) {
    $from = $1;
}

$user_id = _check_from($dbname, $from);

if ($user_id ne "" and $entity->is_multipart) {
    _save_attached_file($entity, $dbname, $user_id, $item_id);
}

exit;


sub _connect_db($$$$) {
    my $db_host   = shift;
    my $db_name   = shift;
    my $db_user   = shift;
    my $db_passwd = shift;

    my $data_source = "dbi:ODBC:"
                    . "server=" . $db_host . ";"
                    . "database=" . $db_name;
    my $dbh = DBI->connect($data_source, $db_user, $db_passwd)
                  or die $DBI::errstr;
    $dbh->{AutoCommit} = 0;
    $dbh->{RaiseError} = 1;

    return $dbh;
}

sub _check_from($$) {
    my $dbname  = shift;
    my $from    = shift;
    my $user_id = "";

    my $db_server = 'windows-db';
    my $db_name   = $dbname;
    my $db_user   = 'foo';
    my $db_passwd = 'bar';
    my $dbh
        = _connect_db($db_server, $db_name, $db_user, $db_passwd);
    my $stmt = "SELECT user_id"
             . " FROM users WITH (NOLOCK)"
             . " WHERE email = '$from'";
    my $sth = $dbh->prepare($stmt)
              or die $dbh->errstr;
    $sth->execute or die $dbh->errstr;
    while (my $row = $sth->fetchrow_arrayref) {
        ($user_id) = @$row;
    }
    $sth->finish;
    $dbh->disconnect;

    return $user_id;
}

sub _save_attached_file($$$$) {
    my $entity  = shift;
    my $dbname  = shift;
    my $user_id = shift;
    my $item_id = shift;

    my $parts_count = $entity->parts;
    for (my $i = 1; $i < $parts_count; $i++) {
        my $part_entity = $entity->parts($i) ?
                          $entity->parts($i) :
                          $entity->parts($i)->parts($i);
        my $content_type = $part_entity->head->mime_type;

        if ($content_type =~ /\/(html|plain|alternative)/) {
            next;
        }

        my $attachment = $part_entity->bodyhandle->as_string;
        my $filename   = $part_entity->head->recommended_filename;

        my $db_server = 'earth-db';
        my $db_name   = $dbname;
        my $db_user   = 'foo';
        my $db_passwd = 'bar';
        my $dbh
            = _connect_db($db_server, $db_name, $db_user, $db_passwd);
        my $stmt = "SELECT user_id FROM files WITH(NOLOCK)"
                 . " WHERE user_id = '$user_id'"
                 . " AND item_id = '$item_id'";
        my $sth = $dbh->prepare($stmt) or die $dbh->errstr;
        $sth->execute or die $dbh->errstr;
        my $result_user_id = "";
        while (my $row = $sth->fetchrow_arrayref) {
            ($result_user_id) = @$row;
        }
        $sth->finish;
        if ($result_user_id) {
            $stmt = "DELETE FROM files"
              . " WHERE user_id = '$user_id'"
              . " AND item_id = '$item_id'";
            $sth = $dbh->prepare($stmt) or die $dbh->errstr;
            eval {
                $sth->execute;
                $dbh->commit;
            };
            if ($@) {
                $dbh->rollback or die $dbh->errstr;
            }
        }
        $dbh->disconnect;

        $dbh = _connect_db($db_server, $db_name, $db_user, $db_passwd);
        $stmt = "INSERT INTO files ("
              . "user_id,"
              . "item_id,"
              . "content_type,"
              . "content,"
              . "filename,"
              . "date"
              . ") VALUES ("
              . "'$user_id',"
              . "'$item_id',"
              . "'$content_type',"
              . "?,"
              . "'$filename',"
              . "GETDATE()"
              . ")";
        $sth = $dbh->prepare($stmt) or die $dbh->errstr;
        $sth->bind_param( 1, $attachment, DBI::SQL_LONGVARBINARY );
        eval {
            $sth->execute;
            $dbh->commit;
        };
        if ($@) {
            $dbh->rollback or die $dbh->errstr;
        }
        $dbh->disconnect;

        last;
    }
}

__END__

cpanmのインストール

$ su
Password:
# cd /usr/bin
# curl -k -LO http://xrl.us/cpanm
# chmod 755 cpanm

ファイル内の文字列置換

カレントディレクトリ以下のファイル内のすべてのfooをbarに置換する。

$ find . -type f -print0 | xargs -0 perl -i.bak -pe 's/foo/bar/g'
$ find . -name "*.bak" -print0 | xargs -0 rm -f

も少しスマートにできんかね。

Subversionに新規ファイルをまとめてコミット

ディレクトリhogeの下で新たに追加したファイルをまとめてSubversionにコミットするサンプル。

$ svn st -u hoge | perl -nle 'if ($_ =~ /^\?\s+(.+)$/) {system("svn", "add", $1);}'
$ svn commit -m 'comment' hoge

以上

ファイルサイズの集計

カレントディレクトリ以下のファイルサイズの集計

$ find . -type f -printf "%s\n" | perl -nle 'BEGIN{my $sum = 0;} $sum += $_; END{print $sum;}'

awkで書くと

$ find . -type f -printf "%s\n" | awk '{ sum += $1; }; END { printf "%d\n", sum }'

Perlワンライナー：.batファイルでドラッグ&ドロップ

（2010/04/30perlfreak.vox.comより転載）

例えばPerlがインストールされているWindowsでつぎの行を hoge.bat というファイル名で保存する。

for %%a in (%*) do perl -i.bak -ne "if (/^hoge_/) {print;}" %%a

hoge.bat に処理対象のテキストファイルをドラッグ&ドロップすると、処理前の内容は元ファイルに「.bak」がついたファイルにバックアップされ、元のファイルは行の先頭が「hoge_」の行のみ出力されたものになる。

便利。

Perlワンライナー：ファイル名一括置換

（2010/02/24perlfreak.vox.comより転載）

同一ディレクトリ内のファイルの拡張子「.txt」を「.sql」に置換する例。

$ find . -name \*\.txt | perl -nle '$o=$_;s/\.txt$/\.sql/;rename $o,$_'

Perlワンライナー：ファイル内の特定文字列を置換

（2010/02/18perlfreak.vox.comより転載）

ファイル hoge.txt 内の特定文字列「foo」を「bar」に置換する場合

$ perl -i.bak -pe 's/foo/bar/' /tmp/hoge.txt

のように実行する。

-i.bak

オプションをつけると

hoge.txt.bak

というファイル名でバックアップが作成される。

Perlワンライナー：特定のアドレスを含むメールファイル

（2010/02/17perlfreak.vox.comより転載）

1メール1テキストファイルとして、メールファイルのあるディレクトリで

$ perl -0777 -ne 'split(/\n\n/, $_);print $ARGV . "\n" if ($_[0] =~ /\nFrom: (.+?)\n[A-Z]/ism and $1 =~ /hoge@foo\.bar/ism)' *

を実行すると、From: に hoge@foo.bar を含むファイル名が出力される。

perlコマンドのオプション「-0777」は、標準入力からのデータを改行で分割して読み込まない。

split(/\n\n/, $_);

は、標準入力から一気に読み込んだデータを空行で分割して無名配列に格納している。

その最初の要素がメールヘッダーになる。

正規表現は、From: が複数行になる場合を考慮。

Perlワンライナー：特定パターン文字列を含むファイル

（2010/02/12perlfreak.vox.comより転載）

同一ディレクトリ内のファイルで、特定パターンの文字列を含むファイルのファイル名をリストアップ。

$ perl -nle 'print $ARGV if (/正規表現/)' *

Perl 更新日付が指定日数より前のファイルを圧縮

（2008/08/05perlfreak.vox.comより転載）

OSの文字コードがUTF-8のLinux上のSambaサーバで管理しているディレクトリ下のファイルが対象。

===（compress_files.pl ここから）===
#!/usr/bin/perl -w

use File::Find::Rule;
use Encode qw/ from_to /;
#use warnings;
use strict;

# 処理対象ディレクトリパスと日数
my $dir_path = $ARGV[0] if $ARGV[0];
my $days = $ARGV[1] if $ARGV[1];
unless ( $days ) { exit; }

# 指定日数分前のtime
my $days_before = time - 60 * 60 * 24 * $days;

# ログ
my $log_path = '/tmp/compress_files.log';
system( "/usr/bin/touch", $log_path ) unless ( -e $log_path );

# 対象ファイルのパスを取得
my @files = File::Find::Rule->file()
->mtime( "<$days_before" ) ->in( $dir_path );

# 圧縮・削除処理
open OUT, ">> $log_path" or die "Cannot open file: $!\n";
foreach my $file_path ( @files ) {
if ( $file_path =~ /.+\.zip$/ ) { next; }

my $compress_path = $file_path . '.zip';

if ( $file_path =~ /^(.+)\/(.+?)$/ ) {
print $file_path . "\n";
print OUT $file_path . "\n";
my $dir_path = $1;
my $file_name = $2;
my $cp_file_name = $file_name;
from_to( $cp_file_name, 'utf8', 'cp932' );
my $compress_name = $file_name . '.zip';
chdir $dir_path;
system( "/bin/cp", "-p", $file_name, $cp_file_name );
my( $owner, $group, $date, $time ) = (split( / /, `/bin/ls -l $file_name`))[2,3,5,6];
my( $year, $mon, $day ) = split( /-/, $date );
my( $hour, $min ) = split( /:/, $time );
system( "/usr/bin/zip", $compress_name, $cp_file_name );
system( "/bin/chown", "$owner:$group", $compress_name );
system( "/usr/bin/touch", "-m", "-t", "$year$mon$day$hour$min", $compress_name );
system( "/bin/rm", $file_name, $cp_file_name );
}
}
close OUT;

exit;
===（compress_files.pl ここまで）===

Perl メールサーバマシン上で添付ファイル処理

（2008/06/17perlfreak.vox.comより転載）

メールの添付ファイルを指定ディレクトリに保存する。
指定ディレクトリ下にFrom:のアカウントでサブディレクトリを作り、その下にタイムスタンプ+拡張子でファイルを保存する。
引数は2つ。1つめは、ファイル保存ディレクトリのパス。2つめは、メールスプールファイルのディレクトリパス。
aliasesで

foo: |"/usr/local/bin/save_attached.pl /var/spool/attached"

のように指定し、メールを受信する度に処理する場合は、2つめの引数は指定しない。
一度受信したメールを処理する場合は、2つめの引数が必要。cronで定期実行する。
処理対象は、From:が@hoge.comのものに限定している。

===（save_attached.pl ここから）===
#!/usr/bin/perl -w

use MIME::Parser;
use MIME::Base64 qw/ decode_base64 /;
#use warnings;
use strict;

my $check_domain = 'hoge.com';
my $save_path = "";
my $spool_path = "";

# 引数チェック
if ( $ARGV[0] ) {
$save_path = $ARGV[0];
$save_path =~ s/\/$//;
unless ( -d $save_path ) {
exit;
}
}
else {
exit;
}

if ( $ARGV[1] ) {
$spool_path = $ARGV[1];
$spool_path =~ s/\/$//;
unless ( -d $spool_path ) {
exit;
}
}

my $parser = new MIME::Parser;
$parser->output_to_core( 1 );

if ( $spool_path ne "" ) {
opendir INDIR, $spool_path or die;
while ( my $spool_file = readdir INDIR ) {
chomp $spool_file;
my $spool_file_path = $spool_path . '/' . $spool_file;
if ( $spool_file =~ /^\d+\.$/ and -f $spool_file_path ) {
my $account = "";

# ファイルデータを取得
open IN, "< $spool_file_path" or next; my $buff = do { local $/; };
close IN;

my $entity = $parser->parse_data( $buff ) or next;
my $from = $entity->head->get( 'from' );
chomp $from;

# Fromアドレスのチェック
if ( $from =~ /([_\.a-zA-Z0-9]+)\@$check_domain/ ) {
$account = $1;
}
else {
system( "/bin/rm", $spool_file_path );
next;
}

# 添付ファイル保存
if ( $entity->is_multipart ) {
&_save_attached_file( $entity, $save_path, $account );
system( "/bin/rm", $spool_file_path );
}
}
}
closedir INDIR;
}
else {
my $account = "";
my $entity = $parser->parse( \*STDIN ) or die;
my $from = $entity->head->get( 'from' );
chomp $from;

# Fromアドレスのチェック
if ( $from =~ /([_\.a-zA-Z0-9]+)\@$check_domain/ ) {
$account = $1;
}
else {
exit;
}

# 添付ファイル保存
if ( $entity->is_multipart ) {
&_save_attached_file( $entity, $save_path, $account );
}
}

exit;

#=== FUNCTION ================================================================
# NAME: _save_attached_file
# PURPOSE: 添付ファイル保存
# DESCRIPTION: 添付ファイルを保存する。
# PARAMETERS: メールエンティティ、保存先ディレクトリパス、アカウント
# RETURNS: なし
#===============================================================================
sub _save_attached_file() {

my ( $entity, $save_path, $account ) = @_;
my $date = &_get_date();
my $parts_count = $entity->parts;
for ( my $i = 1; $i < $parts_count; $i++ ) { my $part_entity = $entity->parts( $i );
my $filename = $part_entity->head->recommended_filename;
if ($filename =~ /\=\?ISO\-2022\-JP\?B\?(.+)\?\=/ ) {
$filename = $1;
$filename = decode_base64( $filename );
}

my $ext = "";
if ( $filename =~ /\.(\w+?)$/ ) {
$ext = $1;
}

my $new_filename = $date . '_' . $i;
if ( $ext ne "" ) {
$new_filename = $new_filename . '.' . $ext;
}

my $save_dir = $save_path . '/' . $account;
unless ( -d $save_dir ) {
system( "/bin/mkdir", $save_dir );
}
my $save_file = $save_dir . '/' . $new_filename;

open OUT, "> $save_file" or next;
print OUT $part_entity->bodyhandle->as_string;
close OUT;
}

}

#=== FUNCTION ================================================================
# NAME: _get_date()
# PURPOSE: 年月日時分秒
# DESCRIPTION: 年月日時分秒を返す。
# PARAMETERS: なし
# RETURNS: YYYYMMDDHHMISS
#===============================================================================
sub _get_date() {

my( $sec, $min, $hour, $mday, $mon, $year ) = (localtime)[0,1,2,3,4,5];
$year+=1900;
$mon++;
$sec = sprintf("%02d", $sec);
$min = sprintf("%02d", $min);
$hour = sprintf("%02d", $hour);
$mday = sprintf("%02d", $mday);
$mon = sprintf("%02d", $mon);

return $year . $mon . $mday . $hour . $min . $sec;

}
===（save_attached.pl ここまで）===