Mercurial > hg > Applications > Calcon

package Calcon;

## $Id$

use 5.008;
use strict;
# use warnings; we have -w, so why we need this?

#require Exporter;

#our @ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

# This allows declaration	use Calcon ':all';
# If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
# will save memory.
#our %EXPORT_TAGS = ( 'all' => [ qw(
#
#) ] );

#our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

#our @EXPORT = qw(

#);

our $VERSION = '0.01';


# Preloaded methods go here.

# if you don't have NKF
# package Calcon::NKF;
#
# コード変換しなくても動くことは動くけど、いくつか問題がある。
#
# sub nkf {
#    return shift(@_);
# }

# デバッグ中に本当にこのパッケージを見ているかどうかの確認用。
# print STDERR "new versoin!!\n";

#######################################################################/

package Calcon::Basic ;
use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ();

# このパッケージ用の汎用ライブラリ。Date や Record などの
# ファクトリーもここにある。Read/Write の両方から参照される。
# Date/Record の実装を変えたいときは、ここを変更する。

my $date_class = 'Calcon::Date';
my $record_class = 'Calcon::Record';

sub new {
   my ($this,$opts,$file) = @_;
   # ClassName->new で呼び出される時のためにこれがある。Perl の決り文句。
   my $class = ref($this) || $this;
   my $self = {};
   bless $self, $class;
   # 入出力ファイル名
   $self->{'-file'} = $file if ($file);
   $self->option($opts);
   $self->initialize();  # this calls sub class' initializer.
   return $self;
}

# 下位クラスから呼び出される初期化。ここでは何もしない。
# new で呼ばれたinitilize は、段階的に SUPER::initilalize を呼び出す。
# 最終的に、基底クラスである Calcon::Basic (Calcon そのものであるべき?)
# の initialize を呼び出す。呼び出されるのだから用意しておく必要がある。

sub initialize {
    my ($self) = @_;
}

# option 関係。

sub set_debug {
    my ($self,$flag) = @_;
    $self->{'-debug'} = $flag;
}

sub option {
    my ($self,$option) = @_;

    return if (! defined($option));
    foreach my $opt ( $option =~ /./g ) {
        if ($opt eq '-') {
        } elsif ($opt eq 'n') {
            $self->{'-file-out'} = 1;
        } elsif ($opt eq 'd') {
            $self->set_debug(1);
        } elsif ($opt eq 'a') {
            $self->{'-address-only'} = 1;
        } elsif ($opt eq 'c') {
            $self->{'-calendar-only'} = 1;
        } elsif ($opt eq 'F') {
            $self->{'-future-only'} = 1;
        } elsif ($opt eq 't') {
            $self->{'-tomorrow'} = 1;
        } elsif ($opt eq 'C') {
            $self->{'-count'} = 5;
        }
    }
}

# デバッグ用レコード表示ルーチン。

sub show {
    my ($self,$record) = @_;
    $record->show();
}

# 時間関係のライブラリ

sub localtime {
    my ($self,$date) = @_;
    return $date->localtime();
}

sub date {
    my ($self,$date) = @_;
    return $date->date();
}

sub today {
    $date_class->today;
}

sub unix_time {
    my ($self,$date) = @_;
    return $date->unix_time();
}

# Factory Pattern

sub make_date_unix {
    my ($self,$date) = @_;
    return $date_class->make_date_unix($date);
}

sub make_date {
    my ($self,$date) = @_;
    return $date_class->make_date($date);
}

sub make_record {
    my ($self) = @_;
    my %record;
    my $record = \%record;
    bless $record,$record_class;
}

#######################################################################/

package Calcon::Record ;
use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Time::Local;
@ISA = ();

# 変換に用いる中間データ形式。オブジェクトにすると、デバッグの
# 時に便利。

sub show {
    my ($self) = @_;
    foreach my $key (keys %$self) {
	my $value = $self->{$key};
	if (ref $value) {
	    $value = $value->value();
	}
	print "$key: $value\n" if (defined($value) && $value ne '');
    }
    print "\n";
}

# 中身を文字列で返す。

sub value {
    my ($self) = @_;
    my $data;
    foreach my $key (keys %$self) {
	my $value = $self->{$key};
	if (ref $value) {
	    $value = $value->value();
	}
	$data .= "$key: $value\n" if (defined($value) && $value ne '');
    }
    $data;
}

# 等しいかどうか

sub equal {
    my ($self,$record) = @_;

    foreach my $key (keys %{$self}) {
	next if (!defined $self->{$key} && !defined $record->{$key});
	if(ref $self->{$key} && ref $record->{$key}) {
	    return 0 if (! $self->{$key}->equal($record->{$key}));
	} else {
	    return 0 if ($self->{$key} ne $record->{$key});
	}
    }
    return 1;
}

# 与えられたレコードリストに含まれる情報しか持っていないかどうか

sub information_in_list {
    my ($self,$records) = @_;

    my $lines;
    foreach my $record (@$records) {
	foreach my $key (keys %{$record}) {
	    my $value;
	    if (ref $record->{$key}) {
		$value = $record->{$key}->value();
	    } else {
		$value = $record->{$key};
	    }
	    foreach my $line (split(/\n/,$value)) {
		$line =~ s/\s+/ /g;
		next if (! $line);
		$lines->{$line} = $key;
	    }
	}
    }
    return $lines;
}

# 与えられたレコードリストに対して相対的に新しい情報だけのレコードを作る。

    sub new_information {
    my ($self,$records) = @_;
    my $lines = $self->information_in_list($records);

    my $info;
    foreach my $key (keys %{$self}) {
	my $value;
	if (ref $self->{$key}) {
	    $value = $self->{$key}->value();
	} else {
	    $value = $self->{$key};
	}
	foreach my $line (split(/\n/,$value)) {
	    $line =~ s/\s+/ /g;
	    next if (! $line);
	    next if (defined $lines->{$line}) ;
	    if (defined $info->{$key}) { $info->{$key} .= "\n$line";}
	    else { $info->{$key} .= $line; }
	}
    }
    if(defined $info) {
	bless $info ;

	# 必要なキーを残す

	$info->{'-date'} = $records->[0]->{'-date'}
	    if (defined ($records->[0]->{'-date'})) ;
	$info->{'-name'} = $records->[0]->{'-name'}
	    if (defined ($records->[0]->{'-name'})) ;
	# else error だけど、まぁ、良い。
    }
    $info;
}

# 与えられたリストにおなじ値を持つレコードが含まれているかどうか

sub is_included {
    my ($self,$records) = @_;
    my $lines = $self->information_in_list($records);

    foreach my $key (keys %{$self}) {
	my $value;
	if (ref $self->{$key}) {
	    $value = $self->{$key}->value();
	} else {
	    $value = $self->{$key};
	}
	foreach my $line (split(/\n/,$value)) {
	    $line =~ s/\s+/ /g;
	    next if (! $line);
	    return 0 if (! defined $lines->{$line}) ;
	}
    }
    return 1;
}

#######################################################################/

package Calcon::Date ;
use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Time::Local;
@ISA = ();

# 日付に関するオブジェクト
#   Perl に標準なものがあるんだろうけど。
# record とおなじインタフェースを持つべき

my @monthname = ( 'Jan','Feb', 'Mar', 'Apr', 'May', 'Jun',
     'Jul','Aug','Sep','Oct','Nov', 'Dec');
my %monthname;
my $i;
foreach my $name (@monthname) { $monthname{$name} = $i++; }

# use unix time scalar as an object
#     < 1902/1/1-12/31         date in every year
#     1903/1/1    00:00-23:59  time in evey day
#     1903/1/1-7               every weekday
# It is better to use [$date,$tags] array for this class.
# あんまり良い実装じゃないね。せこすぎ。

my $every_day_min = timelocal(0,0,0,1,0,1902);
my $every_day_max = timelocal(0,0,0,1,0,1903);
my $every_time_min = timelocal(0,0,0,1,0,1903);
my $every_time_max = timelocal(59,59,23,1,0,1903);
my $every_weekday_min = timelocal(0,0,0,4,0,1903); # Sunday
my $every_weekday_max = timelocal(0,0,0,11,0,1903);# Sunday

my $today = time - 24*3600;

my %week = (
    'Sun'=> timelocal(0,0,0,4,0,1903),
    'Mon'=> timelocal(0,0,0,5,0,1903),
    'Tue'=> timelocal(0,0,0,6,0,1903),
    'Wed'=> timelocal(0,0,0,7,0,1903),
    'Thu'=> timelocal(0,0,0,8,0,1903),
    'Fri'=> timelocal(0,0,0,9,0,1903),
    'Sat'=> timelocal(0,0,0,10,0,1903),
);
my @week_name = (
    'Sun',
    'Mon',
    'Tue',
    'Wed',
    'Thu',
    'Fri',
    'Sat',
);

sub is_allday {
    my ($self) = @_;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
	   localtime($$self);
    return ($sec==0 && $min==0 && $hour==0);
}

sub is_day {
    my ($self) = @_;
    return ( $every_day_min <= $$self && $$self < $every_day_max );
}

sub is_time {
    my ($date) = @_;
    return ( $every_time_min <= $$date && $$date < $every_time_max );
}

sub future {
    my ($self) = @_;
    return ( $$self >= $today );
}

sub tomorrow {
    my ($self) = @_;
    return ( $today+24*3600*2 >= $$self && $$self >= $today-24*3600/2);
}

sub is_weekday {
    my ($date) = @_;
    return ( $every_weekday_min <= $$date && $$date < $every_weekday_max );
}

sub localtime {
    my ($self) = @_;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
	   localtime($$self);
    return ($year+1900,$mon+1,$mday,$hour,$min);
}

sub make_date {
    my ($self,$date) = @_;
    my ($year,$month,$day,$hour);
    my ($sec,$min);

    $hour = $min = $sec = 0;

    if ($date =~ m-(\d+)/(\d+)/(\d+)-) {
	# $year = $1 - 1900;     this is no longer good for timelocal
	$year = $1;
	$month = $2-1;
	$day = $3;
    } elsif ($date =~ m-(\d+)/(\d+)-) {
	$year = 1902;
	$month = $1-1;
	$day = $2;
    } else {
	if ($week{$date}) {
	    my $weekday  = $week{$date};
	    bless $date;
	    return $date;
	}
	if ($date =~ m-(\d+):(\d+)-) {
	    $hour = $1;
	    $min = $2;
	}
	$year = 1903; $month = 0; $day = 1;
	return &make_date1($year,$month,$day,$hour,$min,$sec);
    }
    if ($date =~ m-(\d+):(\d+)-) {
	$hour = $1;
	$min = $2;
    }
    return &make_date1($year,$month,$day,$hour,$min,$sec);
}

sub make_date1 {
    my ($year,$month,$day,$hour,$min,$sec) = @_;
    my ($date,$self);

    if ( eval '$date = timelocal($sec,$min,$hour,$day,$month,$year)' ) {
    } else {
	$date = timelocal(0,0,0,1,0,70);
    }
    $self = \$date;
    bless $self;
}

sub make_date_unix {
    my ($self,$date) = @_;
    $self = \$date;
    bless $self;
}

sub date {
    my ($self) = @_;
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
	   CORE::localtime($$self);
    my $date;
    if ($self->is_day()) {
	$date = ($mon+1)."/$mday";
    } elsif ($self->is_weekday()) {
	return $week_name[$wday];
    } elsif ($self->is_time()) {
        $date = sprintf(" %02d:%02d",$hour,$min) if ($hour || $min);
    } else {
	$date = ($year+1900)."/".($mon+1)."/$mday";
	$date .= sprintf(" %02d:%02d",$hour,$min) if ($hour || $min);
    }
    return $date;
}

sub unix_time {
    my ($self) = @_;
    $$self;
}

sub add {
    my ($self,$add) = @_;
    my ($result);
    return $self if (!defined($add));
    $result = $$self + $add;
    bless \$result;
}

sub date_after {
    my ($self,$day2) = @_;
    return $$self<$$day2;
}

sub today {
    my $today = time;
    bless \$today;
}

# record のインタフェース

sub show  {
    my ($self) = @_;
    print $self->date();
}

sub value {
    my ($self) = @_;
    $self->date();
}

sub equal {
    my ($self,$date) = @_;
    return ($self->unix_time() !=  $date->unix_time());
}

#######################################################################/

package Calcon::Reader ;
use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = (  'Calcon::Basic' );

# Reader の基底クラス

#  Reader は decode method を持つ必要がある。

sub decode {
    my ($self) = @_;
}

sub set_output{
    my ($self,$out) = @_;
    $self->{'-output'} = $out;
}

# date_normalize は Date クラスに変換するので、Reader は必ず
# 呼ぶ必要がある。少し汎用すぎるか?

sub date_normalize {
    my ($self,$keys,$record) = @_;
    my ($sday,$stime,$eday,$etime);

    if ($record->{'birth'}) {
	$record->{'birth'} = $self->make_date($record->{'birth'});
    }
    if ($record->{'modify-date'}) {
	$record->{'modify-date'} = $self->make_date($record->{'modify-date'});
    }
    return if (! $record->{'date'}); # internal error
# print ">**$record->{'date'}***\n";
# print ">**$record->{'end-date'}***\n";
# print ">**$record->{'time'}***\n";
# print ">**$record->{'end-time'}***\n";
    # warning killer
    if (! defined($record->{'date'})) { $record->{'date'} = '';}
    if (! defined($record->{'time'})) { $record->{'time'} = '';}
    if (! defined($record->{'end-time'})) { $record->{'end-time'} = '';}
    if (! defined($record->{'end-date'})) { $record->{'end-date'} = '';}
    $sday = $eday = $stime = $etime = '';

    if ($record->{'time'} =~ /(\d+:\d+)\s*-\s*(\d+:\d+)/) {
	$stime = $1; $etime = $2;
    } elsif ($record->{'time'} =~ /(\d+:\d+)/) {
	$stime = $1;
    }
    if ($record->{'date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)\s*-(\d+\/\d+\/\d+).*\s*(\d+:\d+)/) {
	$sday = $1; $stime = $2; $eday = $3; $etime = $4;
    } elsif ($record->{'date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)\s*-\s*(\d+:\d+)/) {
	$sday = $1; $stime = $2; $etime = $3;
    } elsif ($record->{'date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)/) {
	$sday = $1; $stime = $2;
    } elsif ($record->{'date'} =~ /(\d+\/\d+\/\d+)/) {
	$sday = $1;
    }

    # これらのチェックで end-time などが作られてしまうみたい。本来は、
    # defined で避けるべきなんだろうが...

    if ($record->{'end-time'} =~ /(\d+:\d+)/) {
	$etime = $1;
    }
    if ($record->{'end-date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)/) {
	$eday = $1; $etime = $2;
    } elsif ($record->{'end-date'} =~ /(\d+\/\d+\/\d+)/) {
	$eday = $1;
    } elsif ( $etime ) {
	$eday = $sday;
    }

    $sday = $self->make_date("$sday $stime");
    if ($eday) {
	$eday = $self->make_date("$eday $etime");
	if ($eday->date_after($sday)) {
	    undef $eday;
	}
    }

    # いったん消しておいて、
    foreach my $key ('end-date','date', 'time','end-time') {
	undef $record->{$key};
    }
    @$keys = grep(!/^end-date|^date|^time|^end-time/,@$keys);

    # もう一回作る。まったくね。

# print "@$keys\n";
    if ($eday) {
	$record->{'end-date'} = $eday;
	unshift(@$keys,'end-date');
    }
    $record->{'date'} = $sday;
    unshift(@$keys,'date');

# print "@$keys\n";
# print "***$record->{'date'}***\n";
# print "***$record->{'end-date'}***\n";
}

#######################################################################/

package Calcon::Writer ;
use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ( 'Calcon::Basic' );
use Carp;

# Writer の基底クラス

# Why this class is necessary?
sub initialize {
    my ($self) = @_;

    # 書き出しファイルの切替え
    # directory などに出力する場合は、-file を undef する。
    if (defined $self->{'-file'}) {
	open(OUT,">".$self->{'-file'}) or
	    croak("Can't open $self->{'-file'}:$!\n");
	select OUT;
    }
    # いらないのは知っているが、拡張するかも知れないので。
    $self->SUPER::initialize();
}

#   Writer の基本インタフェース (必ず上書きされる)
#     Perl にもインタフェースが欲しいよね。

sub start_file {
    my ($self,$type) = @_;
}

sub end_file {
    my ($self,$type) = @_;
}

sub record {
    my ($self,$record,$key) = @_;
}


#######################################################################/

package Calcon::File_write ;

# ファイル形式への書き出し
#    key: データ
# レコードのセパレータは "\n\n"

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ('Calcon::Writer');

sub record {
    my ($self,$keys,$items) = @_;
    my @keys = @$keys;
    my %items = %$items;
    # should be override
    if ($items->{'date'}) { return if ($self->{'-future-only'} && ! $items->{'date'}->future()); }
    foreach my $key (@keys) {
	my $value = $items{$key};
	if (ref $value) {
	    $value = $value->value();
	}
	print "$key: $value\n" if (defined($value) && $value ne '');
    }
    print "\n";
}

#######################################################################/

package Calcon::Print_write ;

# 印刷形式。login時に表示するコンパクトな形式。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use NKF;
@ISA = ('Calcon::Writer');

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    if ($self->{'-tomorrow'}) {
	$self->{'-count'} = 5;
    } else {
	$self->{'-count'} = -1;
    }
}

sub record {
    my ($self,$keys,$items) = @_;
    my @keys = @$keys;
    my %items = %$items;
    # should be override
    if (defined $items->{'date'}) {
        my $date = $items->{'date'};
	return if ($self->{'-future-only'} && ! $date->future());
	return if ($self->{'-tomorrow'} && ! $date->tomorrow());
	return if ($self->{'-count'} == 0);
	$self->{'-count'} --;
	$date = $date->date();
	my $memo ='';
	$memo = $items->{'memo'} if (defined($items->{'memo'}));
	$memo =~ s/\n+$//;
	if ($self->{'-tomorrow'}) {
	    print nkf('-e',"$date:\t$memo\n");
	} else {
	    $memo =~ s/^/$date:\t/mg;
	    print nkf('-e',"$memo\n");
	}
    } else {
	foreach my $key (@keys) {
	    my $value = $items{$key};
	    if (ref $value) {
		$value = $value->value();
	    }
	    print nkf('-e',"$key: $value\n") if (defined($value) && $value ne '');
	}
	print "\n";
    }
}

#######################################################################/

package Calcon::Zaurus;
use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ();

# ザウルス関連の基底クラス
# フレーバとして使うので new がない。
# 使用するクラスはZaurus_initialize を呼び出す必要がある。

my %item_type = (
'ADR1'=>'s', 'ADR2'=>'s', 'ALRM'=>'d', 'ANN1'=>'d', 'ANN2'=>'d', 'ATSC'=>'u',
'ATTM'=>'u', 'ATTR'=>'u', 'BRTH'=>'d', 'CFIP'=>'s', 'CHK1'=>'b', 'CHK2'=>'b',
'CHK3'=>'b', 'CHK4'=>'b', 'CLAS'=>'s', 'CLSC'=>'u', 'CNTC'=>'u', 'COLR'=>'u',
'CPS1'=>'s', 'CTGR'=>'u', 'DB01'=>'u', 'DB02'=>'u', 'DB03'=>'u', 'DB04'=>'u',
'DB05'=>'u', 'DB06'=>'u', 'DB07'=>'u', 'DB08'=>'u', 'DB09'=>'u', 'DB10'=>'u',
'DB11'=>'u', 'DB12'=>'u', 'DB13'=>'u', 'DB14'=>'u', 'DB15'=>'u', 'DB16'=>'u',
'DB17'=>'u', 'DB18'=>'u', 'DB19'=>'u', 'DB20'=>'u', 'DB21'=>'u', 'DB22'=>'u',
'DB23'=>'u', 'DB24'=>'u', 'DB25'=>'u', 'DB26'=>'u', 'DB27'=>'u', 'DB28'=>'u',
'DBFN'=>'u', 'DBID'=>'u', 'DBIT'=>'u', 'DBSI'=>'u', 'DBST'=>'u', 'DNS1'=>'s',
'DNS2'=>'s', 'ECDT'=>'u', 'EDDY'=>'d', 'EDTM'=>'d', 'ETDY'=>'d', 'FAX1'=>'s',
'FAX2'=>'s', 'FINF'=>'b', 'FNDY'=>'d', 'HOL1'=>'d', 'HTXT'=>'h', 'IMG1'=>'i',
'IMGF'=>'g', 'IMJG'=>'j', 'IORR'=>'b', 'LKDT'=>'d', 'LKIF'=>'u', 'LTDY'=>'d',
'MAL1'=>'s', 'MARK'=>'u', 'MEM1'=>'s', 'MLAD'=>'s', 'MLCC'=>'s', 'MLFM'=>'s',
'MLID'=>'u', 'MLRP'=>'s', 'MLTO'=>'u', 'MPFB'=>'s', 'NAME'=>'s', 'NAPR'=>'s',
'NMSK'=>'s', 'OFCE'=>'s', 'OFPR'=>'s', 'OPT1'=>'u', 'OPT2'=>'u', 'PGR1'=>'s',
'POPA'=>'s', 'POPP'=>'s', 'PRBD'=>'u', 'PRF1'=>'u', 'PRTY'=>'u', 'PSTN'=>'s',
'PSWD'=>'s', 'RCCK'=>'b', 'RDCK'=>'b', 'RMRK'=>'s', 'RVTM'=>'u', 'SBJT'=>'u',
'SCCP'=>'s', 'SCTG'=>'u', 'SCTN'=>'s', 'SDDT'=>'d', 'SDTM'=>'u', 'SPKS'=>'s',
'STDY'=>'d', 'SVAD'=>'s', 'TCPS'=>'u', 'TEL1'=>'s', 'TEL2'=>'s', 'TIM1'=>'d',
'TIM2'=>'d', 'TITL'=>'s', 'TMNL'=>'u', 'USID'=>'s', 'XLIF'=>'u', 'ZCCP'=>'s',
'ZIP2'=>'s', 'ZIPC'=>'s', 'ZPKS'=>'s', 'ZRTF'=>'u', 'ZXLS'=>'u', 'mDTM'=>'d',
'mISC'=>'u', 'tPID'=>'u',
);

my %item_name = (
    'FNDY'=>'finish-date',
    'ETDY'=>'start-date',
    'LTDY'=>'deadline',
    'STDY'=>'start-date',
    'ADR1'=>'home-address',
    'ADR2'=>'address',
    'ANN1'=>'anniversary',
    'BRTH'=>'birth',
    'CLAS'=>'class',
    'CPS1'=>'mobile-tel',
    'DNS1'=>'DNS 1',
    'DNS2'=>'DNS 2',
    'EDTM'=>'edit-time',
    'FAX1'=>'home-fax',
    'FAX2'=>'fax',
    'HTXT'=>'hand-text',
    'IMG1'=>'image',
    'IMGF'=>'gif',
    'IMJG'=>'jpg',
    'LKDT'=>'link-date',
    'MAL1'=>'mail',
    'MEM1'=>'memo',
    'MLAD'=>'mail-adderess',
    'MLTO'=>'mail-to',
    'NAME'=>'name',
    'NAPR'=>'name-yomi',
    'NMSK'=>'mask',
    'OFCE'=>'office',
    'OFPR'=>'office-yomi',
    'POPA'=>'pop 1',
    'POPP'=>'pop p',
    'PSTN'=>'position',
    'PSWD'=>'password',
    'RMRK'=>'remark',
    'SCCP'=>'sccp',
    'SCTN'=>'section',
    'SDTM'=>'sdtm',
    'SPKS'=>'spks',
    'SVAD'=>'cvad',
    'TEL1'=>'home-tel',
    'TEL2'=>'tel',
    'TIM1'=>'date',
    'TIM2'=>'end-date',
    'TITL'=>'title',
    'USID'=>'user id',
    'ZCCP'=>'zccp',
    'ZIP2'=>'home-zip',
    'ZIPC'=>'zip',
    'ZPKS'=>'packats',
    'mDTM'=>'modify-date',
);


sub Zaurus_initialize {
    my ($self) = @_;
    $self->{'-item_type'} = \%item_type;
    $self->{'-item_name'} = \%item_name;
    $self->{'-offset'} = 8;
}

# ザウルスのBOX形式に格納されている属性名リストの取出

sub item_list {
    my ($self,$data) = @_;
    my ($value,@index);
    my ($debug) = $self->{'-debug'};

    my $title_offset;
    my $title_len = 0;
    my $field_offset;

    my $version = unpack("n",substr($data,2,2));
    $self->{'-zaurus-version'} = $version;
    # $title_offset += ($version < 0x1030)?2:0;

    if ($version <= 0x1002 ) {
	$title_offset = 0x15;
	$self->{'-title-begin'} = $title_offset;
	$field_offset = 1;
    } elsif ($version < 0x1030 ) {
	$title_offset =  unpack("V",substr($data,0x8,4));
	$self->{'-title-begin'} = $title_offset;
	$title_offset += 2;
	$field_offset = 2;
    } else {
	$title_offset =  unpack("V",substr($data,0x8,4));
	$self->{'-title-begin'} = $title_offset;
	$field_offset = 2;
    }

    my $title_count =  ord(substr($data,$title_offset,1));
    my $ptr = $title_offset+1;
    my $i = 0;
    print "\n\nfile:",$self->{'-file'},"\n\n"
        if ($debug && defined ($self->{'-file'}));
    while($title_count-->0) {
	my $item_len =  ord(substr($data,$ptr,1));
	$ptr += 2;
	# print "item: ",unpack("H*",substr($data,$ptr,$item_len)) if ($debug);
	my $id = $self->{'-item_id'}->[$i] = substr($data,$ptr+$field_offset,4);
	my $name = $self->{'-item_name1'}->[$i] =
		substr($data,$ptr+5,$item_len-5);
	print "list:\t$i:$id:$item_len:$name\n" if ($debug);
	$ptr += $item_len;
	$i++;
    }
    print "title-len: $version $title_len ",$ptr - $title_offset,"\n" if ($debug);
    $self->{'-item_name_count'} = $i;
    $self->{'-title-length'} = $ptr-$title_offset;
}


#######################################################################/

package Calcon::Zaurus_read ;

# BOX 形式からの読み込み

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ('Calcon::Zaurus', 'Calcon::Reader');

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    $self->Zaurus_initialize();

    $self->{'-debug'} = 0;
    $self->{'-offset'} = 8;
    $self->{'-all'} = 0;
    $self->{'-item_list'} = '';  # '' or 'original' or 'id'
}

sub read {
    my ($self,$file) = @_;

    $self->{'-file'} = $file;
    open(F,"<".$file);

    local($/) ;
    undef $/;
    my $data = <F>;
    $data;
}

sub decode {
    my ($self,$file) = @_;
    my ($debug) = $self->{'-debug'};
    my $out = $self->{'-output'};

    my $data = $self -> read($file);
    $self -> item_list($data);
    $out->start_file($file);
    print "Zaurus version: $self->{'-zaurus-version'}\n" if ($debug);
    if ($self->{'-zaurus-version'} <= 0x1002) {
	$self->decode_old_data($data);
    } elsif ($self->{'-zaurus-version'} == 0x1030) {
	$self->{'-offset'} = 10;
	$self->decode_data($data);
    } else {
	$self->decode_data($data);
    }
    $out->end_file($file);
}

# 複雑なIndexの処理

sub decode_index {
    my ($self,$data) = @_;
    my ($debug) = $self->{'-debug'};

    my ($length) =  unpack("V",substr($data,0x10,4));
    if ($self->{'-zaurus-version'} eq 0x1030) {
	$length =  unpack("V",substr($data,0x8,4));
    }
    my $offset = 0x50;
    my ($value,@index);
    my $i;
    my $flag;

    do {
	for($i=$offset;$i<$length;$i+=4) {
	    $value = unpack("V",substr($data,$i,4));
	    next if ($value == 0xffffffff);
	    push(@index,$value) if ($value);
	}
	$offset = $value;
	$flag = unpack("v",substr($data,$offset,2));

	printf "next index %0x: %0x\n",$offset,"" if ($debug);
	printf "flag: %0x\n",$flag if ($debug);

	if ($self->{'-zaurus-version'} eq 0x1030) {
	    $length = unpack("V",substr($data,$offset+2,4));
	    $offset = $offset+6;
	    $length += $offset;
	} else {
	    $length = unpack("v",substr($data,$offset+2,2));
	    $offset = $offset+5;
	    $length += $offset;
	}
	printf "next index length %0x\n",$length if ($debug);

    } while ($flag == 0xfff0);

    return @index;
}

# BOX形式の中のレコードの処理

sub decode_data {
    my ($self,$data) = @_;
    my ($offset) = $self->{'-offset'};
    my ($debug) = $self->{'-debug'};

    my(@index) = $self->decode_index($data);

    foreach my $index (@index) {
	printf "index %0x: %s\n",$index,"" if ($debug);

	last if (length(substr($data,$index,2))<2);
	next if (substr($data,$index,2) eq "\xf0\xff");

	my $record_number=ord(substr($data,$index,1)) +
	    ord(substr($data,$index+1,1))*256;
	my $record_len=ord(substr($data,$index+2,1)) +
	    ord(substr($data,$index+3,1))*256;

	my $item_count=ord(substr($data,$index+6,1));
	my $item_dummy=ord(substr($data,$index+10,1));

	my @len = ();
	my $ptr = $index + $offset;
	my $total_len = 0;
        my $k = 1;
        for(my $j=$self->{'-item_name_count'}; $j>0; $j--) {
	    my $i=ord(substr($data,$ptr,1));
	    if ($i>=0x80) {
		$ptr++;
		$i = ord(substr($data,$ptr,1))+($i-0x80)*256;
	    }
	    print "len:$k:  $i\n" if ($debug);
	    $k++;
	    push(@len,$i);
	    $total_len += $i;
	    $ptr++;
	}
	printf "offset: %x\n",$ptr-$index if ($debug);

	# $ptr = $index+40+$item_dummy; should be this kind of method...
	# $ptr = $index+$record_len-$total_len+5;
	# $ptr = $index+8+$item_count;


	print "head: ",unpack("H*",substr($data,$index,50)),"\n" if ($debug);
	print "body: ",unpack("H*",substr($data,$ptr,50)),"\n" if ($debug);

	my $i = 0;
	my $record = $self->make_record;
	my @key_list = ();
	foreach my $len (@len) {
	    my ($key,$item,$type) =
		$self->decode_item($i,substr($data,$ptr,$len));
	    if ($item) {
		if ($type eq 's' || $type eq 'd') {
		    push(@key_list,$key);
		    $record->{$key} = $item;
		} elsif ($self->{'-all'}) {
		    push(@key_list,$key);
		    $record->{$key} = $type.":".unpack("H*",$item);
		}
	    }
	    $i++;
	    $ptr += $len;
	}
	$self->date_normalize(\@key_list,$record);
	$self->{'-output'}->record(\@key_list,$record);
	print "\n" if ($debug);;
    }
}

# たぶん、PI-7000以前の形式

sub decode_old_data {
    my ($self,$data) = @_;
    my $debug = $self->{'-debug'};
    my @len = ();
    my $ptr = $self->{'-title-begin'} + $self->{'-title-length'};

    my $old_number = 0;
    while(1) {
	my $record = $self->make_record;
	my @key_list = ();

	# my $record_number = ord(substr($data,$ptr++,1));
	my $record_number = unpack("v",substr($data,$ptr,2));
	my $optr = $ptr;
	while ($record_number != $old_number+1) {
	    # $record_number = ord(substr($data,$ptr++,1));
            $ptr += 1;
	    $record_number = unpack("v",substr($data,$ptr,2));
	    return if ($ptr>length($data));
	}
	print "offset: ",$ptr-$optr,"\n" if ($debug && $optr<$ptr);
        $ptr += 2;
	my $record_length = unpack("v",substr($data,$ptr,2));
	$ptr += 2;
	print "record_number:  $record_number\n" if ($debug);
	print "record_length:  $record_length\n" if ($debug);
	$old_number = $record_number;
	# last if ($record_length == 0);
	my $record_end = $optr + $record_length+4; # - 3;
	my $i = 0;
	$ptr+=2;
        for(my $j=$self->{'-item_name_count'}; $j>0; $j--) {
	# while($ptr < $record_end) {
	    my $len=ord(substr($data,$ptr++,1));
	    if ($len>=0x80) {
		$len = ord(substr($data,$ptr,1))+($len-0x80)*256;
		$ptr++;
	    }
	    print "len:  $len\n" if ($debug);
	    print "data: ",substr($data,$ptr,$len),"\n" if ($debug);
	    my ($key,$item,$type) =
		$self->decode_item($i,substr($data,$ptr,$len));
	    if ($item) {
		if ($type eq 's' || $type eq 'd') {
		    push(@key_list,$key);
		    $record->{$key} = $item;
		} elsif ($self->{'-all'}) {
		    push(@key_list,$key);
		    $record->{$key} = $type.":".unpack("H*",$item);
		}
	    }
	    $i++;
	    $ptr += $len;
	}
	if ($debug && $ptr != $record_end) {
	    print "record_end: $ptr $record_end\n";
	}
	$ptr = $record_end;
	print "\n" if ($debug);;
	$self->date_normalize(\@key_list,$record);
	$self->{'-output'}->record(\@key_list,$record);
        # }
    }
}

sub decode_time {
    my ($self,$t) = @_;

    return '' if (! $t);
    # print unpack("H*",substr($t,1,4)),"\n";

    $t = hex(unpack("H*",substr($t,1,4)));
    my $year =  ($t&0x0000000f)*16 ;
    $year +=   (($t&0x0000f000)>>12) + 1900;
    my $month = ($t&0x00000f00)>>8;
    my $day =   ($t&0x00f80000)>>19;
    my $min =   ($t&0x3f000000)>>24;
    my $hour =((($t&0xc0000000)>>30)&0x3)<<0;
    $hour +=   (($t&0x00070000)>>16)<<2;
    if ($year == 2155) { # unspecified case
	$t = sprintf("%d/%d",$month,$day);
    } else {
	$t = sprintf("%04d/%d/%d",$year,$month,$day);
    }
    if($min!=63) {
        $t .= sprintf(" %02d:%02d",$hour,$min);
    }
    $t;
}

# Zaurus レコード中の可変長データを属性名とともに変換する。

sub decode_item {
    my ($self,$i,$item) = @_;
    my $all = $self->{'-all'};
    my $debug = $self->{'-debug'};

    return if (! $item);
    # print $self->{'-item_id'}->[$i],": ",unpack("H*",$item),"\n";
    my $id_name =  $self->{'-item_id'}->[$i];
    my $id_type =  $self->{'-item_type'}->{$id_name};

    if ($self->{'-item_list'} eq 'original') {
	$id_name = $self->{'-item_name1'}->[$i];
    } elsif ($self->{'-item_list'} eq 'id') {
    } elsif (defined $self->{'-item_name'}->{$id_name}) {
	$id_name = $self->{'-item_name'}->{$id_name};
    }

    if ( $id_type eq 'd' ) {
	$item = $self->decode_time($item);
    }
    return ($id_name,$item,$id_type);
}

#######################################################################/

package Calcon::Pool;

# 差分などを取るための中間的なレコードバッファ
# Unix の pipe みたいに使う
# Writer/Reader を両方継承すべきかも知れない。けど、今のところ、Reader
# を継承する利点は無い。decode ではなく、output を呼ぶ。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use NKF;
@ISA = ('Calcon::Writer');
# This also has Reader interface.

sub record {
    my ($self,$keys,$record) = @_;

    if(defined($record->{'name'})) {
	$self->address($keys,$record);
    } elsif(defined($record->{'date'})) {
	if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); }
	$self->calendar($keys,$record);
    } else {
	# I don't know.
    }
}

sub address {
    my ($self,$keys,$record) = @_;
    push(@{$self->{'-address-index'}->{$record->{'name'}}},$record);
}

sub calendar {
    my ($self,$keys,$record) = @_;
    push(@{$self->{'-date-index'}->{$record->{'date'}->unix_time()}},$record);
}

sub set_contents {
    my ($self,$address,$calendar) = @_;
    $self->{'-date-index'} = $calendar;
    $self->{'-address-index'} = $address;
}

sub contents {
    my ($self) = @_;
    return ( $self->{'-date-index'}, $self->{'-address-index'});
}

# Reader インターフェースの部分

sub set_output {
    my ($self,$out) = @_;
    $self->{'-output'} = $out;
}

sub output {
    my ($self,$out) = @_;

    $self->{'-output'} = $out;
    $self->{'-output'}->start_file();
    $self->write_datebook();
    $self->write_addressbook();
    $self->{'-output'}->end_file();
}

sub write_datebook {
    my ($self) = @_;
    for my $date ( sort {$a<=>$b} keys %{$self->{'-date-index'}} ) {
	for my $record ( @{$self->{'-date-index'}->{$date}} ) {
	    my @keys = keys %{$record};
	    $self->{'-output'}->record(\@keys,$record);
	}
    }
}

sub write_addressbook {
    my ($self) = @_;
    for my $adr ( keys %{$self->{'-address-index'}} ) {
	for my $record ( @{$self->{'-address-index'}->{$adr}} ) {
	    my @keys = keys %{$record};
	    $self->{'-output'}->record(\@keys,$record);
	}
    }
}

# 自分自身のクラスを切替えることで動作モードを切替える

sub delete_mode {
    my ($self) = @_;
    bless $self,'Calcon::Pool::delete';
}

sub merge_mode {
    my ($self) = @_;
    bless $self,'Calcon::Pool::merge';
}

sub input_mode {
    my ($self) = @_;
    bless $self,'Calcon::Pool';
}

# 以下のルーチンは、たぶん、Record クラスにあるべき

sub same_record_in_list {
    my ($self,$list,$record) = @_;
# print "\nCampare: ";$record->value;
    record:
    for (my $i = 0; $i<=$#{$list}; $i++) {
	my $r = $list->[$i];
# print "\nList: ";$r->value;
	next if (! $record->equal($r));
# print "\nResult: $i\n";
	return $i;
    }
# print "\nResult: -1\n";
    return -1;
}

#######################################################################/

package Calcon::Pool::delete;

# 自分のPoolから、与えれたレコードを削除する。差分計算。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use NKF;
@ISA = ('Calcon::Pool');

sub address {
    my ($self,$keys,$record) = @_;
    my $name = $record->{'name'};
    if (my $list = $self->{'-address-index'}->{$name}) {
	my $i;
	if (($i = $self->same_record_in_list($list,$record)) >= 0 ) {
	    splice(@{$list},$i,1);
	    if (! @$list) {
		delete $self->{'-address-index'}->{$name};
	    }
	}
    }
}

sub calendar {
    my ($self,$keys,$record) = @_;
    my $date = $record->{'date'}->unix_time();
    if (my $list = $self->{'-date-index'}->{$date}) {
	my $i;
	if (($i = $self->same_record_in_list($list,$record)) >= 0 ) {
	    splice(@{$list},$i,1);
	    if (! @$list) {
		delete $self->{'-date-index'}->{$date};
	    }
	}
    }
}

#######################################################################/

package Calcon::Pool::merge;

# Pool にないレコードだったら、そのレコードを付け加える。
# 中身を見て、必要な情報のみを付け加える方が良い。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use NKF;
@ISA = ('Calcon::Pool');

sub address {
    my ($self,$keys,$record) = @_;
    my $name = $record->{'name'};
    if (my $list = $self->{'-address-index'}->{$name}) {
	my $i;
	if (($i = $self->same_record_in_list($list,$record)) >= 0 ) {
	    return;
	}
	push(@$list,$record);
    } else {
	push(@{$self->{'-address-index'}->{$name}},$record);
    }
}

sub calendar {
    my ($self,$keys,$record) = @_;
    my $date = $record->{'date'}->unix_time();
    my $list = $self->{'-date-index'}->{$date};
    if ($list) {
	my $r;
	return unless ($r = $self->new_info($list,$record));
	push(@$list,$r);
    } else {
	push(@{$self->{'-date-index'}->{$date}},$record);
    }
}


#######################################################################/

package Calcon::Buffered_Writer;

# 変換前にすべてを読み込む必要がある形式のために使うクラス。
# データの先頭に総レコード数を持つ形式とか。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use NKF;
@ISA = ('Calcon::Writer');

#
# Some format requires whole record before write, because of
# record count or sorted order. This plugin class perform
# reading and queueing.
#
# write_datebook or write_address_book should be overwrited.
#

sub record {
    my ($self,$keys,$record) = @_;

    if(defined($record->{'name'})) {
	$self->{'-adr-max'}++;
	$self->address($keys,$record);
    } elsif(defined($record->{'date'})) {
	if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); }
	$self->{'-date-max'}++;
	$self->calendar($keys,$record);
    } else {
	# I don't know.
    }
}

sub address {
    my ($self,$keys,$record) = @_;
    push(@{$self->{'-address-records'}}, $record);
}

sub calendar {
    my ($self,$keys,$record) = @_;
    push(@{$self->{'-date-records'}}, $record);
}

sub end_file {
    my ($self) = @_;
    $self->write_datebook() if ( defined($self->{'-date-max'}));
    $self->write_addressbook() if ( defined($self->{'-adr-max'}));
}

sub write_datebook {
    my ($self) = @_;
    my $count = $self->{'-date-max'};
    for my $dates ( @{$self->{'-date-records'}} ) {
    }
}

sub write_addressbook {
    my ($self) = @_;
    my $count = $self->{'-adr-max'};
    for my $adr ( @{$self->{'-address-records'}} ) {
    }
}


#######################################################################/

package Calcon::Zaurus_backup_read ;

# ザウルスのバックアップ形式

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ( 'Calcon::Zaurus_read' );

sub decode {
    my ($self,$backup) = @_;
    my $out = $self->{'-output'};

    my $data = $self->backup_read($backup);

    foreach my $file ( $self->backup_files($data) ) {
	next if ($file !~ /BOX$/);
	$self->SUPER::decode($file);
    }
}

sub backup_files {
    my ($self,$data) = @_;
    if ($data =~ /^\032*PABAK/) {
	return $self->text_backup($data);
    } else {
	return $self->ztar($data);
    }
}

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();

# alphabet encoding
#
# 0-5        "0".."5"
# 6-0x1f     "A".."Z"
# 0x20-0x25  "6"..";"
# 0x26-0x3f  "a".."z"
#
# make character replacement code
#
    my $ya = '';
    my $yb = '';
    for(my $i=0;$i<0x40;$i++) {
	if( $i <= 0x05 ) { $ya .= pack("C",($i + 0x30));}
	elsif( $i <= 0x1f ) { $ya .= pack("C",($i + 0x3b));}
	elsif( $i <= 0x25 ) { $ya .= pack("C",($i + 0x16));}
	else { $ya .= pack("C",($i + 0x3b)); }
    # since . never matches \n, 0x40 is added
	$yb .= sprintf("\\%03o",$i+0x40);
    }
    eval "sub a_decode \{ y\/" . $ya . "/" . $yb . "/;}\n";
    eval "sub a_encode \{ y\/" . $yb . "/" . $ya . "/;}\n";

}

sub read {
    my ($self,$file) = @_;
    return $self->{'-files'}->{$file};
}

##########################################################
#
# Zaurus Binary Encoding
#
##########################################################

# bit encoding
# s/..../&decode($&)/eg;
# 76543210765432107654321076543210
# 00      11      22        001122
# 33221100332211003322110033221100
# 00      11      22        001122

sub bit_decode {
    my $bit = substr($_[0],0,3);
    vec($bit, 3,2) =  vec($_[0],14,2);
    vec($bit, 7,2) =  vec($_[0],13,2);
    vec($bit,11,2) =  vec($_[0],12,2);
    return $bit;
}

sub bit_encode {
    my $bit = $_[0];
    vec($bit,14,2) = vec($bit, 3,2);
    vec($bit,13,2) = vec($bit, 7,2);
    vec($bit,12,2) = vec($bit,11,2);
# since . never matches \n, 0x40 is added
    vec($bit,11,2) = vec($bit,7,2) = vec($bit,3,2) = 1;
    return $bit;
}

sub z_encode {
    my ($i);
    $i = (length()%3);
    $_ .= "\0" x (3-$i) if($i);
    s/.../&bit_encode($&)/eg;
    &a_encode;
}

sub z_decode {
    my ($i);
    s/\s//g;
    &a_decode;
    $i = (length()%4);
    $_ .= "\0" x (4-$i) if($i);
    s/..../&bit_decode($&)/eg;
}

sub text_backup {
    my ($self,$data) = @_;
    my $debug = $self->{'-debug'};
    my (@names,@size);

    print("\nBackup Directory\n") if ($debug);

    $data =~ s/^\032*PABAK.*\n([^\032]*\032)//;
    $_ = $1;
    &z_decode;
    my @title = (); my @attr = ();
    my $len = length($_) - 20; my $j = 0;
    for(my $i=6;$i<$len;$i+=20) {
	$title[$j] = substr($_,$i,12);
	$attr[$j] = unpack("H*",substr($_,$i+12,5));
	$size[$j] = (ord(substr($_,$i+17,1))
	     +ord(substr($_,$i+18,1))*0x100
	     +ord(substr($_,$i+19,1))*0x10000);
	print($title[$j]."\t") if ($debug);
	print($attr[$j]."\t") if ($debug);
	print($size[$j]."\n") if ($debug);
	$j++;
    }
    my $i = 0;
    foreach (split(/\032/,$data)) {
	s/^PABAK.*\n//;
        &z_decode;
	$self->{'-files'}->{$title[$i++]} = $_;
    }
    return @title;
}

sub ztar {
    my ($self,$data) = @_;
    my $debug = $self->{'-debug'};
    my (@names,@size);
    my $ptr = 0;

    $_ = substr($data,0,16);
    $ptr += 16;
    my $count = unpack("V",substr($_,4,4));

    print unpack("H*",substr($_,0,8)),"\n" if ($debug);
    for ( my $i = 0; $i<$count ; $i++ ) {
	$_ = substr($data,$ptr,24); $ptr+=24;
	last if (substr($_,0,1) eq "\xff");
	my $name = substr($_,0,12); $name =~ s/\0.*//;
	print "name: $name\n" if ($debug);
	push(@names,$name);
	my $size = unpack("V",substr($_,12,4));
	print "size: $size\n" if ($debug);
	push(@size,$size);
	print unpack("H*",substr($_,12)),"\n" if ($debug);
    }

    for ( my $i = 0; $i<$count ; $i++ ) {
	$_ = substr($data,$ptr,$size[$i]); $ptr+=$size[$i];
	my $name = $names[$i];
	$self->{'-files'}->{$name} = $_;
    }
    return @names;
}

sub backup_read {
    my ($self,$file) = @_;

    $self->{'-file'} = $file;
    open(F,"<".$file);
    local($/) ;
    undef $/;
    my $data = <F>;
    $data;
}


#######################################################################/

package Calcon::iApp_read;

# iCal/AddressBook からAppleScript 経由で読み込む。なので、
# Mac::AppleScript が必要。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Mac::AppleScript qw(RunAppleScript);
use NKF;
@ISA = ( 'Calcon::File_read' ) ;

# We use Applescript, but it is very slow.

my $tell;

my %record_keys = (
    "phone電話"=>"tel",
    "phoneファックス"=>"fax",
    "emailメール"=>"mail",
    "address住所"=>"address",
);

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    $self->{'-labels'} = \%record_keys;
}

sub decode {
    my ($self,$file) = @_;
    my ($debug) = $self->{'-debug'};
    my $out = $self->{'-output'};
    my $record;
    my $keys;

    $out->start_file('');
    $self->get_all_event() if (! $self->{'-address-only'});
    $self->get_all_contact() if (! $self->{'-calendar-only'});
    $out->end_file('');

}

sub date {
    my ($self,$date)=@_;
    my @date = ($date =~ /(\d+)/g);
    if ($date =~ /PM$/) {
	if ($date[3]==12) { $date[3]=0;}
	$date[3]+=12;
    }
    return $self->make_date("$date[0]/$date[1]/$date[2] $date[3]:$date[4]");
}


sub property {
    my ($self,$contact,$id,$property,$record,$key) = @_;
    my $result;
    $result = RunAppleScript("${tell}${property} of ${contact} $id\nend tell\n");
    # it looks like apple event returns some garbage
    $result =~ s/^\"//; $result =~ s/\"$//; $result =~ s/\001.*$//;
    if (defined($record) && $result ne '') {
	if ($key =~ /date/ || $key =~ /birth/) {
	    $record->{$key} = $self->date($result);
	} else {
	    $record->{$key} = nkf('-eS',$result);
	}
    } else {
        nkf('-eS',$result);
    }
}

sub address {
    my($self,$id,$vid,$phone,$record) = @_;

    my ($street , $zip , $state , $country , $city);
    $street = $zip = $state = $country = $city = '';
    my $address = RunAppleScript("${tell}properties of ${phone} $vid of person $id\nend tell\n");

# {zip:missing value, label:"住所", state:missing value, street:"那覇市久茂地3-21-1", country code:missing value, country:missing value, id:"AFBD61FE-FB17-11D6-A84E-0003936AC938", city:missing value, class:address}

    $address =~ s/^\"//; $address =~ s/\"$//;
    $address =~ s/\001.*$//;
    $address =~ s/\002.*?"/"/;
    $address = nkf('-eS',$address);

    # my ($street , $zip , $state , $country , $city);
    $address =~ /street:"([^"]*)"/ && ($street = $1);
    $address =~ /zip:"([^"]*)"/ && ($zip = $1);
    $address =~ /state:"([^"]*)"/ && ($state = $1);
    $address =~ /city:"([^"]*)"/ && ($city = $1);
    $address =~ /country:"([^"]*)"/ && ($country = $1);

    my ($label) = ($address =~ /label:"(.*?)"/);
    if (! defined($self->{'-labels'}->{$phone.$label})) {
        print "## $phone$label not defined\n";
    } else {
	$record->{$self->{'-labels'}->{$phone.$label}} =
	    "$state $city $street $country"
	    if ($state||$city||$street||$country);
	if ($zip && $self->{'-labels'}->{$phone.$label} =~ /home/) {
	    $record->{'home-zip'} = $zip;
	} else {
	    $record->{'zip'} = $zip if ($zip);
	}
    }
}

sub value {
    my($self,$id,$vid,$phone,$record) = @_;
    my $result  = RunAppleScript("${tell}properties of ${phone} $vid of person $id\nend tell\n");
    $result =~ s/^\"//; $result =~ s/\"$//; $result =~ s/\001.*$//;
    $result = nkf('-eS',$result);
    my ($value,$label) = ($result =~ /value:"(.*?)".*label:"(.*?)"/);
    if (! defined($self->{'-labels'}->{$phone.$label})) {
        print "## $phone$label not defined\n";
    } else {
	$record->{$self->{'-labels'}->{$phone.$label}} = $value;
    }
}


sub get_all_contact {
    my ($self) = @_;
    $tell = "tell application \"Address Book\"\n";

    my $count = RunAppleScript("${tell}count of person\nend tell\n");
    foreach my $id ( 1..$count ) {
	$self->person($id);
    }
}

sub person {
    my ($self,$id) = @_;
    my $record = {};

    my $phone_count  = RunAppleScript("${tell}count of phone of person $id\nend tell\n");
    foreach my $phone_id ( 1..$phone_count ) {
	$self->value($id,$phone_id,'phone',$record);
    }

    my $email_count  = RunAppleScript("${tell}count of email of person $id\nend tell\n");
    foreach my $email_id ( 1..$email_count ) {
	$self->value($id,$email_id,'email',$record);
    }

    my $address_count  = RunAppleScript("${tell}count of address of person $id\nend tell\n");
    foreach my $address_id ( 1..$address_count ) {
	$self->address($id,$address_id,'address',$record);
    }

    my $name = $self->property('person',$id,'last name');
    my $first_name = $self->property('person',$id,'first name');
    $record->{'name'} = ($name && $first_name)?"$name $first_name":
	($name)?$name:$first_name;

    my $name_p = $self->property('person',$id,'phonetic last name');
    my $first_name_p = $self->property('person',$id,'phonetic first name');
    $record->{'name-yomi'} = ($name_p && $first_name_p)?"$name_p $first_name_p":
	($name_p)?$name_p:$first_name_p;

    $self->property('person',$id,'job title',$record,'section');
    $self->property('person',$id,'title',$record,'title');

    #       $self->property('person',$id,'birth date',$record,'birth');
    $self->property('person',$id,'organization',$record,'office');
    my $keys = [];
    push(@$keys,keys %{$record});

    my $out = $self->{'-output'};
    $out->record($keys,$record);
}


sub get_all_event {
    my ($self) = @_;

    $tell = "tell application \"iCal\"\n";
    if ($self->{'-future-only'}) {
	my $today = $self->today();
        my ($year,$mon,$mday,$hour,$min) = $today->localtime();
	my $count = RunAppleScript("${tell}uid of every event of last calendar whose start date > date \"$year/$mon/$mday\"\nend tell\n");
	for my $id ($count =~ /("[^"]*")/g) {
	    $self->uid_event($id);
	}
    } else {
	my $count = RunAppleScript("${tell}count of event of last calendar\nend tell\n");
	for(my $id=1; $id <= $count ;$id++) {
	    $self->event($id);
	}
    }
}

sub uid_event {
    my ($self,$id) = @_;
    my $record = $self->make_record;

    # $self->property('event',$id,'all day event',$record,'all-day');
    $self->property('some event of last calendar whose uid is',$id,'start date',$record,'date');
    $self->property('some event of last calendar whose uid is',$id,'end date',$record,'end-date');
    $self->property('some event of last calendar whose uid is',$id,'summary',$record,'summary');
    $self->property('some event of last calendar whose uid is',$id,'description',$record,'memo');
    my $keys = [];
    push(@$keys,keys %{$record});

    my $out = $self->{'-output'};
    $out->record($keys,$record);
}

sub event {
    my ($self,$id) = @_;
    my $record = $self->make_record;

    # $self->property('event',$id,'all day event',$record,'all-day');
    $self->property('event',$id." of last calendar",'start date',$record,'date');
    $self->property('event',$id." of last calendar",'end date',$record,'end-date');
    $self->property('event',$id." of last calendar",'summary',$record,'summary');
    $self->property('event',$id." of last calendar",'description',$record,'memo');
    my $keys = [];
    push(@$keys,keys %{$record});

    my $out = $self->{'-output'};
    $out->record($keys,$record);
}


#######################################################################/

package Calcon::iApp_write ;

# AppleScript 経由で iCal/AddressBook に書き出す。この実装では、
# Mac::AppleScript はいらない

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use NKF;
use Carp;

@ISA = ( 'Calcon::Writer' );

sub initialize {
    my ($self) = @_;

    $self->SUPER::initialize();
    if (defined $self->{'-file'}) {
	$self->{'-file-out'} = 1;
    } else {
	if (defined $self->{'-file-out'}) {
	    $self->{'-file'} = "script-out";
	}
    }

    $self->{'-fake-allday'} = 1;
    $self->{'-time-for-allday'} = 12*3600;
    $self->{'-add-time-for-allday'} = 2*3600;

    $self->{'-check-script'} = 1;
    $self->{'-check-group'} = 20;
    $self->{'-do-grouping'} = 1;

#    | perl -pe 's/[\177-\377]/sprintf "\\%03o",ord($&)/eg;'
#    | perl -pe 's/\\(\d\d\d)/sprintf "%c",oct($&)/eg;'

    $self->{"-phone-labels"} = {
	"tel"=>"電話",
	"tel-home"=>"自宅電話",
	"mobile-tel"=>"携帯",
	"home-fax"=>"自宅ファックス",
	"fax"=>"ファックス",

    };
    $self->{"-mail-labels"} = {
	"mail"=>"メール",
	"mail-to"=>"メール2",
	"mail-address"=>"メール3",

    };
    $self->{"-address-labels"} = {
	"address"=>"住所",
	"home-address"=>"自宅住所",
    };
    $self->{"-zip-labels"} = {
	"zip"=>"郵便番号",
	"home-zip"=>"自宅郵便番号",
    };
    $self->{'-groups'} = {};
    $self->{'-init-file'} = "s000000";
    $self->{'-check-script-count'} = 0;
    $self->{'-script-name'} =  $self->{'-init-file'};

}

sub start_file {
    my ($self,$type) = @_;
    undef $self->{'-application'};
    if ($self->{'-file-out'}) {
	mkdir $self->{'-file'};
    }
}

sub end_file {
    my ($self,$type) = @_;
    $self->close();
    $self->{'-telling'} = 0;
    if ($self->{'-file-out'}) {
	$self->make_group();
	while(<script-out/*.script>) {
	    my $out = $_;
	    $out =~ s/\.script$/.compile/;
	    print STDERR "osacompile -o $out $_\n";
	    # system "osacompile -o $out $_";
	    # system "osascript $out";
	}
    }
}

sub start_record {
    my ($self,$type) = @_;

    if ($self->{'-check-script'}) {
	my $i = $self->{'-check-script-count'}++;
	if ($i % $self->{'-check-group'}==0) {
	    my $d = $self->{'-script-name'}++;
	    $self->close() if ( $self->{'-telling'} );
	    $self->{'-telling'} = 0;
            if (1) {
	    if ($self->{'-file-out'}) {
		open OUT,"> script-out/$d.script" or croak($!);
	    } else {
		print STDERR "doing $i\n";
		open OUT,"| osascript " or cloak($!);
	    }
            } else {
	    if ($self->{'-file-out'}) {
		open OUT,"> script-out/$d.script" or croak($!);
	    } else {
		print STDERR "doing $i\n";
		open OUT,"| osascript " or cloak($!);
	    }
            }
	    select OUT;
	}
    }
}

sub print {
    my ($self,@data) = @_;
    foreach (@data) {
	my $data = nkf('-s -Z',$_);
	$data =~ s/\354\276/\203_/g;
	$data =~ s/\356\276/  /g;
	$data =~ s/\356\277/  /g;
	$data =~ s/([^\200-\377])\\/$1\200/g;
	# $data =~ s/\201/\/g;
        $data =~ s/\\/\\\\/g;
	print $data;
    }
}

sub record {
    my ($self,$keys,$record) = @_;
    my ($application);

    $self->start_record('');

    # check proper application
    if (defined $record->{'name'}) {
	$application = 'Address Book';
	$self->set_application($application);
	$self->address_book($keys,$record);
	$self->print("end tell\n") if (! $self->{'-check-script'}) ;
    } elsif (defined $record->{'date'}) {
	if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); }
	$application = 'iCal';
	$self->set_application($application);
	$self->ical($keys,$record);
	$self->print("end tell\n") if (! $self->{'-check-script'}) ;
    } else {
	# nothing to do
    }
    $self->print("\n");
}

sub close {
    my ($self) = @_;
    my $application = $self->{'-application'};
    if ($self->{'-check-script'}) {
	if ($application eq "Address Book") {
	    $self->print("--close address\n");
	    $self->print("--close group\n");
	    # $self->print("with transaction\n");
	    $self->print("save addressbook\n");
	    # $self->print("end transaction\n");
	}
	$self->print("quit saving yes\n")
	    if (0 && $self->{'-check-script-count'} % 5 == 4);
	$self->print("end tell\n");
	undef $self->{'-application'};
    }
    $self->{'-telling'} = 0;
}

sub set_application {
    my ($self,$application) = @_;

    if ($application ne $self->{'-application'}) {
	$self->print("end tell\n") if ($self->{'-telling'} );
	$self->{'-application'} = $application;
	$self->print("\ntell Application \"$application\"\n");
	$self->{'-telling'} = 1;
    }
}

sub address_book {
    my ($self,$keys,$record) = @_;
    my @keys = @$keys;
    my %record = %$record;
    my ($tab) = '';


    return if(! defined $record{'name'});
    $tab .= '    ';

    # $self->print("with transaction\n");
    if(defined $record{'office'}) {
	my $group = $record{'office'};
	$self->print($tab,"if not exists some group whose name is ");
	$tab .= '    ';
	$self->print("\"$group\" then \n");
	$self->print($tab,"make new group with properties ");
	$self->print("{name:\"$group\"}\n");
	$tab =~ s/    $//;
	$self->print($tab,"end\n\n");
    }
    $self->print($tab,"set aPerson to make new person with properties {");
    $tab .= '    ';

    my @names;
    my $data =  $record{'name'};
    @names = split(/ +/,$data);

    $self->print("last name: \"",shift(@names),"\",");
    $self->print("first name: \"@names\"}\n");

    $self->print($tab,"tell aPerson\n");
    if(defined $record{'name-yomi'}) {
	if($record{'name-yomi'} =~ /\201H/) {  # ?
	} else {
	    my $data =  $record{'name-yomi'};
	    if ($data =~ /,/) {
		@names = split(/,/,$data);
		$data = $names[1].' '.$names[0];
	    }
	    $data = nkf('-sIZ --hiragana',$data);
	    $data = $self->check_2byte($data);
	    @names = split(/ +/,$data);
            # put one space to prevent a problem of incomplete Shift JIS
	    $self->print($tab,"set phonetic last name to \"",shift(@names)," \"\n");
	    $self->print($tab,"set phonetic first name to \"@names \"\n")
		if (@names);
	}
    }

    if(defined $record{'section'}) {
	$self->print($tab,"set job title to \"$record{'section'}\"\n");
    }
    if(defined $record{'title'}) {
	$self->print($tab,"set title to \"$record{'title'}\"\n");
    }
    foreach my $address ('','home-') {
	my @data = ();
	if(defined $record{$address."address"}) {
	    my $adr = nkf('-s -Z',$record{$address."address"});
	    if($adr=~ s/\201\247\s*(\d+)//) {
		$record{$address.'zip'} = $1;
	    }
	    if($record{$address.'zip'}) {
		push(@data,",zip:\"$self->{'-zip-labels'}->{$record{$address.'zip'}}\"");
	    }
	    $self->add_address($tab,$adr,$address."address",\@data);
	}
    }
    foreach my $phone ('tel','tel-home','mobile-tel','home-fax','fax') {
	if(defined $record{$phone}) {
	    $self->add_phone($tab,$record{$phone},$phone);
	}
    }
    foreach my $mail ('mail','mail-to','mail-address') {
	if(defined $record{$mail}) {
	    $self->add_mail($tab,$record{$mail},$mail);
	}
    }

    if(defined $record{'birth'}) {
	# it looks like Address Book's apple script has trouble with birth date
	# $self->print($tab,"set birth date to ",$self->date($record{'birth'}),"\n");
    }
    if(defined $record{'office'}) {
	$self->print($tab,"set organization to \"$record{'office'}\"\n");
	if ($self->{'-do-grouping'}) {
	    $tab =~ s/    $//;
	    $self->print($tab,"end tell\n");
	    $self->print($tab,"try\n");
	    $tab .= '    ';
	    $self->print($tab,"add aPerson to some group whose name is \"");
	    $self->print($record{'office'},"\"\n");
	    $tab =~ s/    $//;
	    $self->print($tab,"end\n");
	    # $self->print("end transaction\n");
	    $self->{'-groups'}->{$record{'office'}} = 1;;
	    return;
	}
    }
    $tab =~ s/    $//;
    $self->print($tab,"end tell\n");
    # $self->print("end transaction\n");
}

sub check_2byte {
    my ($self,$data) = @_;
    my $new  = '';
    my $tmp;

    while($data) {
	if ($data =~ s/^([\000-\177]*)([\200-\377])//) {
	    $new .= $1; $tmp = $2;
	    if (! $data ) {
	    } elsif ($data =~ /^[!-\376]/) {
		$data =~ s/^.//;
		$new .= $tmp . $&
	    }
	} else {
	    $new .= $data;
	    last;
	}
    }
    $new;
}


sub date {
    my ($self,$date) = @_;
    my ($year,$month,$day,$hour,$min) = $date->localtime();

    $date = "date \"${year}N $month $day j";
    if ($hour) { $date .= " $hour:$min";}
    $date .= "\"";
    return $date;
}

sub add_address {
    my ($self,$tab,$data,$label,$option) = @_;

    $label = nkf('-s',$self->{'-address-labels'}->{$label});
    $self->print($tab,"make new address at end of address of aPerson ");
    $self->print("with properties {street:\"$data\", label:\"$label\"@$option}\n");
}

sub add_phone {
    my ($self,$tab,$data,$label) = @_;

    $label = nkf('-s',$self->{'-phone-labels'}->{$label});
    $self->print($tab,"make new phone at end of phone of aPerson with properties {value:\"$data\", label:\"$label\"}\n");
}

sub add_mail {
    my ($self,$tab,$data,$label) = @_;

    $label = nkf('-s',$self->{'-mail-labels'}->{$label});
    $self->print($tab,"make new email at end of email of aPerson with properties {value:\"$data\", label:\"$label\"}\n");
}

sub make_group {
    my ($self) = @_;
    my (%groups) = %{$self->{'-groups'}};
    my $tab = '    ';

    return if (! %groups);
    open OUT,"> script-out/group.script" or cloak($!);
    select OUT;
    $self->print("tell application \"Address Book\"\n");
    foreach my $group (keys %groups) {
	$self->print($tab,"if not exists some  group whose name is ");
	$tab .= '    ';
	$self->print("\"$group\" then \n");
	$self->print($tab,"make new group with properties ");
	$self->print("{name:\"$group\"}\n");
	$tab =~ s/    $//;
	$self->print($tab,"end\n");
    }
    $self->print("close group\n");
    # $self->print("with transaction\n");
    $self->print("save addressbook\n");
    # $self->print("end transaction\n");
    $self->print("quit saving yes\n");
    $self->print("end tell\n");
}

sub ical {
    my ($self,$keys,$record) = @_;
    my @keys = @$keys;
    my %record = %$record;
    my ($tab) = '';

    # $self->print("with transaction\n");
    # $self->print($tab,"set aDay to ");
    $self->print("make new event at end of event of last calendar with properties {");
    if ($record{'date'}->is_allday() &&  $self->{'-fake-allday'} ) {
	$record{'date'} = $record{'date'}->add($self->{'-time-for-allday'});
	$record{'end-date'} =
	    $record{'date'}->add($self->{'-add-time-for-allday'});
    }
    $self->print($tab,"start date:",$self->date($record{'date'}));
    if (defined $record{'end-date'}) {
        if ($record{'date'}->value() == $record{'end-date'}->value()) {
	    $record{'end-date'} =
		$record{'date'}->add($self->{'-add-time-for-allday'});
	}
	$self->print($tab,",end date:",$self->date($record{'end-date'}))
    }
    $self->print($tab,",stamp date:",$self->date($record{'modify-date'}))
	if (defined $record{'modify-date'});
    if (defined($record{'memo'})) {
	my ($summary,$memo);
	if (defined($record{'summary'})) {
	    $summary = $record{'summary'};
	    $memo = $record{'memo'};
	} else {
	    $summary = $record{'memo'};
	    # if this contains double quote we have a problem. But
	    # I cannot fix it without decoding shift JIS and backslash/0x80
	    # conversion.
	    $summary =~ s/"//g; # oops
	    $summary =~ s/[\r\n].*$//; $memo = $&;
	}

	$self->print($tab,",summary:\"",$summary,"\"") if ($summary);
	$self->print($tab,",description:\"",$memo,"\"") if ($memo);
    }
    $self->print($tab,"}\n");

    # $self->print($tab,"tell aDay\n");
    # $self->print($tab,"if start date = end date then\n");
    # $self->print($tab,"   set end date to start date + ".
    #	int($self->{'-add-time-for-allday'}/60)." * minutes\n");
    # $self->print($tab,"end if\n");
    # $self->print($tab,"end\n");
    # $self->print("end transaction\n");
}

#######################################################################/

package Calcon::Entourage_write ;

# Mac のEntrourage に AppleScript 経由で書き出す。ここでも Mac::AppleScript
# は使わない。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use NKF;
@ISA = ( 'Calcon::iApp_write' );

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();

    $self->{'-fake-allday'} = 0;
    $self->{'-time-for-allday'} = 12*3600;
    $self->{'-add-time-for-allday'} = 2*3600;

    $self->{'-check-script'} = 1;
    $self->{'-check-group'} = 20;

    $self->{'-init-file'} = "s000000";
    $self->{'-check-script-count'} = 0;
    $self->{'-japanese-format'} = 1;
    $self->{'-script-name'} =  $self->{'-init-file'};

    $self->{"-phone-labels"} = {
	"tel"=>"business phone number",
	"tel-home"=>"home phone number",
	"mobile-tel"=>"mobile phone number",
	"home-fax"=>"home fax phone number",
	"fax"=>"business fax phone number",

    };
}

sub record {
    my ($self,$keys,$record) = @_;

    $self->start_record('');

    # check proper application
    if (defined $record->{'name'}) {
	my $application = 'Microsoft Entourage';
	$self->set_application($application);
	$self->contact($keys,$record);
	$self->print("end tell\n") if (! $self->{'-check-script'}) ;
    } elsif (defined $record->{'date'}) {
	if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); }
	my $application = 'Microsoft Entourage';
	$self->set_application($application);
	$self->event($keys,$record);
	$self->print("end tell\n") if (! $self->{'-check-script'}) ;
    } else {
	# nothing to do
    }
    $self->print("\n");
}

sub close {
    my ($self) = @_;
    my $application = $self->{'-application'};
    if ($self->{'-check-script'}) {
	$self->print("quit saving yes\n")
	    if (0 && $self->{'-check-script-count'} % 5 == 4);
	$self->print("end tell\n");
	undef $self->{'-application'};
    }
    $self->{'-telling'} = 0;
}

sub make_group {
}

sub contact {
    my ($self,$keys,$record) = @_;
    my @keys = @$keys;
    my %record = %$record;
    my ($tab) = '';
    my @names;
    my $data =  $record{'name'};
    @names = split(/ +/,$data);

    # $self->print("with transaction\n");
    $tab .= '    ';


    # $self->print("${tab}try\n${tab}set aPerson to some contact whose last name is \"$names[0]\" and first name is \"$names[1]\"\n${tab}on error\n";

    $self->print($tab,"set aPerson to make new contact with properties {");

    $tab .= '    ';

    $self->print($tab,"last name: \"",shift(@names),"\",");
    $self->print($tab,"first name: \"@names\"}\n");
    $tab =~ s/    //;
    # $self->print($tab,"end\n");


    $self->print($tab,"tell aPerson\n");
    if(defined $record{'name-yomi'}) {
	if($record{'name-yomi'} =~ /\201H/) {  # ?
	} else {
	    my $data =  $record{'name-yomi'};
	    if ($data =~ /,/) {
		@names = split(/,/,$data);
		$data = $names[1].' '.$names[0];
	    }
	    $data = nkf('-sIZ --hiragana',$data);
	    $data = $self->check_2byte($data);
	    @names = split(/ +/,$data);
            # put one space to prevent a problem of incomplete Shift JIS
	    $self->print($tab,"set last name furigana to \"",shift(@names)," \"\n");
	    $self->print($tab,"set first name furigana to \"@names \"\n")
		if (@names);
	}
    }

    $self->print($tab,"set japanese format to true\n") if ($self->{'-japanese-format'});
    if(defined $record{'section'}) {
	$self->print($tab,"set department to \"$record{'section'}\"\n");
    }
    if(defined $record{'title'}) {
	$self->print($tab,"set job title to \"$record{'title'}\"\n");
    }
    if(defined $record{'address'}) {
	$self->print($tab,"set business address to {",
           "zip:\"$record{'zip'}\",",
           "street address:\"$record{'address'}\"",
	    "}\n"
	);
    }
    if(defined $record{'home-address'}) {
	$self->print($tab,"set home address to {",
           "zip:\"$record{'home-zip'}\",",
           "street address:\"$record{'home-address'}\"",
	    "}\n"
	);
    }

    foreach my $phone ('tel','tel-home','mobile-tel','home-fax','fax') {
	if(defined $record{$phone}) {
	    $self->print($tab,"set ",$self->{'-phone-labels'}->{$phone},
		" to \"",$record{$phone},"\"\n"
	    );
	}
    }

    # $self->print($tab,"delete every email address of aPerson\n");
    foreach my $mail ('mail','mail-to','mail-address') {
	if(defined $record{$mail}) {
	    foreach my $m (split(/,/,$record{$mail})) {
		$self->print($tab,"make new email address of aPerson with data \"$m\"\n");
	    }
	}
    }

    if(defined $record{'birth'}) {
	$self->print($tab,"set birthday to \"",$self->birth_date($record{'birth'}),"\"\n");
    }
    if(defined $record{'office'}) {
	$self->print($tab,"set company to \"$record{'office'}\"\n");
    }
    if(defined $record{'office-yomi'}) {
	$self->print($tab,"set company furigana to \"$record{'office-yomi'}\"\n");
    }
    $tab =~ s/    $//;
    $self->print($tab,"end tell\n");
    # $self->print("end transaction\n");
}

sub birth_date {
    my ($self,$date) = @_;
    my ($year,$month,$day,$hour,$min) = $date->localtime();

    if (!$year) { $year = '';} else { $year = "$year/"; }
    $date = "$year$month/$day";
    if ($hour) { $date .= " $hour:$min";}
    return $date;
}


sub event {
    my ($self,$keys,$record) = @_;
    my @keys = @$keys;
    my %record = %$record;
    my ($tab) = '';

    # $self->print("with transaction\n");
    # $self->print($tab,"set aDay to ");
    $self->print("make new event with properties {");

#  make new event with properties {subject:"", location:"", content:
# "", start time:date "2002N 11 13 j 0:00:00 PM", end time:date
# "2002N 11 13 j 0:30:00 PM", all day event:false, recurring:false,
# category:{}, links:{}, remind time:1440, recurrence:""}

    if ( $record{'date'}->is_allday()) {
	$self->print($tab,"all day event: true,");
	$self->print($tab,"start time:",$self->date($record{'date'}));
    } else {
	$self->print($tab,"all day event: false,");
	$self->print($tab,"start time:",$self->date($record{'date'}));
	if (defined $record{'end-date'}) {
	    $self->print($tab,",end time:",$self->date($record{'end-date'}))
	}
    }
    # $self->print($tab,",stamp date:",$self->date($record{'modify-date'}))
    # 	if (defined $record{'modify-date'});
    if (defined($record{'memo'})) {
	my ($summary,$memo);
	if (defined($record{'summary'})) {
	    $summary = $record{'summary'};
	    $memo = $record{'memo'};
	} else {
	    $summary = $record{'memo'};
	    # if this contains double quote we have a problem. But
	    # I cannot fix it without decoding shift JIS and backslash/0x80
	    # conversion.
	    $summary =~ s/"//g; # oops
	    $summary =~ s/[\r\n].*$//; $memo = $&;
	}

	$self->print($tab,",subject:\"",$summary,"\"") if ($summary);
	$self->print($tab,",content:\"",$memo,"\"") if ($memo);
    }
    $self->print($tab,"}\n");

}


#######################################################################/

package Calcon::Sla300_read;

# Linux Zaurus SLA300 の XML形式
# でもなんか新しくなって、これではなくなったらしい。しくしく。

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ( 'Calcon::Reader') ;

use NKF;
use Time::Local;

my %keys = (
   'birthday'=>'birth',
   'businessfax'=>'fax',
   'businessmobile'=>'keitai',
   'businessphone'=>'tel',
   'businessstate'=>'state',
   'businessstreet'=>'address',
   'businesszip'=>'zip',
   'categories'=>'categories',
   'company'=>'office',
   'companypronunciation'=>'office-yomi',
   'department'=>'section',
   'description'=>'memo',
   'emails'=>'email',
   'end'=>'end-date',
   'firstname'=>'first-name',
   'firstnamepronunciation'=>'first-name-yomi',
   'homefax'=>'home-fax',
   'homemobile'=>'home-keitai',
   'homephone'=>'home-tel',
   'homestate'=>'home_state',
   'homestreet'=>'home-address',
   'homezip'=>'home-zip',
   'jobtitle'=>'title',
   'lastname'=>'name',
   'lastnamepronunciation'=>'name-yomi',
   'notes'=>'memo',
   'rid'=>'rid',
   'rinfo'=>'rinfo',
   'start'=>'date',
   'uid'=>'uid',
);

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    $self->{'-keywords'} = \%keys;
}

sub decode {
    my ($self,$file) = @_;
    my $out = $self->{'-output'};

    $self->{'-file'} = $file;
    open(F,"<".$file);

    $out->start_file('');

    local($/) = ">";
    while(<F>) {
	$self->xml_decode($_);
    }
    $out->end_file('');
}

sub xml_decode {
    my($self,$xml) = @_;
    my($out) = $self->{'-output'};
    my($convert) = $self->{'-keywords'};

    $xml =~ s/^\s*<([^ ]*) // or return;
    my $type = $1;
    $xml =~ s=/>\s*$== or return;
    $type =~ tr/A-Z/a-z/;
    return if ($type ne 'contact' && $type ne 'event');
    my $record = $self->make_record;
    my $keys = [];
    $_ = $xml;
    while($_) {
	if (s/^\s*([^\s]*)\s*\=\s*\"(.*?)\"\s*//) {
	    my $key = $1;
	    my $data = $2;
	    $key =~ tr/A-Z/a-z/;
	    $key = $convert->{$key} if ( $convert->{$key} );
	    if ($key =~ /birth$/) {
		my (@data) = ($data =~ /(\d+)/g);
		$data = $self->make_date(join("/",@data));
	    } elsif ($key =~ /date$/) {
		$data = $self->make_date_unix($data);
	    } else {
		$data = nkf('-eZ -W',$data);
	    }
	    $record->{$key} = $data;
	    push(@$keys,$key);
	} else {
	    s/^[^\s]*\s*//;
	}
    }
    if (defined($record->{'type'}) && $record->{'type'} =~ /Allday/i) {
	undef $record->{'end-date'};
	@$keys = grep(!/^end-date/,@$keys);
    }
    $out->record($keys,$record);
}


#######################################################################/

package Calcon::Sla300_write;

# Linux Zaurus SLA300 の XML形式
# でもなんか新しくなって、これではなくなったらしい。しくしく。

use strict;
# use warnings;
use Time::Local;
use NKF;
use Carp;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ('Calcon::Buffered_Writer');

# Mac OS X 10.2 's Address Book requires utf-16
# | nkf -Z -e|iconv -c -f EUC-JP -t UTF-16
#

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    $self->{'-fake-allday'} = 0;
    $self->{'-time-for-allday'} = 12*3600;
    $self->{'-add-time-for-allday'} = 2*3600;
}

sub write_datebook {
    my ($self) = @_;
    my $count = $self->{'-date-max'};

    open(CAL,">datebook.xml") or croak($!);
    $self->print ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
    $self->print ( "<!DOCTYPE DATEBOOK><DATEBOOK>\n");
    $self->print ( "<RIDMax>$count</RIDMax>\n");
    my $uid = -1032244274;
    my $rid = 11;

    for my $dates ( @{$self->{'-date-records'}} ) {

	my $end_date = $dates->{'end-date'};
	if (! $end_date) {
	    if ($dates->{'date'}->is_allday()) {
		if ($self->{'-fake-allday'}) {
		    $dates->{'date'}=
			$dates->{'date'}->add($self->{'-time-for-allday'});
		    $dates->{'end-date'} =
			$dates->{'date'}->add($self->{'-add-time-for-allday'});
		    $dates->{'date'} = $self->unix_time($dates->{'date'});
		} else {
		    $end_date = $dates->{'date'}->add(23*3600+59*60);
		    $dates->{'type'} = "AllDay";
		    $dates->{'date'} = $self->unix_time($dates->{'date'});
		    $dates->{'end-date'} = $self->unix_time($end_date);
		}
	    } else {
		$end_date =
		    $dates->{'date'}->add($self->{'-add-time-for-allday'});
		$dates->{'date'} = $self->unix_time($dates->{'date'});
		$dates->{'end-date'} = $self->unix_time($end_date);
	    }
	} else {
	    $dates->{'date'} = $self->unix_time($dates->{'date'});
	    $dates->{'end-date'} = $self->unix_time($dates->{'end-date'})
	}
	# warning killer
	if (! defined($dates->{'summary'})) { $dates->{'summary'} = '';};
	if (! defined($dates->{'memo'})) { $dates->{'memo'} = '';};
	$dates->{'memo'} = nkf('-w -Z3',$dates->{'summary'}.$dates->{'memo'});

	my $memo = $dates->{'memo'};
	my $start_time = $dates->{'date'};
	my $end_time   = $dates->{'end-date'};
	$self->print("<event description=\"$memo\" categories=\"\" uid=\"$uid\" rid=\"$rid\" rinfo=\"1\" start=\"$start_time\"");
	if ($dates->{'end-date'}) {
	    $self->print(" end=\"$end_time\"");
	}
	if ($dates->{'type'}) {
	    $self->print(" type=\"$dates->{'type'}\"");
	}
	$self->print("/>\n");
	$uid++;
	$rid++;
	$count--;
    }
    $self->print("<events>\n");
    $self->print("</events>\n");
    $self->print("</DATEBOOK>\n");
}

sub write_addressbook {
    my ($self) = @_;
    my $count = $self->{'-adr-max'};

    open(CAL,">addressbook.xml") or croak($!);

    $self->print ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n");
    $self->print ( "<!DOCTYPE Addressbook ><AddressBook>\n");
    $self->print ( "<RIDMax>$count</RIDMax>\n");
    $self->print ( "<Groups></Groups>\n");
    for my $adr ( @{$self->{'-address-records'}} ) {

	if (defined  $adr->{'birth'}){
	      $adr->{'birth'} =  $self->birth_date($adr->{'birth'}) ;
	}

	my ($address) 		= $adr->{'address'};
	my ($birth) 		= $adr->{'birth'};
	my ($company) 		= $adr->{'office'};
	my ($email) 		= $adr->{'email'};
	my ($fax) 		= $adr->{'fax'};
	my ($first_name) 	= $adr->{'first-name'};
	my ($first_name_yomi) 	= $adr->{'first-name-yomi'};
	my ($home_address) 	= $adr->{'home-address'};
	my ($home_fax) 		= $adr->{'home-fax'};
	my ($home_keitai) 	= $adr->{'home-keitai'};
	my ($home_state) 	= $adr->{'home_state'};
	my ($home_tel) 		= $adr->{'home-tel'};
	my ($home_zip) 		= $adr->{'home-zip'};
	my ($keitai) 		= $adr->{'keitai'};
	my ($last_name) 	= $adr->{'name'};
	my ($memo) 		= $adr->{'memo'};
	my ($name_yomi) 	= $adr->{'name-yomi'};
	my ($name) 		= $adr->{'name'};
	my ($office_yomi) 	= $adr->{'office-yomi'};
	my ($section) 		= $adr->{'section'};
	my ($state) 		= $adr->{'state'};
	my ($tel) 		= $adr->{'tel'};
	my ($title) 		= $adr->{'title'};
	my ($zip) 		= $adr->{'zip'};

	$self->print ( "<Contact ");
	$self->print ( "LastName=\"$last_name\" " ) if ($last_name);
	$self->print ( "FirstName=\"$first_name\" " ) if ($first_name);
	$self->print ( "JobTitle=\"$title\" " ) if ($title);
	$self->print ( "Department=\"$section\" " ) if ($section);
	$self->print ( "Company=\"$company\" " ) if ($company);
	$self->print ( "Birthday=\"$birth\" " ) if ($birth);
	$self->print ( "BusinessPhone=\"$tel\" " ) if ($tel);
	$self->print ( "BusinessFax=\"$fax\" " ) if ($fax);
	$self->print ( "BusinessStreet=\"$address\" " ) if ($address);
	$self->print ( "BusinessState=\"$state\" " ) if ($state);
	$self->print ( "BusinessZip=\"$zip\" " ) if ($zip);
	$self->print ( "BusinessMobile=\"$keitai\" " ) if ($keitai);
	$self->print ( "HomePhone=\"$home_tel\" " ) if ($home_tel);
	$self->print ( "HomeMobile=\"$home_keitai\" " ) if ($home_keitai);
	$self->print ( "HomeFax=\"$home_fax\" " ) if ($home_fax);
	$self->print ( "HomeStreet=\"$home_address\" " ) if ($home_address);
	$self->print ( "HomeState=\"$home_state\" " ) if ($home_state);
	$self->print ( "HomeZip=\"$home_zip\" " ) if ($home_zip);
	$self->print ( "Emails=\"$email\" " ) if ($email);
	$self->print ( "Notes=\"$memo\" " ) if ($memo);
	$self->print ( "rid=\"$count\" ");
	$self->print ( "rinfo=\"1\" ");
	$self->print ( "LastNamePronunciation=\"$name_yomi\" " ) if ($name_yomi);
	$self->print ( "FirstNamePronunciation=\"$first_name_yomi\" " ) if ($first_name_yomi);
	$self->print ( "CompanyPronunciation=\"$office_yomi\" " ) if ($office_yomi);
	$self->print ( "/>\n");

	$count--;
    }
    $self->print ( "</Contact>\n");
    $self->print ( "</AddressBook>\n");
}

sub birth_date {
    my ($self,$date) = @_;
    my ($year,$month,$day,$hour,$min) = $date->localtime();

    if ($date->is_day()) {
	return "$month/$day";
    }
    return "$year/$month/$day";
}

sub print {
    my ($self,@data) = @_;
    print CAL nkf("-w -Z3",@data);
}

#######################################################################/

package Calcon::Vcard_write;
use strict;
# use warnings;
use NKF;

# VCARD 形式

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ( 'Calcon::Writer' );

# Mac OS X 10.2 's Address Book requires utf-16
# | nkf -Z -e|iconv -c -f EUC-JP -t UTF-16
#

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    $self->{'-fake-allday'} = 1;
    $self->{'-time-for-allday'} = 12*3600;
    $self->{'-add-time-for-allday'} = 2*3600;
}

sub record {
    my ($self,$keys,$record) = @_;
    my ($application);

    if(defined($record->{'name'})) {
	$self->vcard($keys,$record);
    } elsif(defined($record->{'date'})) {
	if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); }
	$self->vcal($keys,$record);
    } else {
	# I don't know.
    }
}

sub end_file {
    my ($self) = @_;
    if ($self->{'-vcal-opening'}) {
	print "END:VCALENDAR\n";
	$self->{'-vcal-opening'} = 0;
    }
}

sub print {
    my ($self,@data) = @_;
    foreach (@data) {
	my $data = nkf('-s -Z',$_);
	$data =~ s/\354\276/\203_/g;
	$data =~ s/\356\276/  /g;
	$data =~ s/\356\277/  /g;
	$data =~ s/([^\200-\377])\\/$1\200/g;
	# $data =~ s/\201/\/g;
	$data = nkf('-w',$_);
	$data =~ s/\000/ /g;
	print $data;
    }
}

sub vcal {
    my ($self,$keys,$record) = @_;
    my (%record) = %{$record};
    my $data;

    my $timezone = "Asia/Tokyo";

    if (! $self->{'-vcal-opening'}) {
    print(<<"EOFEOF");
BEGIN:VCALENDAR
CALSCALE:GREGORIAN
X-WR-TIMEZONE;VALUE=TEXT:Asia/Tokyo
METHOD:PUBLISH
VERSION:2.0
EOFEOF
	$self->{'-vcal-opening'} = 1;
    }

    if ($record{'date'}->is_allday() && $self->{'-fake-allday'}) {
	$record{'date'}=$record{'date'}->add($self->{'-time-for-allday'});
    }
    my $dtstart = "\nDTSTART;TZID=$timezone:".$self->date($record{'date'});
    my $dtend = '';
    my $dtstamp = '';

    if (! defined( $record{'end-date'}) || $record{'end-date'} == $record{'date'} ) {
	# $dtend = "\nDURATION:PT2H";  this is useless for iCal
	$record{'end-date'} = $record{'date'}->add(
	    $self->{'-add-time-for-allday'});
	$dtend = "\nDTEND;TZID=$timezone:".$self->date($record{'end-date'});
    } else {
	$dtend = "\nDTEND;TZID=$timezone:".$self->date($record{'end-date'});
    }
    if (defined( $record{'modify-date'})) {
	$dtstamp = "\nDTSTAMP;TZID=$timezone:".$self->date($record{'modify-date'});
    }

    my $summary = '';
    my $description = '';
    if (defined($record{'memo'})) {
	$summary = $record{'memo'};
	$summary =~ s/[\r\n].*$//; $description = $&;

	$description =~ s/[\n\r]/\n /mg;
	$description =~ s/\s*$//;
	$summary =~ s/[\n\r]/ /mg;
	$summary =~ s/\s*$//;
    }

    if ($description eq $summary) {
	$description = "";
    } else {
	if ($description) {
	    $description = "\nDESCRIPTION: $description";
	}
    }
    return if (! $description && ! $summary );

#     DURATION:PT1H = "DURATION:PT1H";
#     X-WR-CALNAME;VALUE=TEXT:ホーム
#     X-WR-TIMEZONE;VALUE=TEXT:Asia/Tokyo
# SEQUENCE:$i

    $self->print(<<"EOFEOF");
BEGIN:VEVENT
SUMMARY:$summary$dtstart$dtend$description$dtstamp
END:VEVENT
EOFEOF
#    print "\n";
}

sub date {
    my ($self,$date) = @_;
    my ($year,$month,$day,$hour,$min) = $self->localtime($date);

    $date = sprintf("%04d%02d%02dT%02d%02d%02d",
	$year,$month,$day,$hour,$min,0);
    return $date;
}

sub vcard {
    my ($self,$keys,$record) = @_;
    my (%record) = %{$record};
    my $data;

    if(defined($record{'office'})) {
	$record{'office'} = 'etc' if(! $record{'office'}) ;
    }
    if(defined($record{'name-yomi'})) {
	$record{'name-yomi'} =~ s/^ *//;
    }
    if(defined($record{'office-yomi'})) {
	$record{'office-yomi'} =~ s/^ *//;
    }
    $record{'secret'} = ' ' if(! $record{'secret'});
    $record{'alarm'} =  ' ' if(! $record{'alarm'}) ;
    $record{'class'} = ' ' if(! defined($record{'class'}));
    $record{'print-format'} = '2220' if(! defined($record{'print-format'}));
    $record{'mark'} = '00' if(! defined($record{'mark'}));
    $record{'priority'} = '01' if(! defined($record{'priority'}));
    if ($record{'time'} =~ /(.*)-(.*)/) {
	$record{'time'} = $1;
	$record{'end-time'} = $2;
    }

    print "begin:vcard\n";
    print "version:3.0\n";
    if(defined $record{'name'}) {
	$data =  $record{'name'};
	print "FN:$data\n" if($data);
	if(0 && defined $record{'name-yomi'}) {
	    $data = join(";",split(/ /,$record{'name-yomi'}));
	    print "N:$data\n" if($data);
	} else {
	    $data = join(";",split(/ /,$data));
	    print "N:$data\n" if($data);
	}
	if(defined $record{'name-yomi'}) {
	    my ($last , $first , $last_yomi , $first_yomi );
	    $last = $first = $last_yomi = $first_yomi = '';
	    ($last,$first) =  split(/ /,$record{'name'});
	    ($last_yomi,$first_yomi) = split(/ /,$record{'name-yomi'}),
#	    print YOMI $last,"\n";
#	    print YOMI $last_yomi,"\n";
#	    print YOMI $first,"\n";
#	    print YOMI $first_yomi,"\n";
	}

	# print "fn:$data\n" if($data);
	# if(defined $record{'office'}) {
	#     $data = $data.";".$record{'office'};
	# }
	# print "n:$data\n" if($data);
    }
    if(defined $record{'office'}) {
	 $data = "$record{'office'}";
	if(defined $record{'section'}) {
	    $data .= ";".$record{'section'};
	}
	print "org:$data\n" if($data);
    }
    if(defined $record{'title'}) {
	 $data = "$record{'title'}";
	print "title:$data\n" if($data);
    }
    if(defined $record{'address'}) {
	my ($adr1 , $adr2 , $adr_state , $adr_zip , $adr_country );
	$adr1 = $adr2 = $adr_state = $adr_zip = $adr_country = '';
	$data =  $record{'address'};
	$adr1 =  $record{'address'};
# ADD:番地;;町村;沖縄;903-0213;日本
	if(defined $record{'zip'}) {
	    $adr_zip = $record{'zip'};
	}
#	    print "adr;type=work;type=pref:$data\n" if($data);
print "adr;type=work;type=pref:;;$adr1;$adr2;$adr_state;$adr_zip;$adr_country\n" if ($data);
	print "label;type=work;type=pref:$adr_zip $data\n" if($data);
    }
    if(defined $record{'tel'}) {
	$data =  $record{'tel'};
	print "tel;type=work:$data\n" if($data);
    }
    if(defined $record{'tel2'}) {
	$data =  $record{'tel2'};
	print "tel;type=cell:$data\n" if($data);
    }
    if(defined $record{'fax'}) {
	$data =  $record{'fax'};
	print "tel;type=fax:$data\n" if($data);
    }
    if(defined $record{'mail'}) {
	$data =  $record{'mail'};
	print "email;internet:$data\n" if($data);
    }
    if(defined $record{'birth'}) {
	$data =  $record{'birth'};
	print "bday:".$data->date()."\n" if($data);
    }
    if(defined $record{'name-yomi'}) {
	$data =  $record{'name-yomi'};
	print "x-custom1:$data\n" if($data);
    }
    if(defined $record{'office-yomi'}) {
	$data =  $record{'office-yomi'};
	print "x-custom2:$data\n" if($data);
    }
    print "end:vcard\n";
    print "\n";
}

#######################################################################/

package Calcon::Vcard_Apple_write;
use strict;
# use warnings;
use NKF;

# VCARD 形式

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ( 'Calcon::Vcard_write' );

# Mac OS X 10.3 's Address Book requires utf-16
# | nkf -w16
#

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    open(OUTPUT,"| nkf -w16") or die("nkf required.");
    select OUTPUT;
}

sub print {
    my ($self,@data) = @_;
    foreach (@data) {
	chop;
	s/\015/\\n/g;
	s/\012//g;
	print "$_\n";
    }
}

sub vcard {
    my ($self,$keys,$record) = @_;
    my (%record) = %{$record};
    my $data;
    $self->{'item'} = 1;

    if(defined($record{'office'})) {
	$record{'office'} = 'etc' if(! $record{'office'}) ;
    }
    if(defined($record{'name-yomi'})) {
	$record{'name-yomi'} =~ s/^ *//;
    }
    if(defined($record{'office-yomi'})) {
	$record{'office-yomi'} =~ s/^ *//;
    }
    $self->print("begin:vcard\n");
    $self->print("version:3.0\n");
    if(defined $record{'name'}) {
	$data =  $record{'name'};
	$self->print("FN:$data\n") if($data);
	if(0 && defined $record{'name-yomi'}) {
	    $data = join(";",split(/ /,$record{'name-yomi'}));
	    $self->print("N:$data\n") if($data);
	} else {
	    $data = join(";",split(/ /,$data));
	    $self->print("N:$data\n") if($data);
	}
	if(defined $record{'name-yomi'}) {
	    my ($last , $first , $last_yomi , $first_yomi );
	    $last = $first = $last_yomi = $first_yomi = '';
	    ($last,$first) =  split(/ /,$record{'name'});
	    ($last_yomi,$first_yomi) = split(/ /,$record{'name-yomi'}),
	    $self->print("X-PHONETIC-LAST-NAME:$last_yomi\n");
	    $self->print("X-PHONETIC-FIRST-NAME:$first_yomi\n");
	}

	# print "fn:$data\n" if($data);
	# if(defined $record{'office'}) {
	#     $data = $data.";".$record{'office'};
	# }
	# print "n:$data\n" if($data);
    }
#    my $cat = 0;
#    if(defined $record{'group'}) {
#	 $data = "$record{'group'}";
#	$self->print("CATEGORIES:$data\n") if($data);
#    }
    if(defined $record{'office'}) {
	 $data = "$record{'office'}";
	$self->print("ORG:$data;\n") if($data);
#	if ($cat==0) {
#	    $self->print("CATEGORIES:$data\n") if($data);
#	}
    }
    my $title;
    if(defined $record{'section'}) {
	$title = $record{'section'};
    }
    if(defined $record{'title'}) {
	 $title .= ($title?'\n':'')."$record{'title'}";
	$self->print("title:$data\n") if($data);
    }
    if(defined $record{'address'}) {
	my $i = $self->{'item'}++;
	my ($adr1 , $adr2 , $adr_state , $adr_zip , $adr_country );
	$adr1 = $adr2 = $adr_state = $adr_zip = $adr_country = '';
	$data =  $record{'address'};
	$adr1 =  $record{'address'};
# ADD:番地;;町村;沖縄;903-0213;日本
	if(defined $record{'zip'}) {
	    $adr_zip = $record{'zip'};
	}
$self->print("item$i.ADR;type=work;type=pref:;;$adr1;$adr2;$adr_state;$adr_zip;$adr_country\n") if ($data);
    }
    if(defined $record{'tel'}) {
	# my $i = $self->{'item'}++;
	$data =  $record{'tel'};
	$self->print("TEL;type=WORK:$data\n") if($data);
    }
    if(defined $record{'mobile-tel'}) {
	# my $i = $self->{'item'}++;
	$data =  $record{'mobile-tel'};
	$self->print("TEL;type=CELL:$data\n") if($data);
    }
    if(defined $record{'home-tel'}) {
	# my $i = $self->{'item'}++;
	$data =  $record{'tel'};
	$self->print("TEL;type=HOME:$data\n") if($data);
    }
    if(defined $record{'tel2'}) {
	# my $i = $self->{'item'}++;
	$data =  $record{'tel2'};
	$self->print("TEL;type=CELL:$data\n") if($data);
    }
    if(defined $record{'fax'}) {
	# my $i = $self->{'item'}++;
	$data =  $record{'fax'};
	$self->print( "TEL;type=FAX:$data\n") if($data);
    }
    if(defined $record{'home-address'}) {
	my $i = $self->{'item'}++;
	my ($adr1 , $adr2 , $adr_state , $adr_zip , $adr_country );
	$adr1 = $adr2 = $adr_state = $adr_zip = $adr_country = '';
	$data =  $record{'home-address'};
	$adr1 =  $record{'home-address'};
# ADD:番地;;町村;沖縄;903-0213;日本
	if(defined $record{'home-zip'}) {
	    $adr_zip = $record{'home-zip'};
	}
$self->print("item$i.ADR;type=home;type=pref:;;$adr1;$adr2;$adr_state;$adr_zip;$adr_country\n") if ($data);
	# $self->print("item$1.X-ABADR:ja\n") if ($data);
    }
    if(defined $record{'mail2'}) {
	# my $i = $self->{'item'}++;
	$data =  $record{'mail2'};
	$self->print("EMAIL;type=INTERNET;type=home:$data\n") if($data);
    }
    if(defined $record{'mail'}) {
	# my $i = $self->{'item'}++;
	$data =  $record{'mail'};
	$self->print("EMAIL;type=INTERNET;type=pref:$data\n") if($data);
    }
    if(defined $record{'birth'}) {
	$data =  $record{'birth'};
	$self->print("bday:".$data->date()."\n") if($data);
    }
    if(defined $record{'memo'}) {
	$data =  $record{'memo'};
	$self->print("NOTE:$data\n") if($data);
    }
#    if(defined $record{'name-yomi'}) {
#	$data =  $record{'name-yomi'};
#	$self->print "x-custom1:$data\n" if($data);
#    }
#    if(defined $record{'office-yomi'}) {
#	$data =  $record{'office-yomi'};
#	$self->print "x-custom2:$data\n" if($data);
#    }
    $self->print("end:vcard\n");
    $self->print("\n");
}

#######################################################################/

package Calcon::File_read;
use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ( 'Calcon::Reader') ;

# File 形式の読み込み。かなりいいかげんなものでも読み込むが...

use NKF;

sub initialize {
    my ($self) = @_;
    $self->SUPER::initialize();
    $self->{'-email-extract'} = 1;
}

sub decode {
    my ($self,$file) = @_;
    my $out = $self->{'-output'};

    $self->{'-file'} = $file;
    open(F,"<".$file);

    $out->start_file('');

    local($/) = "\n\n";
    while(<F>) {
	$self->buffer_decode($_);
    }
    $out->end_file('');
}

# いいかげんなものでも読み込むためのルーチン

sub buffer_decode {
    my ($self,$buf,%initial) = @_;
    my @data;
    my $key;
    my ($debug) = $self->{'-debug'};
    my $i = 0;
    my $out = $self->{'-output'};

    # $_ =~ s/\n\s+/ /g;
    # s/\n[ \t]/\037/g;

    $buf =~ s/^\s*//;
    @data = split(/\n/,$buf);
    my $record = $self->make_record;
    my $keys = [];

    foreach my $key (keys %initial) {
	$record->{$key} = $initial{$key};
	push(@$keys,$key);
    }
    foreach $_ (@data) {
	if (s/^([A-Za-z][-A-Za-z0-9_]*):\s*//) {
	    $key = $1;
	} else {
	    $key = 'memo';
	}
	$key = 'memo' if ($key eq '');
        if ($key eq 'Subject') {
	    $key = 'memo';
        }
	s/^(\201\100)*//;
	$_ = nkf('-sZ',$_);
	if($key eq 'time' || $key eq 'end-time') {
	    $record->{$key} = $_;
	    next;
	}
	if(!($key eq 'date' || $key eq 'end-date')) {
	    my $save = $_;
	    my $savekey = $key;

	    my $stime;
	    my $etime;
	    # use extra . to avoid regex bug
	    if (/(\d+:\d+).*[-~].*?(\d+:\d+)/) {
		$stime = $1;
		$etime = $2;
# print "*0** $stime $etime\n";
	    } elsif (/(\d+:\d+).*\201\140.*?(\d+:\d+)/) { # ～
		$stime = $1;
		$etime = $2;
# print "*1** $stime $etime\n";
	    } elsif (/(\d+:\d+).*\201\250.*?(\d+:\d+)/) { # →
		$stime = $1;
		$etime = $2;
# print "*2** $stime $etime\n";
	    } elsif (/(\d+:\d+)/) {
		$stime = $1;
	    }
	    if ($stime) {
		my $date = $record->{'date'};
		if ($date) {
		    if ($record->{'memo'}) {

			$self->date_normalize($keys,$record);
			$out->record($keys,$record);

			$record = $self->make_record; $keys = [];
			foreach my $key (keys %initial) {
			    $record->{$key} = $initial{$key};
			    push(@$keys,$key);
			}
			$record->{'date'} = $date;
			push(@$keys,'date');
		    }
		    if (! $record->{'time'}) {
			$record->{'time'} = $stime;
			push(@$keys,'time');
		    }
		    if (! $record->{'end-time'}) {
			$record->{'end-time'} = $etime;
			push(@$keys,'end-time');
		    }
		    $_ = $save;
		    $key = $savekey;
		}
	    }
	} else {
	    # don't append time field
	    push(@$keys,$key);
	    $record->{$key} = $_;
	    next;
	}
	if ($self->{'-email-extract'}) {
	    if(s/[-a-zA-Z0-9.]+@[-a-zA-Z0-9.]+//) {
		if (defined($record->{'mail'})) {
		    $record->{'mail'} .= ",".$&;
		} else {
		    $record->{'mail'} = $&;
		    push(@$keys,'mail');
		}
	    }
	}
	next if (! $_);
	if(defined $record->{$key}) {
	    $record->{$key} .= "\n" . $_;    # append for duplicated field
	} else {
	    push(@$keys,$key);
	    $record->{$key} = $_;
	}
    }
    $self->date_normalize($keys,$record);
    $out->record($keys,$record);
}

#######################################################################/

package Calcon::Xcalendar_read;

# XCalendar 形式の読み込み。かなりいいかげんなものでも読み込むが...

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Time::Local;
use NKF;

@ISA = ( 'Calcon::File_read' ) ;

sub decode {
    my ($self,$file) = @_;
    my @data;
    my $key;
    my ($debug) = $self->{'-debug'};
    my $i = 0;
    my $out = $self->{'-output'};

    $self->{'-file'} = $file;
    my $calendar = $file;

    # my $i = 0;
    my $found = 1;
    my $today = time;
    my $daytime = 60*60*24*2;

    my $all = 1;
    my $tomorrow = $self->{'-tomorrow'};

    my %xcal;

    while(<$calendar/xc*>) {
	my $file = $_;
	my $date = $self->make_xcalendar_date($file);
	next if (! defined $date->unix_time);
	next if ($self->{'-tomorrow'} && ! $date->tomorrow());
	next if ($self->{'-future-only'} && ! $date->future());
        $xcal{$date->unix_time()} = $file;
    }

    $out->start_file('');

    $i= $all ? -1 : 4;
    foreach my $key ( sort {$a <=> $b;} keys(%xcal) ) {
        $found = 0;
        open(XCAL,$xcal{$key}) || next;
        my ($sec,$min,$hour,$day,$month,$year,$wday,$date_,$isdst) =
		    localtime($key);
	my $date;
	$date = ($year+1900)."/".($month+1)."/$day";
	local($/) = "\n\n";
        while(<XCAL>) {
	    $self->buffer_decode($_,'date'=>$date);
	}
        last if($i-- == 0);
    }
    $out->end_file('');
}

#######################################################################/

# 別に Xcalendar class のメソッドでもいいんだけど。

package Calcon::Date ;

use vars qw(%monthname);

sub make_xcalendar_date {
    my ($self,$name) = @_;

    my $date;
    if ($name =~ m^xc([0-9]+)([A-Za-z]+)([0-9]+)$^) {
	my $day = $1 ;my $month = $monthname{$2}; my $year = $3;
	# if($year > 1900) { $year -= 1900; }
	$date = &timelocal(0,0,0,$day,$month,$year,0,0,0);
    }
    bless \$date;
}

#######################################################################/

package Calcon::Basic ;

sub make_xcalendar_date {
    my ($self,$name) = @_;
    $date_class->make_xcalendar_date($name);
}

#######################################################################/

package Calcon::Xcalendar_write ;

# Xcalendar 形式の書き出し

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
@ISA = ('Calcon::Writer');
use NKF;

sub initialize {
    my ($self) = @_;
    if (defined $self->{'-file'}) {
	$self->{'-directory'} = defined $self->{'-file'};
	undef  $self->{'-file'};
    } else {
	$self->{'-directory'} = "$ENV{'HOME'}/Calendar.new";
    }
    $self->SUPER::initialize();
    mkdir $self->{'-directory'};
}

sub record {
    my ($self,$keys,$record) = @_;
    my @keys = @$keys;
    my %record = %$record;
    # should be override
    return if (! $record->{'date'} );
    return if ($self->{'-future-only'} && ! $record->{'date'}->future());
    $self->open($record->{'date'});
    foreach my $key (@keys) {
	my $value = $record{$key};
	if (ref $value) {
	    $value = $value->value();
	}
	print nkf('-e',"$key: $value\n") if ($value);
    }
    print "\n";
    $self->close();
}

sub open {
    my ($self,$date) = @_;
    my $name = $date->xcalendar_file_name;
    if (defined($self->{'-directory'})) {
	$name = $self->{'-directory'}."/".$name;
    }
    open(OUT,">>".$name);
    select OUT;
}

sub close {
    close OUT;
}

#######################################################################/

package Calcon::Date;

sub xcalendar_file_name {
    my ($self) = @_;
    my ($year,$month,$day,$hour,$min) = $self->localtime();
    sprintf("xc%02d%s%04d",$day,$monthname[$month-1],$year);
}

#######################################################################/

package Calcon::Entourage_read;

# Mac のEntourage から AppleScript 経由で読み込む
# ファイルからでも読み込み可能
# Zaurus のCSVも読めた方が良いね
# 日本語専用

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
use Mac::AppleScript qw(RunAppleScript);
use NKF;
use Carp;
@ISA = ( 'Calcon::File_read' ) ;

# We use Applescript, but it is very slow.
# get_all_event is slightly faster.
# To convert contact, it is better to use export address in Entourage Menu.
# If it has a file name other than '/dev/stdin', it assumes export file.

my %item_keys = (
    "名"=>"first name",
    "姓"=>"last name",
    "敬称"=>"sir name",
    "Suffix"=>"suffix",
    "ニックネーム"=>"nick name",
    "会社名"=>"company",
    "役職"=>"title",
    "部署"=>"department",
    "番地 (勤務先)"=>"business address street address",
    "市区町村 (勤務先)"=>"business address city",
    "都道府県 (勤務先)"=>"business address state",
    "郵便番号 (勤務先)"=>"business address zip",
    "国/地域 (勤務先)"=>"business address country",
    "Web ページ (勤務先)"=>"www",
    "番地 (自宅)"=>"home address street address",
    "市区町村 (自宅)"=>"home address city",
    "都道府県 (自宅)"=>"home address state",
    "郵便番号 (自宅)"=>"home address zip",
    "国/地域 (自宅)"=>"home address country",
    "Web ページ (自宅)"=>"home www",
    "電話 1 (自宅)"=>"home phone number",
    "電話 2 (自宅)"=>"home tel2",
    "FAX (自宅)"=>"home fax number",
    "電話 1 (勤務先)"=>"business phone number",
    "電話 2 (勤務先)"=>"tel2",
    "FAX (勤務先)"=>"business fax number",
    "ポケットベル"=>"pager",
    "携帯電話"=>"mobile phone number",
    "電話 (メイン)"=>"main phone number",
    "電話 (アシスタント)"=>"sub tel",
    "電話 (ユーザー設定 1)"=>"tel 1",
    "電話 (ユーザー設定 2)"=>"tel 2",
    "電話 (ユーザー設定 3)"=>"tel 3",
    "電話 (ユーザー設定 4)"=>"tel 4",
    "電子メール アドレス 1"=>"mail-address",
    "電子メール アドレス 2"=>"business mail",
    "電子メール アドレス 3"=>"mail",
    "電子メール アドレス 4"=>"mail-to",
    "電子メール アドレス 5"=>"mail 5",
    "電子メール アドレス 6"=>"mail 6",
    "電子メール アドレス 7"=>"mail 7",
    "電子メール アドレス 8"=>"mail 8",
    "電子メール アドレス 9"=>"mail 9",
    "電子メール アドレス 10"=>"mail 10",
    "電子メール アドレス 11"=>"mail 11",
    "電子メール アドレス 12"=>"mail 12",
    "電子メール アドレス 13"=>"mail 13",
    "メモ 1"=>"memo",
    "メモ 2"=>"memo 2",
    "メモ 3"=>"memo 3",
    "メモ 4"=>"memo 4",
    "メモ 5"=>"memo 5",
    "メモ 6"=>"memo 6",
    "メモ 7"=>"memo 7",
    "メモ 8"=>"memo 8",
    "日付 1 :"=>"date",
    "日付 2 :"=>"date 2",
    "配偶者"=>"spouse",
    "誕生日"=>"birthday",
    "記念日"=>"aniversary",
    "備考"=>"note",
    "年齢"=>"age",
    "星座"=>"astology sign",
    "血液型"=>"blood type",
    "会社名 (ふりがな)"=>"company furigana",
    "名 (ふりがな)"=>"first name furigana",
    "姓 (ふりがな)"=>"last name furigana",
    "配偶者名 (ふりがな)"=>"spouse furigana",
    "趣味"=>"play",
);

$| = 0;
# my $tell = "tell application \"Microsoft Entourage\"\n";
$tell = "tell application \"Microsoft Entourage\"\n";

sub decode {
    my ($self,$file) = @_;
    my ($debug) = $self->{'-debug'};
    my $out = $self->{'-output'};
    if (! $file || $file ne '/dev/stdin') {
	$self->read_export($file);
    }

    $out->start_file('');
    $self->get_all_event() if (! $self->{'-address-only'});
    $self->get_all_contact() if (! $self->{'-calendar-only'});
    $out->end_file('');

}

sub date {
    my ($self,$date)=@_;
    my @date = ($date =~ /(\d+)/g);
    if ($date =~ /PM$/) {
	if ($date[3]==12) { $date[3]=0;}
	$date[3]+=12;
    }
    return $self->make_date("$date[0]/$date[1]/$date[2] $date[3]:$date[4]");
}

sub read_export {
    my ($self,$file) = @_;

    open(IN,"<$file") or cloak("$@");
    local($/) = "\r";

    my $title = <IN>;
    chop($title);

    return if (eof(IN));

    my @keys = split(/\t/,nkf('-eS',$title));
    my $i = 0;
    my %keys;
    foreach my $key (@keys) {
	$keys{$item_keys{$key}} = $i++;
    }
    # foreach my $key (@keys) {
    # 	print "$key:$item_keys{$key}:$keys{$item_keys{$key}}\n";
    # }

    $self->{'-input-keys'} = \%keys;
    my $i0 = 0;
    while(<IN>) {
	my @items;
	chop;
	@items = split(/\t/,$_);
	$self->{'-input'}->[$i0++] = \@items;
    }
    $self->{'-input-count'} = $i0;
}

sub property {
    my ($self,$contact,$id,$property,$record,$key) = @_;
    my $result;
    if ($self->{'-input-count'}) {
	$result = $self->{'-input'}->[$id]->[$self->{'-input-keys'}->{$property}];
	if (! defined($self->{'-input-keys'}->{$property}) ) {
	    print "$property not found\n";
	}
    } else {
	$result = RunAppleScript("${tell}${property} of ${contact} $id\nend tell\n");
    }
    $result =~ s/^\"//;
    $result =~ s/\"$//;
    if (defined($record) && $result ne '') {
	if ($key =~ /date/ || $key =~ /birth/) {
	    $record->{$key} = $self->date($result);
	} else {
	    $record->{$key} = nkf('-eS',$result);
	}
    } else {
	nkf('-eS',$result);
    }
}

sub address {
    my ($self,$id,$property,$record,$key) = @_;
    my $address;
    my ($street , $zip , $state , $country , $city);

    if ($self->{'-input-count'}) {
	my $l = $self->{'-input'}->[$id];
        my $k = $self->{'-input-keys'};
	$address = $l->[$k->{"$property street address"}];
	$zip =     $l->[$k->{"$property zip"}];
	$state =   $l->[$k->{"$property state"}];
	$city =    $l->[$k->{"$property city"}];
	$country = $l->[$k->{"$property country"}];
    } else {
	$address = RunAppleScript("${tell}${property} of contact $id\nend tell\n");
	$address =~ /street address:"([^"]*)"/ && ($street = $1);
	$zip =~ /zip:"([^"]*)"/ && ($zip = $1);
	$state =~ /state:"([^"]*)"/ && ($state = $1);
	$city =~ /city:"([^"]*)"/ && ($city = $1);
	$country =~ /country:"([^"]*)"/ && ($country = $1);
    }


    $record->{$key} = nkf('-eS',"$state $city $street $country")
	if ($state||$city||$street||$country);
    if ($zip && $key =~ /home/) {
	$record->{'home-zip'} = $zip;
    } else {
	$record->{'zip'} = $zip if ($zip);
    }
}

sub get_all_contact {
    my ($self) = @_;
    my $out = $self->{'-output'};
    my $count;
    if ($self->{'-input-count'}) {
	$count = $self->{'-input-count'};
    } else {
	$count = RunAppleScript("${tell}count of contact\nend tell\n") or croak("$@");
    }

    foreach my $id ( 1..$count ) {
	$self->contact($id);
    }
}

sub contact {
    my ($self,$id) = @_;
    my $record = $self->make_record;

    $self->property('contact',$id,'business phone number',$record,'tel');
    $self->property('contact',$id,'home phone number',$record,'tel-home');
    $self->property('contact',$id,'mobile phone number',$record,'mobile-tel');
    $self->property('contact',$id,'main phone number',$record,'tel');
    $self->property('contact',$id,'home fax number',$record,'home-fax');
    $self->property('contact',$id,'business fax number',$record,'fax');

    my $name = $self->property('contact',$id,'last name');
    my $first_name = $self->property('contact',$id,'first name');
    $record->{'name'} = ($name && $first_name)?"$name $first_name":
	($name)?$name:$first_name;

    my $name_p = $self->property('contact',$id,'last name furigana');
    my $first_name_p = $self->property('contact',$id,'first name furigana');
    $record->{'name-yomi'} = ($name_p && $first_name_p)?"$name_p $first_name_p":
	($name_p)?$name_p:$first_name_p;

    $self->property('contact',$id,'department',$record,'section');
    $self->property('contact',$id,'title',$record,'title');

    $self->address($id,'business address',$record,'address');
    $self->address($id,'home address',$record,'home-address');

    my $mail = $self->property('contact',$id,'mail');
    my $mail1 = $self->property('contact',$id,'mail-to');
    if ($mail) { $mail .= ",".$mail1 ;} else { $mail = $mail1;}
    my $mail2 = $self->property('contact',$id,'mail-address');
    if ($mail) { $mail .= ",".$mail1 ;} else { $mail = $mail2;}

    $self->property('contact',$id,'birthday',$record,'birth');
    $self->property('contact',$id,'company',$record,'office');
    $self->property('contact',$id,'company furigana',$record,'office-yomi');

    my $keys = [];
    push(@$keys,keys %{$record});

    # $self->date_normalize($keys,$record);
    my $out = $self->{'-output'};
    $out->record($keys,$record);
}

sub get_all_event {
    my ($self) = @_;
    my $out = $self->{'-output'};
    my $count ;
    if ($self->{'-input-count'}) {
	for(my $id=1; $id <= $count ;$id++) {
	    $self->event($id);
	}
	return;
    } elsif ($self->{'-future-only'}) {
	my $today = $self->today();
        my ($year,$mon,$mday,$hour,$min) = $today->localtime();

	$_ = "${tell}id of every event whose start time > date \"$year/$mon/$mday\"\nend tell\n";
	$count = RunAppleScript($_) or cloak("$@ $_");
	for my $id ($count =~ /(\d+)/g) {
	    $self->event_id($id);
	}
    } else {
	$count = RunAppleScript("${tell}count of event\nend tell\n") or croak("$@");
	for(my $id=1; $id <= $count ;$id++) {
	    $self->event($id);
	}
    }
}

sub event {
    my ($self,$id) = @_;
    my $record = $self->make_record;

    $self->property('event',$id,'all day event',$record,'all-day');
    $self->property('event',$id,'start time',$record,'date');

    if ($record->{'all-day'} ne "true") {
	$self->property('event',$id,'end time',$record,'end-date');
    }
    $self->property('event',$id,'subject',$record,'summary');
    $self->property('event',$id,'content',$record,'memo');

    my $keys = [];
    push(@$keys,keys %{$record});

    my $out = $self->{'-output'};
    $out->record($keys,$record);
}

sub event_id {
    my ($self,$id) = @_;
    my $record = $self->make_record;

    $self->property('event id',$id,'all day event',$record,'all-day');
    $self->property('event id',$id,'start time',$record,'date');

    if ($record->{'all-day'} ne "true") {
	$self->property('event id',$id,'end time',$record,'end-date');
    }
    $self->property('event id',$id,'subject',$record,'summary');
    $self->property('event id',$id,'content',$record,'memo');

    my $keys = [];
    push(@$keys,keys %{$record});

    my $out = $self->{'-output'};
    $out->record($keys,$record);
}


#######################################################################/

package Calcon::Vcard_read;

# Vcard / Vcal 形式を読み込む
#  Vcard に読みがないのが日本語向きじゃないね

use strict;
# use warnings;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

@ISA = ( 'Calcon::File_read' ) ;

sub decode {
    my ($self,$file) = @_;
    my ($debug) = $self->{'-debug'};
    my $out = $self->{'-output'};
    my $record;
    my $keys;

    $self->{'-file'} = $file;
    open(F,"<".$file);

    $out->start_file('');

    while(<F>) {
if (/^begin:\s*vcalendar/i) {
} elsif (/^begin:\s*vcad/i) {
} elsif (/^adr(.*):\s*(.*)/i) { $self->items($record,'address',$1,$2);
} elsif (/^bday:\s*(.*)/i) { $record->{'birth'} = $self->make_date($1);
} elsif (/^begin:\s*vcard/i) {  $record = $self->make_record;
} elsif (/^begin:\s*vevent/i) { $record = $self->make_record;
} elsif (/^calscale:\s*(.*)/i) {
} elsif (/^uid:\s*(.*)/i) {
} elsif (/^description:\s*/i) { $record->{'memo'} .= $1;
} elsif (/^dtend(.*):\s*(.*)/i) { $record->{'end-date'} = $self->date($2,$1?$1:$record->{'timezone'});
} elsif (/^dtstamp(.*):\s*(.*)/i) { $record->{'modify-date'} = $self->date($2,$1?$1:$record->{'timezone'});
} elsif (/^dtstart(.*):\s*(.*)/i) { $record->{'date'} = $self->date($2,$1?$1:$record->{'timezone'});
} elsif (/^duration:\s*(.*)/i) { $self->duration($record,$1);
} elsif (/^email(.*):\s*(.*)/i) { $self->items($record,'email',$1,$2);
} elsif (/^end:\s*vcard/i) { $self->vcard($record);
} elsif (/^end:\s*vevent/i) { $self->event($record);
} elsif (/^fn:\s*(.*)/i) { $self->name($record,$1);
} elsif (/^label(.*):\s*(.*)/i) { $self->items($record,'address',$1,$2);
} elsif (/^method:\s*(.*)/i) {  $record->{'publish'} = $1;
} elsif (/^n:\s*(.*)/i) {  $self->name($record,split(/;/,$1));
} elsif (/^org:\s*(.*)/i) { $record->{'office'} = $1;
} elsif (/^sequence:\s*(.*)/i) { $record->{'sequence'} = $1;
} elsif (/^categories:\s*(.*)/i) { $record->{'group'} = $1;
} elsif (/^summary:\s*(.*)/i) { $record->{'summary'} = $1;
} elsif (/^tel(.*):\s*(.*)/i) { $self->items($record,'tel',$1,$2);
} elsif (/^title:\s*/i) { $record->{'title'} = $1;
} elsif (/^version:\s*(.*)/i) { $record->{'version'} = $1;
} elsif (/^X-PHONETIC-LAST-NAME:\s*(.*)/i) { $record->{'name-yomi'} .= "$1 ";
} elsif (/^X-PHONETIC-FIRST-NAME:\s*(.*)/i) { $record->{'name-yomi'} .= "$1 ";
} elsif (/^x-custom1:\s*(.*)/i) { $record->{'name-yomi'} = $1;
} elsif (/^x-custom2:\s*(.*)/i) { $record->{'office-yomi'} = $1;
} elsif (/^x-wr-calname.*:\s*(.*)/i) { $record->{'calendar'} = $1;
} elsif (/^x-wr-timezone.*:\s*(.*)/i) { $record->{'timezone'} = $1;
} elsif (/^item\d+(.*):\s*(.*)/i) { $self->items($record,'address',$1,$2);
} else { $record->{'extra'} .= $_;
}
    }
    $out->end_file('');
}

sub duration {
    my ($self,$record,$duration)=@_;
    if ($duration =~ /pt(\d+)h/) {
	$record->{'duration'} = "$1:00";
    }
}

sub date {
    my ($self,$date,$timezone)=@_;
    if ($date =~ /(\d\d\d\d)(\d\d)(\d\d)t(\d\d)(\d\d)(\d\d)/i) {
	return $self->make_date("$1/$2/$3 $4:$5");
    } elsif ($date =~ /(\d\d\d\d)(\d\d)(\d\d)/i) {
	return $self->make_date("$1/$2/$3");
    } else  {
	return "";
    }
}

sub event {
    my ($self,$record)=@_;
    my $out = $self->{'-output'};
    my $keys = [];
    push(@$keys,keys %{$record});
    $out->record($keys,$record);
}

sub vcard {
    my ($self,$record)=@_;
    my $out = $self->{'-output'};
    my $keys = [];
    push(@$keys,keys %{$record});
    $out->record($keys,$record);
}

sub items {
    my ($self,$record,$label,$type,$value)=@_;
# $record->{''} = $1;;type=work;type=pref;
# $adr1;$adr2;$adr_state;$adr_zip;$adr_country
    if ($type =~ /home/i) {
	$label = "home-".$label;
    } elsif ($type =~ /voice/i) {
    } elsif ($type =~ /internet/i) {
    } elsif ($type =~ /fax/i) {
	$label = "fax";
    } elsif ($type =~ /work/i) {
    }
    $record->{$label} = $value;
}

sub name {
    my ($self,$record,@names)=@_;
    $record->{'name'} = "@names";
}

1;

__END__

=cut

=head1 NAME

Calcon.pm -- Convert Various Calendar/Address data format

=head1 SYNOPSIS

  use Calcon;

=head1 ABSTRACT

abstract

=head1 DESCRIPTION

=head2 EXPORT

=head1 SEE ALSO

=head1 AUTHOR

Shinji KONO, E<lt>kono@ie.u-ryukyu.ac.jpE<gt>

=head1 COPYRIGHT AND LICENSE

#######################################################################/
##
##  Calendar/Address Format Converter
##
##  Copyright (C) 2002  Shinji Kono
##
##    このソースのいかなる複写，改変，修正も許諾します。ただし、
##    その際には、誰が貢献したを示すこの部分を残すこと。
##    再配布や雑誌の付録などの問い合わせも必要ありません。
##    営利利用も上記に反しない範囲で許可します。
##    バイナリの配布の際にはversion messageを保存することを条件とします。
##    このプログラムについては特に何の保証もしない、悪しからず。
##
##    Everyone is permitted to do anything on this program
##    including copying, modifying, improving,
##    as long as you don't try to pretend that you wrote it.
##    i.e., the above copyright notice has to appear in all copies.
##    Binary distribution requires original version messages.
##    You don't have to ask before copying, redistribution or publishing.
##    THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE.
##
##
## $Id$
#######################################################################/


=cut
author	kono
date	Sun, 16 Oct 2005 15:42:04 +0900
parents	37b9a5119474
children	1a68139a269f