(global-set-key "\M-t" 'elscreen-create)
(global-set-key "\M-T" 'elscreen-clone)
(global-set-key "\M-}" 'elscreen-next)
(global-set-key "\M-{" 'elscreen-previous)
(global-set-key [(C-tab)] 'elscreen-next)
(global-set-key [(C-S-tab)] 'elscreen-previous)

(global-set-key "\M-n" 'next-buffer)
(global-set-key "\M-p" 'previous-buffer)

% port search emacs
 
...
 
emacs-app @23.1 (aqua, editors)
The GNU Emacs text editor (Cocoa version)
 
...
 
% sudo port -d install emacs-app

(setq load-path (cons "/Users/iwata/site-lisp/" load-path))
(setq load-path (cons "/Users/iwata/site-lisp/apel-10.7/" load-path))
(setq load-path (cons "/Users/iwata/site-lisp/elscreen-1.4.6/" load-path))

% ls -1 ~/site-lisp
apel-10.7
apel-10.7.tar.gz
elscreen-1.4.6
elscreen-1.4.6.tar.gz
espresso.el
espresso.elc
jaspace.el
jaspace.elc
js2-20090723b.el
js2.elc
yaml-mode-0.0.4.el
yaml-mode-0.0.4x.el
yaml-mode-0.0.4x.elc
yaml-mode.elc
zencoding-mode.el
zencoding-mode.elc
%

(require 'zencoding-mode)
(add-hook 'xml-mode-hook 'zencoding-mode)
(add-hook 'sgml-mode-hook 'zencoding-mode)
(add-hook 'html-mode-hook 'zencoding-mode)
(define-key zencoding-mode-keymap (kbd "<C-return>") nil)
(define-key zencoding-mode-keymap (kbd "<S-return>") 'zencoding-expand-line)

(autoload #'espresso-mode "espresso" "Start espresso-mode" t)
(add-to-list 'auto-mode-alist '("\\.js$" . espresso-mode))
(add-to-list 'auto-mode-alist '("\\.json$" . espresso-mode))

(setq elscreen-prefix-key "\C-t")
(setq elscreen-display-tab t)
(load "elscreen")
(define-key elscreen-map "\C-t" 'elscreen-toggle)
(define-key elscreen-map "t" 'elscreen-toggle)

(set-face-attribute 'default nil
		    :family "Monaco"
		    ;:height 120)
		    :height 90)
(set-fontset-font "fontset-default"
		  'japanese-jisx0208
		  '("Osaka" . "iso10646-1"))
(set-fontset-font "fontset-default"
		  'katakana-jisx0201
		  '("Osaka" . "iso10646-1"))
(setq face-font-rescale-alist
      '((".*Monaco-bold.*" . 1.0)
	(".*Monaco-medium.*" . 1.0)
	(".*Osaka-bold.*" . 1.2)
	(".*Osaka-medium.*" . 1.2)
	("-cdac$" . 1.4)))

(setq ns-command-modifier (quote meta))
(setq ns-alternate-modifier (quote super))

(show-paren-mode 1)

(blink-cursor-mode t)

(set-scroll-bar-mode nil)

(setq auto-mode-alist (append '(("\\.psgi$" . cperl-mode)) auto-mode-alist))
(setq auto-mode-alist (append '(("\\.cgi$" . cperl-mode)) auto-mode-alist))
(setq auto-mode-alist (append '(("\\.pl$" . cperl-mode)) auto-mode-alist))
(setq auto-mode-alist (append '(("\\.t$" . cperl-mode)) auto-mode-alist))

(setq auto-mode-alist (append '(("\\.mt$" . xml-mode)) auto-mode-alist))

(setq load-path (cons "/Users/iwata/site-lisp/" load-path))
(setq load-path (cons "/Users/iwata/site-lisp/apel-10.7/" load-path))
(setq load-path (cons "/Users/iwata/site-lisp/elscreen-1.4.6/" load-path))
 
;;
(setq inhibit-startup-message t)
 
;;
;; key bindings
;;
;; ¥ではなく\を入力する
(define-key global-map [?¥] "\\")
;;
(global-set-key "\C-m" 'newline-and-indent)
;; bind key Ctrl-H to 'Backspace'
(load "term/bobcat")
(when (fboundp 'terminal-init-bobcat) (terminal-init-bobcat))
;; 次の設定の場合，Ctrl-Sによるインクリメンタルサーチ時，
;; ミスしてCtrl-Hすると元のバッファの内容をBackspaceしてしまう
(global-set-key "\C-h" 'backward-delete-char)
 
;; ref: http://d.hatena.ne.jp/sugyan/20091227/1261860179
;; Command-Key and Option-Key
(setq ns-command-modifier (quote meta))
(setq ns-alternate-modifier (quote super))
 
;;
;; font
;; ref: http://d.hatena.ne.jp/tomoya/20090210/1234297520
;;
;(when (eq system-type 'darwin)
;  (setq my-font "-*-*-medium-r-normal--9-*-*-*-*-*-fontset-osaka")
;;;  (setq fixed-width-use-QuickDraw-for-ascii t)
;  (setq mac-allow-anti-aliasing t)
;  (if (= emacs-major-version 22)
;      (require 'carbon-font))
;  (set-default-font my-font)
;  (add-to-list 'default-frame-alist `(font . ,my-font))
;  (when (= emacs-major-version 23)
;    (set-fontset-font
;     (frame-parameter nil 'font)
;     'japanese-jisx0208
;     '("osaka" . "iso10646-1"))
;    (setq face-font-rescale-alist
;	  '(("^-apple-hiragino.*" . 1.2)
;	    (".*osaka-bold.*" . 1.2)
;  	    (".*osaka-medium.*" . 1.2)
;  	    (".*courier-bold-.*-mac-roman" . 1.0)
;  	    (".*monaco cy-bold-.*-mac-cyrillic" . 0.9)
;  	    (".*monaco-bold-.*-mac-roman" . 0.9)
;  	    ("-cdac$" . 1.3)))))
 
;;;
;;; ref: http://emacs.g.hatena.ne.jp/sakito/20100127
;;;
;;(create-fontset-from-ascii-font "Menlo-14:weight=normal:slant=normal" nil "menlokakugo")
;;(set-fontset-font "fontset-menlokakugo"
;;                  'unicode
;;                  (font-spec :family "Hiragino Kaku Gothic ProN" :size 16)
;;                  nil
;;                  'append)
;;(add-to-list 'default-frame-alist '(font . "fontset-menlokakugo"))
;(create-fontset-from-ascii-font "Osaka-9:weight=normal:slant=normal" nil "osaka")
;(set-fontset-font "fontset-osaka"
;                  'unicode
;                  (font-spec :family "Hiragino Kaku Gothic ProN" :size 12)
;                  nil
;                  'append)
;(add-to-list 'default-frame-alist '(font . "fontset-osaka"))
 
;;
;; ref: http://dodeka.net/~j2/wp/?p=457p
;;
(set-face-attribute 'default nil
		    :family "Monaco"
		    ;:height 120)
		    :height 90)
(set-fontset-font "fontset-default"
		  'japanese-jisx0208
		  '("Osaka" . "iso10646-1"))
(set-fontset-font "fontset-default"
		  'katakana-jisx0201
		  '("Osaka" . "iso10646-1"))
(setq face-font-rescale-alist
      '((".*Monaco-bold.*" . 1.0)
	(".*Monaco-medium.*" . 1.0)
	(".*Osaka-bold.*" . 1.2)
	(".*Osaka-medium.*" . 1.2)
	("-cdac$" . 1.4)))
 
 
 
;;
;; window geometry
;;
;(if window-system (progn
  (setq initial-frame-alist '((width . 198)(height . 68)(top . 0)(left . 2)))
  (set-background-color "Black")
  ;(set-foreground-color "White")
  (set-foreground-color "Gray92")
  (set-cursor-color "Yellow")
;))
 
;; title
(setq frame-title-format (format "%%f - Emacs@%s" (system-name)))
 
;; disable making backup files
(setq backup-inhibited t)
(setq make-backup-files nil)
 
 
;;
;; line cursor
;;
(defface hlline-face
  '((((class color)
      (background dark))
     ;;(:background "dark state gray"))
     (:background "gray10"
		  :underline "gray32"))
    (((class color)
      (background light))
     (:background "ForestGreen"
		  :underline nil))
    (t ()))
  "*Face used by hl-line.")
(setq hl-line-face 'hlline-face)
;;(setq hl-line-face 'underline)
(global-hl-line-mode)
 
 
;;
;; ref: http://d.hatena.ne.jp/sugyan/20091227/1261860179
;;
; カーソルの点滅
(blink-cursor-mode t)
; カーソルの位置が何文字目かを表示する
(column-number-mode t)
; スクロールバーを消す
(set-scroll-bar-mode nil)
 
;; ref: http://d.hatena.ne.jp/goryugo/20080724/1216830229
;; 括弧の対応をハイライト.
(show-paren-mode 1)
 
 
;;
;; cperl-mode
;;
(setq auto-mode-alist (append '(("\\.psgi$" . cperl-mode)) auto-mode-alist))
(setq auto-mode-alist (append '(("\\.cgi$" . cperl-mode)) auto-mode-alist))
(setq auto-mode-alist (append '(("\\.pl$" . cperl-mode)) auto-mode-alist))
(setq auto-mode-alist (append '(("\\.t$" . cperl-mode)) auto-mode-alist))
 
;;
;; xml-mode
;;
(setq auto-mode-alist (append '(("\\.html$" . xml-mode)) auto-mode-alist))
(setq auto-mode-alist (append '(("\\.tpl$" . xml-mode)) auto-mode-alist))
;; Text::MicroTemplate
(setq auto-mode-alist (append '(("\\.mt$" . xml-mode)) auto-mode-alist))
 
;;
;; zencoding-mode
;;
(require 'zencoding-mode)
(add-hook 'xml-mode-hook 'zencoding-mode)
(add-hook 'sgml-mode-hook 'zencoding-mode)
(add-hook 'html-mode-hook 'zencoding-mode)
(define-key zencoding-mode-keymap (kbd "<C-return>") nil)
(define-key zencoding-mode-keymap (kbd "<S-return>") 'zencoding-expand-line)
 
;;
;; yaml-mode
;;
(autoload 'yaml-mode "yaml-mode" nil t)
(add-to-list 'auto-mode-alist '("\\.yml$" . yaml-mode))
(add-to-list 'auto-mode-alist '("\\.yaml$" . yaml-mode))
 
;;
;; espresso-mode
(autoload #'espresso-mode "espresso" "Start espresso-mode" t)
(add-to-list 'auto-mode-alist '("\\.js$" . espresso-mode))
(add-to-list 'auto-mode-alist '("\\.json$" . espresso-mode))
 
;;
;; js2-mode
;;
(autoload 'js2-mode "js2" nil t)
(add-to-list 'auto-mode-alist '("\\.js$" . js2-mode))
(add-to-list 'auto-mode-alist '("\\.json$" . js2-mode))
;; http://8-p.info/emacs-javascript.html
;(setq-default c-basic-offset 4)
;
;(when (load "js2" t)
;  (setq js2-cleanup-whitespace nil
;	js2-mirror-mode nil
;	js2-bounce-indent-flag nil)
;
;  (defun indent-and-back-to-indentation ()
;    (interactive)
;    (indent-for-tab-command)
;    (let ((point-of-indentation
;	   (save-excursion
;	     (back-to-indentation)
;	     (point))))
;      (skip-chars-forward "\s " point-of-indentation)))
;
;      (define-key js2-mode-map "\C-i" 'indent-and-back-to-indentation)
;      (define-key js2-mode-map "\C-m" nil))
 
 
;;
;; jaspace-mode
;;
(require 'jaspace)
(add-hook 'fundamental-mode-hook 'jaspace-mode)
(add-hook 'js2-mode-hook 'jaspace-mode)
(add-hook 'yaml-mode-hook 'jaspace-mode)
(add-hook 'perl-mode-hook 'jaspace-mode)
(add-hook 'cperl-mode-hook 'jaspace-mode)
(add-hook 'python-mode-hook 'jaspace-mode)
(add-hook 'ruby-mode-hook 'jaspace-mode)
(add-hook 'php-mode-hook 'jaspace-mode)
(add-hook 'xml-mode-hook 'jaspace-mode)
(add-hook 'html-mode-hook 'jaspace-mode)
(add-hook 'sgml-mode-hook 'jaspace-mode)
(add-hook 'text-mode-hook 'jaspace-mode)
(add-hook 'tt-mode-hook 'jaspace-mode)
;(when (require 'jaspace nil t)
;  (when jaspace-modes (append jaspace-modes
;			      (list 'lisp-mode
;				    'yaml-mode
;				    'perl-mode
;				    'cperl-mode
;				    'js2-mode
;				    'javascript-mode
;				    'python-mode
;				    'ruby-mode
;				    'php-mode
;				    'xml-mode
;				    'html-mode
;				    'css-mode
;				    'text-mode
;				    'tt-mode
;				    'fundamental-mode
;				    ))))
 
(when (boundp 'jaspace-alternate-jaspace-string)
  (setq jaspace-alternate-jaspace-string "□"))
(when (boundp 'jaspace-highlight-tabs)
  (setq jaspace-highlight-tabs ?^))
; 以下の4行，emacs23にてエラーが出る
;(add-hook 'jaspace-mode-off-hook
;	  (lambda()
;	    (when (boundp 'show-trailing-whitespace)
;	      (setq show-trailing-whitespace nil)
(add-hook 'jaspace-mode-hook
	  (lambda()
	    (progn
	      (when (boundp 'show-trailing-whitespace)
		(setq show-trailing-whitespace t))
	      (face-spec-set 'jaspace-highlight-jaspace-face
			     '((((class color) (background light))
				(:foreground "blue"))
			       ;;(t (:foreground "green"))))
			       (t (:foreground "gray64"))))
	      (face-spec-set 'jaspace-highlight-tab-face
			     '((((class color) (background light))
				(:foreground "red"
					     :background "unspecified"
					     :strike-through nil
					     :underline t))
			       ;;(t (:foreground "purple"
			       (t (:foreground "gray32"
					       :background "unspecified"
					       :strike-through nil
					       :underline t))))
	      (face-spec-set 'trailing-whitespace
			     '((((class color) (background light))
				 (:foreground "red"
					      :background "unspecified"
					      :strike-through nil
					      :underline t))
			       (t (:foreground "purple"
			       ;;(t (:foreground "gray16"
						:background "unspecified"
						:strike-through nil
						:underline t)))))))
 
 
;;
;; elscreen
;;   ref: http://dev.ariel-networks.com/Members/matsuyama/pseudo-screen-on-emacs-with-elscreen-and-term
(setq elscreen-prefix-key "\C-t")
(setq elscreen-display-tab t)
(load "elscreen")
(define-key elscreen-map "\C-t" 'elscreen-toggle)
(define-key elscreen-map "t" 'elscreen-toggle)

# shop.yml - SQLライブラリ的なYAMLファイル
---
get__select: |
  SELECT shop_id id, shop_No
       , code, name, flg_suspend
    FROM %%shop  /* 「%%」は適当なテーブル接頭辞に置換 */
    WHERE flg_del = 0
    ORDER BY shop_No ASC
 
add__insert: |
  INSERT INTO %%shop ...
  ...

my $list = $_dsh->q(     # $_dsh: DBIのラッパ的なもの
    'shop::get__select', # shop.ymlの「get__select」をロード
    [],                  # バインド値はなし
    [],                  # リストリファレンスで取得
);
 
print dump $list;  # use Data::Dump qw/dump/;

[
  ["roisxgdpraisxCeb", 1, "test1", "\x{30C6}\x{30B9}\x{30C8}1", 0],
  ["rpisxlbrryisxqAs", 2, "test2", "\x{30C6}\x{30B9}\x{30C8}2", 0],
  ["rpisxDgqrsisxqas", 3, "test3", "\x{30C6}\x{30B9}\x{30C8}3", 0],
  ["shisxwrpssisxKwD", 4, "test4", "\x{30C6}\x{30B9}\x{30C8}4", 0],
  ["rxisxvDlrJisxAey", 5, "test5", "\x{30C6}\x{30B9}\x{30C8}5", 0],
]

my $list = $_dsh->q(     # $_dsh: DBIのラッパ的なもの
    'shop::get__select', # shop.ymlの「get__select」をロード
    [],                  # バインド値はなし
    {},                  # ハッシュリファレンスで取得
    'id',                # キーを「id」にセット
);
 
print dump $list;  # use Data::Dump qw/dump/;

{
  roisxgdpraisxCeb => {
                        code => "test1",
                        flg_suspend => 0,
                        id => "roisxgdpraisxCeb",
                        name => "\x{30C6}\x{30B9}\x{30C8}1",
                        shop_No => 1,
                      },
  rpisxDgqrsisxqas => {
                        code => "test3",
                        flg_suspend => 0,
                        id => "rpisxDgqrsisxqas",
                        name => "\x{30C6}\x{30B9}\x{30C8}3",
                        shop_No => 3,
                      },
  rpisxlbrryisxqAs => {
                        code => "test2",
                        flg_suspend => 0,
                        id => "rpisxlbrryisxqAs",
                        name => "\x{30C6}\x{30B9}\x{30C8}2",
                        shop_No => 2,
                      },
  rxisxvDlrJisxAey => {
                        code => "test5",
                        flg_suspend => 0,
                        id => "rxisxvDlrJisxAey",
                        name => "\x{30C6}\x{30B9}\x{30C8}5",
                        shop_No => 5,
                      },
  shisxwrpssisxKwD => {
                        code => "test4",
                        flg_suspend => 0,
                        id => "shisxwrpssisxKwD",
                        name => "\x{30C6}\x{30B9}\x{30C8}4",
                        shop_No => 4,
                      },
}

my $list = $_dsh->q(     # $_dsh: DBIのラッパ的なもの
    'shop::get__select', # shop.ymlの「get__select」をロード
    [],                  # バインド値はなし
    {},                  # Hash::MultiValueオブジェクトとして取得
    'id',                # キーを「id」にセット
);
 
print dump $list;  # use Data::Dump qw/dump/;

bless({
  roisxgdpraisxCeb => {
                        code => "test1",
                        flg_suspend => 0,
                        id => "roisxgdpraisxCeb",
                        name => "\x{30C6}\x{30B9}\x{30C8}1",
                        shop_No => 1,
                      },
  rpisxDgqrsisxqas => {
                        code => "test3",
                        flg_suspend => 0,
                        id => "rpisxDgqrsisxqas",
                        name => "\x{30C6}\x{30B9}\x{30C8}3",
                        shop_No => 3,
                      },
  rpisxlbrryisxqAs => {
                        code => "test2",
                        flg_suspend => 0,
                        id => "rpisxlbrryisxqAs",
                        name => "\x{30C6}\x{30B9}\x{30C8}2",
                        shop_No => 2,
                      },
  rxisxvDlrJisxAey => {
                        code => "test5",
                        flg_suspend => 0,
                        id => "rxisxvDlrJisxAey",
                        name => "\x{30C6}\x{30B9}\x{30C8}5",
                        shop_No => 5,
                      },
  shisxwrpssisxKwD => {
                        code => "test4",
                        flg_suspend => 0,
                        id => "shisxwrpssisxKwD",
                        name => "\x{30C6}\x{30B9}\x{30C8}4",
                        shop_No => 4,
                      },
}, "Hash::MultiValue")

print dump [$list->values];  # use Data::Dump qw/dump/;

[
  {
    code => "test1",
    flg_suspend => 0,
    id => "roisxgdpraisxCeb",
    name => "\x{30C6}\x{30B9}\x{30C8}1",
    shop_No => 1,
  },
  {
    code => "test2",
    flg_suspend => 0,
    id => "rpisxlbrryisxqAs",
    name => "\x{30C6}\x{30B9}\x{30C8}2",
    shop_No => 2,
  },
  {
    code => "test3",
    flg_suspend => 0,
    id => "rpisxDgqrsisxqas",
    name => "\x{30C6}\x{30B9}\x{30C8}3",
    shop_No => 3,
  },
  {
    code => "test4",
    flg_suspend => 0,
    id => "shisxwrpssisxKwD",
    name => "\x{30C6}\x{30B9}\x{30C8}4",
    shop_No => 4,
  },
  {
    code => "test5",
    flg_suspend => 0,
    id => "rxisxvDlrJisxAey",
    name => "\x{30C6}\x{30B9}\x{30C8}5",
    shop_No => 5,
  },
]

--- DBI.pm.orig	2010-02-18 15:21:00.000000000 +0900
+++ DBI.pm.mod	2010-02-18 16:53:33.000000000 +0900
@@ -156,6 +156,7 @@
 use Carp();
 use DynaLoader ();
 use Exporter ();
+use Hash::MultiValue;
 
 BEGIN {
 @ISA = qw(Exporter DynaLoader);
@@ -465,6 +466,7 @@
 
 	fetchall_arrayref => { U =>[1,3, '[ $slice [, $max_rows]]'] },
 	fetchall_hashref  => { U =>[2,2,'$key_field'] },
+	fetchall_hmv      => { U =>[2,2,'$key_field'] },
 
 	blob_read  =>	{ U =>[4,5,'$field, $offset, $len [, ¥¥$buf [, $bufoffset]]'] },
 	blob_copy_to_file => { U =>[3,3,'$field, $filename_or_handleref'] },
@@ -2057,6 +2059,35 @@
         return $rows;
     }
 
+    sub fetchall_hmv {
+	my ($sth, $key_field) = @_;
+
+        my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
+        my $names_hash = $sth->FETCH("${hash_key_name}_hash");
+        my @key_fields = (ref $key_field) ? @$key_field : ($key_field);
+        my @key_indexes;
+        my $num_of_fields = $sth->FETCH('NUM_OF_FIELDS');
+        foreach (@key_fields) {
+           my $index = $names_hash->{$_};  # perl index not column
+           $index = $_ - 1 if !defined $index && DBI::looks_like_number($_) && $_>=1 && $_ <= $num_of_fields;
+           return $sth->set_err($DBI::stderr, "Field '$_' does not exist (not one of @{[keys %$names_hash]})")
+                unless defined $index;
+           push @key_indexes, $index;
+        }
+        my $hmv = Hash::MultiValue->new;
+        my $rows = {};
+        my $NAME = $sth->FETCH($hash_key_name);
+        my @row = (undef) x $num_of_fields;
+        $sth->bind_columns(¥(@row));
+        while ($sth->fetch) {
+            my $ref = $rows;
+            $ref = $ref->{$row[$_]} ||= {} for @key_indexes;
+            @{$ref}{@$NAME} = @row;
+            $hmv->add($row[$key_indexes[0]], $ref);
+        }
+        return $hmv;
+    }
+
     *dump_results = ¥&DBI::dump_results;
 
     sub blob_copy_to_file {	# returns length or undef on error

--- fetchall_hashref 2010-02-18 16:59:14.000000000 +0900
+++ fetchall_hmv	 2010-02-18 16:59:52.000000000 +0900
@@ -1,4 +1,4 @@
-    sub fetchall_hashref {
+    sub fetchall_hmv {
     my ($sth, $key_field) = @_;
 
         my $hash_key_name = $sth->{FetchHashKeyName} || 'NAME';
@@ -13,6 +13,7 @@
                 unless defined $index;
            push @key_indexes, $index;
         }
+        my $hmv = Hash::MultiValue->new;
         my $rows = {};
         my $NAME = $sth->FETCH($hash_key_name);
         my @row = (undef) x $num_of_fields;
@@ -21,7 +22,8 @@
             my $ref = $rows;
             $ref = $ref->{$row[$_]} ||= {} for @key_indexes;
             @{$ref}{@$NAME} = @row;
+            $hmv->add($row[$key_indexes[0]], $ref);
         }
-        return $rows;
+        return $hmv;
     }
-  
+

--- Growl.orig.pm	2010-02-14 14:28:08.000000000 +0900
+++ Growl.mod.pm	2010-02-14 14:47:48.000000000 +0900
@@ -287,7 +287,7 @@
 sub AppleScript_RegisterNotifications($$$;$)
 {
 	my($appName, $allNotes, $defaultNotes, $iconOfApp) = @_;
-	_Fix_Encode($_, 'MacRoman') for ($appName);
+	_Fix_Encode($_, 'sjis') for ($appName);
 
 	# protect quotes and slashes
 	for ($appName, $iconOfApp) {
@@ -318,7 +318,7 @@
 	for ($appName, $noteName, $noteTitle, $noteDescription) {
 		next unless defined;
 		_Fix_AppleScript_String($_);
-		_Fix_Encode($_, 'MacRoman');  # can't get to work with UTF8, so this will do
+		_Fix_Encode($_, 'sjis');  # can't get to work with UTF8, so this will do
 	}
 
 	my $script = qq'tell application "$helper" to notify ' .

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
 
use Log::Dispatch::MacGrowl;
use Encode;
 
sub en { encode_utf8($_[0]); }
 
my $note1 = Log::Dispatch::MacGrowl->new(
    name      => 'sample1',
    min_level => 'debug',
    app_name  => 'sample1',
    title     => 'sample1',
    sticky    => 1,
    priority  => 0,
);
 
my $note2 = Log::Dispatch::MacGrowl->new(
    name      => 'sample2',
    min_level => 'debug',
    app_name  => en('サンプル2'),
    #app_name  => 'sample2',
    title     => en('サンプル2'),
    sticky    => 1,
    priority  => 2,
);
 
$note1->log(level => 'debug', message => 'Hello!');
$note2->log(level => 'debug', message => en('こんにちは！'));
 
__END__

<form action="" method="post"
      enctype="multipart/form-data">
  ファイル 1-1
  <input type="file" name="file1" value="" />
 
  ファイル 1-2
  <input type="file" name="file1" value="" />
 
  ファイル 2
  <input type="file" name="file2" value="" />
 
  <input type="submit" name="submit" value="アップロード！" />
</form>

use Data::Dumper;
 
# $req is Plack::Request object
my $uploads = $req->uploads;
print ref $uploads;

Hash::MultiValue

use Data::Dumper;
print Dumper $uploads;

bless( {
         'file2' => bless( {
                             'headers' => bless( {
                                                   'content-disposition' => 'form-data; name="file2"; filename="9a8ba767.jpg"',
                                                   'content-type' => 'image/jpeg'
                                                 }, 'HTTP::Headers' ),
                             'filename' => '9a8ba767.jpg',
                             'tempname' => '/tmp/f2cY6WMe0_',
                             'size' => 102723
                           }, 'Plack::Request::Upload' ),
         'file1' => bless( {
                             'headers' => bless( {
                                                   'content-disposition' => 'form-data; name="file1"; filename="7a98edb3.jpg"',
                                                   'content-type' => 'image/jpeg'
                                                 }, 'HTTP::Headers' ),
                             'filename' => '7a98edb3.jpg',
                             'tempname' => '/tmp/6hLGbxAmym',
                             'size' => 301283
                           }, 'Plack::Request::Upload' )
       }, 'Hash::MultiValue' );

print Dumper $uploads->{file1};
print Dumper $uploads->{file2};

$VAR1 = bless( {
                 'headers' => bless( {
                                       'content-disposition' => 'form-data; name="file1"; filename="7a98edb3.jpg"',
                                       'content-type' => 'image/jpeg'
                                     }, 'HTTP::Headers' ),
                 'filename' => '7a98edb3.jpg',
                 'tempname' => '/tmp/j4gQY8Am6V',
                 'size' => 301283
               }, 'Plack::Request::Upload' );
$VAR1 = bless( {
                 'headers' => bless( {
                                       'content-disposition' => 'form-data; name="file2"; filename="9a8ba767.jpg"',
                                       'content-type' => 'image/jpeg'
                                     }, 'HTTP::Headers' ),
                 'filename' => '9a8ba767.jpg',
                 'tempname' => '/tmp/GbG3P_7Fhp',
                 'size' => 102723
               }, 'Plack::Request::Upload' );

print Dumper $uploads->get_all('file1');
print Dumper $uploads->get_all('file2');

$VAR1 = bless( {
                 'headers' => bless( {
                                       'content-disposition' => 'form-data; name="file1"; filename="6ac3d070.jpg"',
                                       'content-type' => 'image/jpeg'
                                     }, 'HTTP::Headers' ),
                 'filename' => '6ac3d070.jpg',
                 'tempname' => '/tmp/E63LJB8y1s',
                 'size' => 59307
               }, 'Plack::Request::Upload' );
$VAR2 = bless( {
                 'headers' => bless( {
                                       'content-disposition' => 'form-data; name="file1"; filename="7a98edb3.jpg"',
                                       'content-type' => 'image/jpeg'
                                     }, 'HTTP::Headers' ),
                 'filename' => '7a98edb3.jpg',
                 'tempname' => '/tmp/38aWzTxmFv',
                 'size' => 301283
               }, 'Plack::Request::Upload' );
$VAR1 = bless( {
                 'headers' => bless( {
                                       'content-disposition' => 'form-data; name="file2"; filename="9a8ba767.jpg"',
                                       'content-type' => 'image/jpeg'
                                     }, 'HTTP::Headers' ),
                 'filename' => '9a8ba767.jpg',
                 'tempname' => '/tmp/jFgvreL2Ol',
                 'size' => 102723
               }, 'Plack::Request::Upload' );

my ($up) = $uploads->get_all('file1');
print Dumper $up->size;

$VAR1 = 59307;

print Dumper $up->path;

$VAR1 = '/tmp/FmOgLKzAZQ';

print Dumper $up->content_type;

$VAR1 = 'image/jpeg';

print Dumper $up->filename;
print Dumper $up->basename;

$VAR1 = '6ac3d070.jpg';
$VAR1 = '6ac3d070.jpg';

my $h = {a => 1, b => 2};
$h->{a} = 3;
print $h->{a}; # 3

my $h = Hash::MultiValue->new(
    a => 1,
    b => 2,
    a => 3,
);

{
    a => (1, 3),
    b => 2,
};

1. 'a' => 1
2. 'b' => 2
3. 'a' => 3

use Hash::MultiValue;
use Try::Tiny;
use Data::Dumper;
 
sub p { print "\n", @_, "\n"; }
sub d { print Dumper @_; }
 
my (@pairs, %h, $h);
@pairs = (
    a => 1,
    b => 2,
    a => 3,
    c => 4,
    d => 5,
    b => 6,
    a => 7,
    e => 8,
);
%h = @pairs;
$h = Hash::MultiValue->new(@pairs);
 
d \@pairs;
d \%h;
d $h;

$VAR1 = [
          'a',
          1,
          'b',
          2,
          'a',
          3,
          'c',
          4,
          'd',
          5,
          'b',
          6,
          'a',
          7,
          'e',
          8
        ];
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => 7,
          'b' => 6,
          'd' => 5
        };
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );

p '# get';
d $h->get('a');
d $h->{a};
d $h->get('f');

# get
$VAR1 = 7;
$VAR1 = 7;
$VAR1 = undef;

p '# get_one';
for my $k (qw/b d f/) {
    try{
        d $h->get_one($k);
    } catch {
        d $_;
    };
}

# get_one
$VAR1 = 'Multiple values match: b at ./sample.pl line 40
';
$VAR1 = 5;
$VAR1 = 'Key not found: f at ./sample.pl line 40
';

p '# get_all';
d [$h->get_all('a')];
d [$h->get_all('f')];

# get_all
$VAR1 = [
          1,
          3,
          7
        ];
$VAR1 = [];

p '# keys';
d [$h->keys];
d [keys %$h];

# keys
$VAR1 = [
          'a',
          'b',
          'a',
          'c',
          'd',
          'b',
          'a',
          'e'
        ];
$VAR1 = [
          'e',
          'c',
          'a',
          'b',
          'd'
        ];

p '# values';
d [$h->values];
d [values %$h];

# values
$VAR1 = [
          1,
          2,
          3,
          4,
          5,
          6,
          7,
          8
        ];
$VAR1 = [
          8,
          4,
          7,
          6,
          5
        ];

p '# add';
d $h->add('f', 10, 20);
d [$h->get_all('f')];

# add
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5,
                 'f' => 20
               }, 'Hash::MultiValue' );
$VAR1 = [
          10,
          20
        ];

p '# remove';
d $h->remove('f');
d [$h->get_all('f')];

# remove
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );
$VAR1 = [];

p '# clear';
d $h->clear;
d [$h->keys];

# clear
$VAR1 = bless( {}, 'Hash::MultiValue' );
$VAR1 = [];

p '# flatten';
d [$h->flatten];

# flatten
$VAR1 = [
          'a',
          1,
          'b',
          2,
          'a',
          3,
          'c',
          4,
          'd',
          5,
          'b',
          6,
          'a',
          7,
          'e',
          8
        ];

p '# each';
$h->each(sub { d "$_[0] => $_[1]"; });
while (my ($k, $v) = each %$h) { d "$k ==> $v"; }

# each
$VAR1 = 'a => 1';
$VAR1 = 'b => 2';
$VAR1 = 'a => 3';
$VAR1 = 'c => 4';
$VAR1 = 'd => 5';
$VAR1 = 'b => 6';
$VAR1 = 'a => 7';
$VAR1 = 'e => 8';
$VAR1 = 'e ==> 8';
$VAR1 = 'c ==> 4';
$VAR1 = 'a ==> 7';
$VAR1 = 'b ==> 6';
$VAR1 = 'd ==> 5';

p '# clone';
my ($hh1, $hh2, $hh3) = (
    $h,
    $h->clone,
    %$h,
);
d $hh1;
d $hh2;
d $hh3;
d ["$h", "$hh1", "$hh2", "$hh3"];

# clone
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );
$VAR1 = 'e';
$VAR1 = [
          'Hash::MultiValue=HASH(0x81b634)',
          'Hash::MultiValue=HASH(0x81b634)',
          'Hash::MultiValue=HASH(0x844960)',
          'e'
        ];

p '# as_hashref';
d $h->as_hashref;

# as_hashref
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => 7,
          'b' => 6,
          'd' => 5
        };

p '# as_hasref_mixed, mixed';
d $h->as_hashref_mixed;
d $h->mixed;

# as_hasref_mixed, mixed
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => 5
        };
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => 5
        };

p '# as_hashref_multi, multi';
d $h->as_hashref_multi;
d $h->multi;

# as_hashref_multi, multi
$VAR1 = {
          'e' => [
                 8
               ],
          'c' => [
                 4
               ],
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => [
                 5
               ]
        };
$VAR1 = {
          'e' => [
                 8
               ],
          'c' => [
                 4
               ],
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => [
                 5
               ]
        };

p '# from_mixed';
my $mixed = {
    o => 1,
    p => [3, 4, 5],
    q => [7],
    r => 9,
};
$h = Hash::MultiValue->from_mixed($mixed);
d $mixed;
d $h;
d [$h->flatten];

# from_mixed
$VAR1 = {
          'p' => [
                 3,
                 4,
                 5
               ],
          'r' => 9,
          'q' => [
                 7
               ],
          'o' => 1
        };
$VAR1 = bless( {
                 'p' => 5,
                 'r' => 9,
                 'q' => 7,
                 'o' => 1
               }, 'Hash::MultiValue' );
$VAR1 = [
          'p',
          3,
          'p',
          4,
          'p',
          5,
          'r',
          9,
          'q',
          7,
          'o',
          1
        ];

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
 
use Hash::MultiValue;
use Try::Tiny;
use Data::Dumper;
 
sub p { print "\n", @_, "\n"; }
sub d { print Dumper @_; }
 
 
my (@pairs, %h, $h);
@pairs = (
    a => 1,
    b => 2,
    a => 3,
    c => 4,
    d => 5,
    b => 6,
    a => 7,
    e => 8,
);
%h = @pairs;
$h = Hash::MultiValue->new(@pairs);
 
d \@pairs;
d \%h;
d $h;
 
p '# get';
d $h->get('a');
d $h->{a};
d $h->get('f');
 
p '# get_one';
for my $k (qw/b d f/) {
    try{
        d $h->get_one($k);
    } catch {
        d $_;
    };
}
 
p '# get_all';
d [$h->get_all('a')];
d [$h->get_all('f')];
 
p '# keys';
d [$h->keys];
d [keys %$h];
 
p '# values';
d [$h->values];
d [values %$h];
 
p '# add';
d $h->add('f', 10, 20);
d [$h->get_all('f')];
 
p '# remove';
d $h->remove('f');
d [$h->get_all('f')];
 
p '# clear';
d $h->clear;
d [$h->keys];
 
$h = Hash::MultiValue->new(@pairs);
 
p '# flatten';
d [$h->flatten];
 
p '# each';
$h->each(sub { d "$_[0] => $_[1]"; });
while (my ($k, $v) = each %$h) { d "$k ==> $v"; }
 
p '# clone';
my ($hh1, $hh2, $hh3) = (
    $h,
    $h->clone,
    %$h,
);
d $hh1;
d $hh2;
d $hh3;
d ["$h", "$hh1", "$hh2", "$hh3"];
 
p '# as_hashref';
d $h->as_hashref;
 
p '# as_hasref_mixed, mixed';
d $h->as_hashref_mixed;
d $h->mixed;
 
p '# as_hashref_multi, multi';
d $h->as_hashref_multi;
d $h->multi;
 
p '# from_mixed';
my $mixed = {
    o => 1,
    p => [3, 4, 5],
    q => [7],
    r => 9,
};
$h = Hash::MultiValue->from_mixed($mixed);
d $mixed;
d $h;
d [$h->flatten];
 
__END__

% sample.pl
$VAR1 = [
          'a',
          1,
          'b',
          2,
          'a',
          3,
          'c',
          4,
          'd',
          5,
          'b',
          6,
          'a',
          7,
          'e',
          8
        ];
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => 7,
          'b' => 6,
          'd' => 5
        };
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );
 
# get
$VAR1 = 7;
$VAR1 = 7;
$VAR1 = undef;
 
# get_one
$VAR1 = 'Multiple values match: b at ./sample.pl line 40
';
$VAR1 = 5;
$VAR1 = 'Key not found: f at ./sample.pl line 40
';
 
# get_all
$VAR1 = [
          1,
          3,
          7
        ];
$VAR1 = [];
 
# keys
$VAR1 = [
          'a',
          'b',
          'a',
          'c',
          'd',
          'b',
          'a',
          'e'
        ];
$VAR1 = [
          'e',
          'c',
          'a',
          'b',
          'd'
        ];
 
# values
$VAR1 = [
          1,
          2,
          3,
          4,
          5,
          6,
          7,
          8
        ];
$VAR1 = [
          8,
          4,
          7,
          6,
          5
        ];
 
# add
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5,
                 'f' => 20
               }, 'Hash::MultiValue' );
$VAR1 = [
          10,
          20
        ];
 
# remove
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );
$VAR1 = [];
 
# clear
$VAR1 = bless( {}, 'Hash::MultiValue' );
$VAR1 = [];
 
# flatten
$VAR1 = [
          'a',
          1,
          'b',
          2,
          'a',
          3,
          'c',
          4,
          'd',
          5,
          'b',
          6,
          'a',
          7,
          'e',
          8
        ];
 
# each
$VAR1 = 'a => 1';
$VAR1 = 'b => 2';
$VAR1 = 'a => 3';
$VAR1 = 'c => 4';
$VAR1 = 'd => 5';
$VAR1 = 'b => 6';
$VAR1 = 'a => 7';
$VAR1 = 'e => 8';
$VAR1 = 'e ==> 8';
$VAR1 = 'c ==> 4';
$VAR1 = 'a ==> 7';
$VAR1 = 'b ==> 6';
$VAR1 = 'd ==> 5';
 
# clone
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );
$VAR1 = bless( {
                 'e' => 8,
                 'c' => 4,
                 'a' => 7,
                 'b' => 6,
                 'd' => 5
               }, 'Hash::MultiValue' );
$VAR1 = 'e';
$VAR1 = [
          'Hash::MultiValue=HASH(0x81b634)',
          'Hash::MultiValue=HASH(0x81b634)',
          'Hash::MultiValue=HASH(0x844960)',
          'e'
        ];
 
# as_hashref
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => 7,
          'b' => 6,
          'd' => 5
        };
 
# as_hasref_mixed, mixed
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => 5
        };
$VAR1 = {
          'e' => 8,
          'c' => 4,
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => 5
        };
 
# as_hashref_multi, multi
$VAR1 = {
          'e' => [
                 8
               ],
          'c' => [
                 4
               ],
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => [
                 5
               ]
        };
$VAR1 = {
          'e' => [
                 8
               ],
          'c' => [
                 4
               ],
          'a' => [
                 1,
                 3,
                 7
               ],
          'b' => [
                 2,
                 6
               ],
          'd' => [
                 5
               ]
        };
 
# from_mixed
$VAR1 = {
          'p' => [
                 3,
                 4,
                 5
               ],
          'r' => 9,
          'q' => [
                 7
               ],
          'o' => 1
        };
$VAR1 = bless( {
                 'p' => 5,
                 'r' => 9,
                 'q' => 7,
                 'o' => 1
               }, 'Hash::MultiValue' );
$VAR1 = [
          'p',
          3,
          'p',
          4,
          'p',
          5,
          'r',
          9,
          'q',
          7,
          'o',
          1
        ];
%

use Cache::FileCache;
 
my $cache = Cache::FileCache->new({
    namespace          => 'filecache_sample',
    default_expires_in => 10,
});

my $to_be_cached = 'hogehoge';
$cache->set('keyname', $to_be_cached);

$cache->set('keyname', $to_be_cached, 60);

my $cached = $cache->get('keyname');   # 保持期限内 ? 'hogehoge' : undef
my $undef  = $cache->get('hogehoge');  # undef

% ./sample1.pl
 
# about 0 sec.
$VAR1 = {
          'bar' => 'huga',
          'baz' => 'piyo',
          'foo' => 'hoge'
        };
$VAR1 = {
          'c' => '3',
          'a' => '1',
          'b' => '2'
        };
 
# about 5 sec.
$VAR1 = {
          'bar' => 'huga',
          'baz' => 'piyo',
          'foo' => 'hoge'
        };
$VAR1 = {
          'c' => '3',
          'a' => '1',
          'b' => '2'
        };
 
# about 11 sec.
$VAR1 = undef;
$VAR1 = {
          'c' => '3',
          'a' => '1',
          'b' => '2'
        };
 
# about 15 sec.
$VAR1 = undef;
$VAR1 = {
          'c' => '3',
          'a' => '1',
          'b' => '2'
        };
 
# about 21 sec.
$VAR1 = undef;
$VAR1 = undef;
%

% ./sample2.pl
 
# cache_root
 
/var/folders/sC/sCwCvkCpGzSDGTP6+Wood++++TI/-Tmp-/FileCache
 
# tree
 
/var/folders/sC/sCwCvkCpGzSDGTP6+Wood++++TI/-Tmp-/FileCache
`-- filecache_sample
    |-- 9
    |   `-- b
    |       `-- 6
    |           `-- 9b63072850833c63c5200f2c35b3edc4118f705e
    `-- a
        `-- 1
            `-- d
                `-- a1dd4114c98069523cdf1d90ff3a43222670b8c8
 
7 directories, 2 files
 
 
# sha1
 
a1dd4114c98069523cdf1d90ff3a43222670b8c8
 
9b63072850833c63c5200f2c35b3edc4118f705e
 
# changing cache_root
 
# cache_root
 
./tmp
 
# tree
 
./tmp
`-- filecache_sample
    |-- 9
    |   `-- b
    |       `-- 6
    |           `-- 9b63072850833c63c5200f2c35b3edc4118f705e
    `-- a
        `-- 1
            `-- d
                `-- a1dd4114c98069523cdf1d90ff3a43222670b8c8
 
7 directories, 2 files
 
 
# sha1
 
a1dd4114c98069523cdf1d90ff3a43222670b8c8
 
9b63072850833c63c5200f2c35b3edc4118f705e
%

$cache = Cache::FileCache->new({
    namespace          => 'filecache_sample',
    default_expires_in => 10,
    cache_root         => './tmp',
});

% ll
total 24
-rw-r--r--@ 1 iwata  staff  673  2  5 01:20 sample.yml
-rwxr-xr-x  1 iwata  staff  681  2  5 02:56 sample1.pl
-rwxr-xr-x@ 1 iwata  staff  946  2  5 03:03 sample2.pl
%

% ll
total 24
-rw-r--r--@ 1 iwata  staff  673  2  5 01:20 sample.yml
-rwxr-xr-x  1 iwata  staff  681  2  5 02:56 sample1.pl
-rwxr-xr-x@ 1 iwata  staff  942  2  5 03:07 sample2.pl
drwxrwxrwx  3 iwata  staff  102  2  5 03:06 tmp
%

% less ./tmp/filecache_sample/a/1/d/a1dd4114c98069523cdf1d90ff3a43222670b8c8
 
^E^G^B^@^@^@^B
^Dvar1^D^Q^MCache::Object^C^@^@^@^F^E^@^@^@^E_Size      Kk^MS^@^@^@^K_Expires_At^E^@^@^@^D_Key  Kk^M^W^@^@^@^K_Created_At^D^C^@^@^@^C
^Dhuga^@^@^@^Cbar
^Dpiyo^@^@^@^Cbaz
^Dhoge^@^@^@^Cfoo^@^@^@^E_Data  Kk^M^W^@^@^@^L_Accessed_At

% ./sample3.pl
 
# tree -p
 
./tmp
`-- [drwxrwxrwx]  filecache_sample
    |-- [drwxrwxrwx]  9
    |   `-- [drwxrwxrwx]  b
    |       `-- [drwxrwxrwx]  6
    |           `-- [-rw-r--r--]  9b63072850833c63c5200f2c35b3edc4118f705e
    `-- [drwxrwxrwx]  a
        `-- [drwxrwxrwx]  1
            `-- [drwxrwxrwx]  d
                `-- [-rw-r--r--]  a1dd4114c98069523cdf1d90ff3a43222670b8c8
 
7 directories, 2 files
 
 
# changing cache_depth and directory_umask
 
# tree -p
 
./tmp
`-- [drwxrwxrwx]  filecache_sample
    |-- [drwxrwxrwx]  9
    |   `-- [drwxrwxrwx]  b
    |       `-- [drwxrwxrwx]  6
    |           |-- [drwx------]  3
    |           |   `-- [drwx------]  0
    |           |       `-- [drwx------]  7
    |           |           `-- [-rw-r--r--]  9b63072850833c63c5200f2c35b3edc4118f705e
    |           `-- [-rw-r--r--]  9b63072850833c63c5200f2c35b3edc4118f705e
    `-- [drwxrwxrwx]  a
        `-- [drwxrwxrwx]  1
            `-- [drwxrwxrwx]  d
                |-- [-rw-r--r--]  a1dd4114c98069523cdf1d90ff3a43222670b8c8
                `-- [drwx------]  d
                    `-- [drwx------]  4
                        `-- [drwx------]  1
                            `-- [-rw-r--r--]  a1dd4114c98069523cdf1d90ff3a43222670b8c8
 
13 directories, 4 files
 
%

% ./sample4.pl
Benchmark: timing 10000 iterations of b1, b2, b3, b4...
        b1: 75 wallclock secs (72.25 usr +  0.70 sys = 72.95 CPU) @ 137.08/s (n=10000)
        b2:  3 wallclock secs ( 2.16 usr +  0.28 sys =  2.44 CPU) @ 4098.36/s (n=10000)
        b3:  3 wallclock secs ( 2.62 usr +  0.64 sys =  3.26 CPU) @ 3067.48/s (n=10000)
        b4:  4 wallclock secs ( 2.59 usr +  0.64 sys =  3.23 CPU) @ 3095.98/s (n=10000)
     Rate    b1    b3    b4    b2
b1  137/s    --  -96%  -96%  -97%
b3 3067/s 2138%    --   -1%  -25%
b4 3096/s 2159%    1%    --  -24%
b2 4098/s 2890%   34%   32%    --
%

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
 
use YAML::Syck;
use Cache::FileCache;
use Data::Dumper;
 
sub p { print "\n", @_, "\n"; }
sub d { print Dumper @_; }
 
my $cache = Cache::FileCache->new({
    namespace          => 'filecache_sample',
    default_expires_in => 10,
});
 
my $var1 = {qw/foo hoge bar huga baz piyo/};
my $var2 = {qw/a 1 b 2 c 3/};
 
$cache->set('var1', $var1);
$cache->set('var2', $var2, 20);
 
sub cache_test {
    my @plan = @_;
    my $sec = 0;
    for my $s (@plan) {
        $sec += $s;
        sleep($s);
        p "# about $sec sec.";
        d $cache->get('var1');
        d $cache->get('var2');
    }
}
 
cache_test 0, 5, 6, 4, 6;
 
__END__

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
 
use YAML::Syck;
use Cache::FileCache;
use Data::Dumper;
 
sub p { print "\n", @_, "\n"; }
sub d { print Dumper @_; }
 
my $cache = Cache::FileCache->new({
    namespace          => 'filecache_sample',
    default_expires_in => 60,
});
 
my $var1 = {qw/foo hoge bar huga baz piyo/};
my $var2 = {qw/a 1 b 2 c 3/};
 
$cache->set('var1', $var1);
$cache->set('var2', $var2);
 
my $cache_root = $cache->get_cache_root();
p '# cache_root';
p $cache_root;
 
p '# tree';
p `tree $cache_root`;
 
p '# sha1';
p sha1_hex 'var1';
p sha1_hex 'var2';
 
#
# cache_rootを変更してみる
#
p '# changing cache_root';
$cache->set_cache_root('./tmp');
 
$cache->set('var1', $var1);
$cache->set('var2', $var2);
 
$cache_root = $cache->get_cache_root();
p '# cache_root';
p $cache_root;
 
p '# tree';
p `tree $cache_root`;
 
p '# sha1';
p sha1_hex 'var1';
p sha1_hex 'var2';
 
__END__

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
 
use YAML::Syck;
use Cache::FileCache;
use Digest::SHA1 qw/sha1_hex/;
use Data::Dumper;
 
sub p { print "\n", @_, "\n"; }
sub d { print Dumper @_; }
 
my $cache = Cache::FileCache->new({
    namespace          => 'filecache_sample',
    default_expires_in => 60,
    cache_root         => './tmp',
});
 
my $var1 = {qw/foo hoge bar huga baz piyo/};
my $var2 = {qw/a 1 b 2 c 3/};
 
$cache->set('var1', $var1);
$cache->set('var2', $var2);
 
my $cache_root = $cache->get_cache_root();
p '# tree -p';
p `tree -p $cache_root`;
 
#
# cache_depth，directory_umaskを変更してみる
#
p '# changing cache_depth and directory_umask';
$cache->set_cache_depth(6);
$cache->set_directory_umask(077);
 
$cache->set('var1', $var1);
$cache->set('var2', $var2);
 
p '# tree -p';
p `tree -p $cache_root`;
 
__END__

#!/usr/bin/env perl
use strict;
use warnings;
use utf8;
 
use YAML;
use YAML::Syck;
use Cache::FileCache;
use Benchmark qw/:all/;
use Data::Dumper;
 
sub p { print "\n", @_, "\n"; }
sub d { print Dumper @_; }
 
my $cache = Cache::FileCache->new({
    namespace          => 'filecache_sample',
    default_expires_in => 600,
    cache_root         => './tmp',
});
 
my $yamlfile = './sample.yml';
 
 
my ($b1, $b2, $b3, $b4);
#
# b1: YAML
#
$b1 = sub {
    my $hash = YAML::LoadFile($yamlfile);
    return $hash;
};
#
# b2: YAML::Syck
#
$b2 = sub {
    my $hash = YAML::Syck::LoadFile($yamlfile);
    return $hash;
};
#
# b3: Cache::FileCache || YAML
#
$b3 = sub {
    my $key = 'sample4_b3';
    my $hash = $cache->get($key);
    unless (defined $hash) {
        $hash = YAML::LoadFile($yamlfile);
        $cache->set($key, $hash);
    }
    return $hash;
};
#
# b4: Cache::FileCache || YAML::Syck
#
$b4 = sub {
    my $key = 'sample4_b4';
    my $hash = $cache->get($key);
    unless (defined $hash) {
        $hash = YAML::Syck::LoadFile($yamlfile);
        $cache->set($key, $hash);
    }
    return $hash;
};
 
 
my $results = timethese(
    10_000,
    {
        b1 => $b1,
        b2 => $b2,
        b3 => $b3,
        b4 => $b4,
    },
);
cmpthese($results);
 
__END__

---
LOCATION:
  PROTOCOL:  http
  DOMAIN:    denske.local
  SUBDOMAIN: www.
  PATH:      /path
 
PAGE:
  COMMON_CSS: [_base, _layout, _additional]
  COMMON_JS:  [_base, _additional]
 
DSI:
  DBI:  1
  YAML: 1
 
DB:
  TYPE:   mysql
  NAME:   sample
  HOST:   localhost
  USER:   sample
  PASSWD: samplepasswd
  TABLE_PREFIX: sample_
 
CACHE:
  ENABLED:   1
  NAMESPACE: samplesample
  EXPIRES:   600
 
COOKIE:
  EXPIRES: +14d
  DOMAIN:  
  PATH:    /
  SECURE:  0
 
MAIL:
  SERVER_SMTP: localhost:587
  ADDRESS:
    FROM: noreply@example.com
    CC:
  SIGNATURE: |
    --
    your email signature.
 
SESSION_KEY_NAME: sample_session
 
CONTENT_TYPE_DEFAULT: text/html; charset=utf-8