DBIC_TRACE=1のときに発行されるsqlにどこで発行されたクエリか追記する

package DBIx::Class::Storage::Statistics::Caller;
use strict;
use warnings;

use base qw/ DBIx::Class::Storage::Statistics /;

sub query_start {
  my ($self, $string, @bind) = @_;
  
  my $caller_sub_name = $self->_get_non_dbic_caller;
  my $message = "[$caller_sub_name] $string: ".join(', ', @bind)."\n";

  if(defined($self->callback)) {
    $string =~ m/^(\w+)/;
    $self->callback->($1, $message);
    return;
  }

  $self->print($message);
}

sub _get_non_dbic_caller {
    my ($self) = @_;
    
    my $get_sub_name = sub {
         for my $n ( 0..20 ) {
             my ($package, $filename, $line, $subroutine, $hasargs,
                 $wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($n);
             return $subroutine if $subroutine =~ s{^AppName::}{};
         };
         return '';
    };

    return $get_sub_name->();
}

1;

使いたいときに

$schema->storage->debugobj( DBIx::Class::Storage::Statistics::Caller->new );

する。

callerをとってくる部分はもっとうまくかけるにおいがぷんぷんする。

あと、上のやつとは全然関係ないけど、最近Arkアプリの起動は

perl boot_app_server_fcgi.pl >> ~/tmp/app/fcgi.log 2>&1  >> /dev/stdin  2>&1 | grep SELECT  >> ~/tmp/app/fcgi-select.log

みたいに起動して、

M-x tail-log-file ~/tmp/app/fcgi.log してる。

してる。
zshとかきちんと理解してないので勘で書いて、あ、動いた。みたいな感じ。

Emacsでlogを見るようにすると、anything-c-moccur とか使えて便利な事がおおい。
あと、sqlとかそのまま実行できて、それもたのしい。

tail-log-fileの定義は以下のような感じ

(defun tail-log-file (file)
  (interactive "f")
  (let* ((log-file (expand-file-name file))
         (buffer-name (concat "*" log-file  "*")))
    (with-current-buffer (get-buffer-create buffer-name)
      (set-buffer buffer-name)
      (setq auto-window-vscroll t)
      (fundamental-mode)
      (start-process "tail"
                     buffer-name
                     "tail"
                     "-f"
                     log-file)
      )
    (switch-to-buffer buffer-name)))

rails.elを参考にしました。

今日は、海の家でタイ料理を食べながらおビールを飲みました。
ですが、気温が高かったからか、僕のビールがすぐに蒸発してしまう不思議な現象に見舞われたため、沢山ビールを注文することになってしまいました。
不思議でしたが、楽しいお酒が沢山飲めて本当に幸せでした。しあわせ、しあわせ。

SQL扱うのに便利な関数とか、プレースホルダーを埋める関数とか

Arkのログ、DBIC_TRACE=1 の時に出るやつをごニョゴニョしたいと思って。いろいろやってみた。

SELECT * FROM user me WHERE ( ( me.id = ? AND deleted = ? ) ): '4', '0'

を選択して、
M-x sql-fill-placeholders
すると、kill-ring に

SELECT * FROM user me WHERE ( ( me.id = '4' AND deleted = '0' ) );

が入っている状態になる。埋め込まれている。そのまま実行できるはず。
以下は、応用。

SELECT * FROM user me WHERE ( ( me.id = ? AND deleted = ? ) ): '4', '0'
を選択して、
C-u M-x sql-fill-placeholders-and-send
で EXPLAIN をつけてSQLバッファで実行。
以外と便利。
落ち着いたらゆっくり書きたい。

(defun sql-fill-params (q los)
  (assert (stringp q))
  (assert (and (listp los)
               (stringp (car-safe los))))
  (with-temp-buffer
    (insert q)
    (goto-char (point-min))
    (dolist (s los)
      (re-search-forward (rx "?"))
      (replace-match s nil t nil))
    (buffer-substring-no-properties (point-min) (point-max))))

(defun sql-fill-placeholders-parse-param-str (param-str)
  (let ((params (split-string param-str "," t)))
    (mapcar (lambda (s) (replace-regexp-in-string
                         "[ \t\n]*$" "" (replace-regexp-in-string "^[ \t\n]*" "" s)))
            params)))

(defun sql-fill-placeholders-from-string (str)
  (when (string-match (rx (* space) (group (* (not (any ":")))) ":" (* space) (group (* print)) eol) str)
    (let ((query (match-string-no-properties 1 str))
          (param-str (match-string-no-properties 2 str)))
      (cond
       ;; no placeholder
       ((not (string-match (rx "?") query))
        query)
       (t
        (let ((params (sql-fill-placeholders-parse-param-str param-str)))
          (sql-fill-params query params)))))))

(defun sql-fill-placeholders-make-executable-sql (start end)
  (let ((sql (sql-fill-placeholders-from-string
              (buffer-substring-no-properties start end))))
    (concat sql ";")))

(defun sql-fill-placeholders (start end)
  (interactive "r")
  (let ((sql (sql-fill-placeholders-make-executable-sql start end)))
    (kill-new sql)))

(defun sql-fill-placeholders-and-send (start end)
  (interactive "r")
  (assert (buffer-live-p (get-buffer sql-buffer)))
  (let* ((sql (sql-fill-placeholders-make-executable-sql start end))
         (sql (if current-prefix-arg (concat "EXPLAIN " sql) sql)))
    (with-current-buffer sql-buffer
      (sql-send-string sql))))

Emacsに選択してる範囲を読んでもらう

say コマンドがインストールされている場合のお話です。

(defun say-on-region (&optional start end)
  (interactive "r")
  (unless (executable-find "say")
    (error  "say command is not installed!!"))
  (shell-command-on-region start end "say"))

読んで欲しいところをリージョン選択しながら M-x say-on-region で話し始めます。

endless eight onichan Daisuki dogura magura

もうお好きなのをどうぞ!!
自分の中のビールの部分がお届けしました。おやすみなさい。

List::Util::first の返り値でハマったのでメモ

use Test::Base qw(no_plan);
use Test::Exception;
use List::Util qw(first);
use Perl6::Say;

my $arr = [
    { id => 1, name => 'aaa' },
    { id => 2, name => 'bbb' },
];
my $is_ccc = sub { $_->{name} eq 'ccc' };

lives_ok( sub {
    map { say $_->name } first { $is_ccc->($_) } @$arr;
}, 'first' );
# => died: Can't call method "name" on an undefined value at -e line 20.

lives_ok( sub {
    map { say $_->name } grep { $is_ccc->($_) } @$arr;
}, 'grep' );
# => ok.

原因は、
first { $is_ccc->($_) } @$arr;
が
(undef)
を返すからだと思われる。

podにはこうかかれている。

This function could be implemented using C<reduce> like this
$foo = reduce { defined($a) ? $a : wanted($b) ? $b : undef } undef, @list

ちょっとずつ前にすすんでる気がする!!。

デフォルト設定の semantic が semantic.cache を各ディレクトリに作ってアレなときにすべき設定

semanticdb-default-save-directory にディレクトリを設定してあげると、そこにキャッシュを作るようになります。

(setq semanticdb-default-save-directory
      "~/.emacs.d/")

また、 semanticdb-default-file-name を変更するとキャッシュファイルの名前を変更する事もできます。

これらの変数は、cedet/semantic/semanticdb-file.el で定義されています。

M-x custom-group semanticdb

でもOKです!!

Lingua::JA::Regular::Unicode をつかって全角カナを半角カナに変換する

全角と半角が混在していて、アレだったのですが、以下のコードで一発でした。
"、。" 等の文字も変換されて問題ない状況でした。

use Lingua::JA::Regular::Unicode;

sub z2h { katakana_z2h($_[0]) }

$_->update({ name => z2h($_->name), description => z2h($_->description) })
    for ( $schema->resultset('Spec')->all );

もし管理画面とにらめっこしながら手作業で直していたとしたら、電脳コイルを見る時間が取れませんでした。
最高です。素晴らしすぎます。tokuhiromさんに感謝!!
tokuhirom++
(incf tokuhirom)

DBIC勉強しつつ、SQL書き方ドリル読んだメモ -2-

p175〜 相関副問い合わせ。

SELECT 
    p.ProductName,
    s1.Quantity,
    s1.saledate
FROM
    Sales AS s1
        JOIN
    Products AS p
    ON p.ProductID = s1.ProductID
WHERE
    s1.Quantity > (
        SELECT AVG(s2.Quantity)
        FROM
            Sales AS s2
        WHERE s2.ProductID = s1.ProductID
    )
;

my $avg = $schema->resultset('Sales')->get_column('Quantity')->func('AVG');
$schema->resultset('Sales')->search(
    {
        'me.Quantity' => {'>' => $avg},
    },
    {
        select => [qw/ Products.productname me.saledate /],
        as => [qw/ name saledate/],
        join => [qw/ Products /],
        order_by => \'Products.productid ASC, me.saledate DESC',
    }
);