Mercurial > hg > Applications > Calcon
annotate Calcon.pm @ 9:798ba47e8046 address-book
*** empty log message ***
author | kono |
---|---|
date | Sun, 16 Oct 2005 15:42:04 +0900 |
parents | 37b9a5119474 |
children | 1a68139a269f |
rev | line source |
---|---|
1 | 1 package Calcon; |
2 | |
3 ## $Id$ | |
4 | |
5 use 5.008; | |
6 use strict; | |
4 | 7 # use warnings; we have -w, so why we need this? |
3
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
8 |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
9 #require Exporter; |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
10 |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
11 #our @ISA = qw(Exporter); |
1 | 12 |
13 # Items to export into callers namespace by default. Note: do not export | |
14 # names by default without a very good reason. Use EXPORT_OK instead. | |
15 # Do not simply export all your public functions/methods/constants. | |
16 | |
17 # This allows declaration use Calcon ':all'; | |
18 # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK | |
19 # will save memory. | |
3
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
20 #our %EXPORT_TAGS = ( 'all' => [ qw( |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
21 # |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
22 #) ] ); |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
23 |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
24 #our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
25 |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
26 #our @EXPORT = qw( |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
27 |
cb79baed256e
remove Exporter to avoid "can't locate object method nw". Why this can
kono
parents:
1
diff
changeset
|
28 #); |
1 | 29 |
30 our $VERSION = '0.01'; | |
31 | |
32 | |
33 # Preloaded methods go here. | |
34 | |
35 # if you don't have NKF | |
36 # package Calcon::NKF; | |
37 # | |
38 # コード変換しなくても動くことは動くけど、いくつか問題がある。 | |
39 # | |
40 # sub nkf { | |
41 # return shift(@_); | |
42 # } | |
43 | |
44 # デバッグ中に本当にこのパッケージを見ているかどうかの確認用。 | |
45 # print STDERR "new versoin!!\n"; | |
46 | |
47 #######################################################################/ | |
48 | |
49 package Calcon::Basic ; | |
50 use strict; | |
51 # use warnings; | |
52 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
53 @ISA = (); | |
54 | |
55 # このパッケージ用の汎用ライブラリ。Date や Record などの | |
56 # ファクトリーもここにある。Read/Write の両方から参照される。 | |
57 # Date/Record の実装を変えたいときは、ここを変更する。 | |
58 | |
59 my $date_class = 'Calcon::Date'; | |
60 my $record_class = 'Calcon::Record'; | |
61 | |
62 sub new { | |
63 my ($this,$opts,$file) = @_; | |
64 # ClassName->new で呼び出される時のためにこれがある。Perl の決り文句。 | |
65 my $class = ref($this) || $this; | |
66 my $self = {}; | |
67 bless $self, $class; | |
68 # 入出力ファイル名 | |
69 $self->{'-file'} = $file if ($file); | |
7 | 70 $self->option($opts); |
5 | 71 $self->initialize(); # this calls sub class' initializer. |
1 | 72 return $self; |
73 } | |
74 | |
5 | 75 # 下位クラスから呼び出される初期化。ここでは何もしない。 |
76 # new で呼ばれたinitilize は、段階的に SUPER::initilalize を呼び出す。 | |
77 # 最終的に、基底クラスである Calcon::Basic (Calcon そのものであるべき?) | |
78 # の initialize を呼び出す。呼び出されるのだから用意しておく必要がある。 | |
1 | 79 |
80 sub initialize { | |
81 my ($self) = @_; | |
82 } | |
83 | |
84 # option 関係。 | |
85 | |
86 sub set_debug { | |
87 my ($self,$flag) = @_; | |
88 $self->{'-debug'} = $flag; | |
89 } | |
90 | |
91 sub option { | |
92 my ($self,$option) = @_; | |
93 | |
4 | 94 return if (! defined($option)); |
1 | 95 foreach my $opt ( $option =~ /./g ) { |
96 if ($opt eq '-') { | |
97 } elsif ($opt eq 'n') { | |
98 $self->{'-file-out'} = 1; | |
99 } elsif ($opt eq 'd') { | |
100 $self->set_debug(1); | |
101 } elsif ($opt eq 'a') { | |
102 $self->{'-address-only'} = 1; | |
103 } elsif ($opt eq 'c') { | |
104 $self->{'-calendar-only'} = 1; | |
105 } elsif ($opt eq 'F') { | |
106 $self->{'-future-only'} = 1; | |
107 } elsif ($opt eq 't') { | |
108 $self->{'-tomorrow'} = 1; | |
109 } elsif ($opt eq 'C') { | |
110 $self->{'-count'} = 5; | |
111 } | |
112 } | |
113 } | |
114 | |
115 # デバッグ用レコード表示ルーチン。 | |
116 | |
117 sub show { | |
118 my ($self,$record) = @_; | |
119 $record->show(); | |
120 } | |
121 | |
122 # 時間関係のライブラリ | |
123 | |
124 sub localtime { | |
125 my ($self,$date) = @_; | |
126 return $date->localtime(); | |
127 } | |
128 | |
129 sub date { | |
130 my ($self,$date) = @_; | |
131 return $date->date(); | |
132 } | |
133 | |
134 sub today { | |
135 $date_class->today; | |
136 } | |
137 | |
138 sub unix_time { | |
139 my ($self,$date) = @_; | |
140 return $date->unix_time(); | |
141 } | |
142 | |
143 # Factory Pattern | |
144 | |
145 sub make_date_unix { | |
146 my ($self,$date) = @_; | |
147 return $date_class->make_date_unix($date); | |
148 } | |
149 | |
150 sub make_date { | |
151 my ($self,$date) = @_; | |
152 return $date_class->make_date($date); | |
153 } | |
154 | |
155 sub make_record { | |
156 my ($self) = @_; | |
157 my %record; | |
158 my $record = \%record; | |
159 bless $record,$record_class; | |
160 } | |
161 | |
162 #######################################################################/ | |
163 | |
164 package Calcon::Record ; | |
165 use strict; | |
166 # use warnings; | |
167 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
168 use Time::Local; | |
169 @ISA = (); | |
170 | |
171 # 変換に用いる中間データ形式。オブジェクトにすると、デバッグの | |
172 # 時に便利。 | |
173 | |
174 sub show { | |
175 my ($self) = @_; | |
176 foreach my $key (keys %$self) { | |
177 my $value = $self->{$key}; | |
178 if (ref $value) { | |
179 $value = $value->value(); | |
180 } | |
181 print "$key: $value\n" if (defined($value) && $value ne ''); | |
182 } | |
183 print "\n"; | |
184 } | |
185 | |
186 # 中身を文字列で返す。 | |
187 | |
188 sub value { | |
189 my ($self) = @_; | |
190 my $data; | |
191 foreach my $key (keys %$self) { | |
192 my $value = $self->{$key}; | |
193 if (ref $value) { | |
194 $value = $value->value(); | |
195 } | |
196 $data .= "$key: $value\n" if (defined($value) && $value ne ''); | |
197 } | |
198 $data; | |
199 } | |
200 | |
201 # 等しいかどうか | |
202 | |
203 sub equal { | |
204 my ($self,$record) = @_; | |
205 | |
206 foreach my $key (keys %{$self}) { | |
207 next if (!defined $self->{$key} && !defined $record->{$key}); | |
208 if(ref $self->{$key} && ref $record->{$key}) { | |
209 return 0 if (! $self->{$key}->equal($record->{$key})); | |
210 } else { | |
211 return 0 if ($self->{$key} ne $record->{$key}); | |
212 } | |
213 } | |
214 return 1; | |
215 } | |
216 | |
217 # 与えられたレコードリストに含まれる情報しか持っていないかどうか | |
218 | |
219 sub information_in_list { | |
220 my ($self,$records) = @_; | |
221 | |
222 my $lines; | |
223 foreach my $record (@$records) { | |
224 foreach my $key (keys %{$record}) { | |
225 my $value; | |
226 if (ref $record->{$key}) { | |
227 $value = $record->{$key}->value(); | |
228 } else { | |
229 $value = $record->{$key}; | |
230 } | |
231 foreach my $line (split(/\n/,$value)) { | |
232 $line =~ s/\s+/ /g; | |
233 next if (! $line); | |
234 $lines->{$line} = $key; | |
235 } | |
236 } | |
237 } | |
238 return $lines; | |
239 } | |
240 | |
241 # 与えられたレコードリストに対して相対的に新しい情報だけのレコードを作る。 | |
242 | |
243 sub new_information { | |
244 my ($self,$records) = @_; | |
245 my $lines = $self->information_in_list($records); | |
246 | |
247 my $info; | |
248 foreach my $key (keys %{$self}) { | |
249 my $value; | |
250 if (ref $self->{$key}) { | |
251 $value = $self->{$key}->value(); | |
252 } else { | |
253 $value = $self->{$key}; | |
254 } | |
255 foreach my $line (split(/\n/,$value)) { | |
256 $line =~ s/\s+/ /g; | |
257 next if (! $line); | |
258 next if (defined $lines->{$line}) ; | |
259 if (defined $info->{$key}) { $info->{$key} .= "\n$line";} | |
260 else { $info->{$key} .= $line; } | |
261 } | |
262 } | |
263 if(defined $info) { | |
264 bless $info ; | |
265 | |
266 # 必要なキーを残す | |
267 | |
268 $info->{'-date'} = $records->[0]->{'-date'} | |
269 if (defined ($records->[0]->{'-date'})) ; | |
270 $info->{'-name'} = $records->[0]->{'-name'} | |
271 if (defined ($records->[0]->{'-name'})) ; | |
272 # else error だけど、まぁ、良い。 | |
273 } | |
274 $info; | |
275 } | |
276 | |
277 # 与えられたリストにおなじ値を持つレコードが含まれているかどうか | |
278 | |
279 sub is_included { | |
280 my ($self,$records) = @_; | |
281 my $lines = $self->information_in_list($records); | |
282 | |
283 foreach my $key (keys %{$self}) { | |
284 my $value; | |
285 if (ref $self->{$key}) { | |
286 $value = $self->{$key}->value(); | |
287 } else { | |
288 $value = $self->{$key}; | |
289 } | |
290 foreach my $line (split(/\n/,$value)) { | |
291 $line =~ s/\s+/ /g; | |
292 next if (! $line); | |
293 return 0 if (! defined $lines->{$line}) ; | |
294 } | |
295 } | |
296 return 1; | |
297 } | |
298 | |
299 #######################################################################/ | |
300 | |
301 package Calcon::Date ; | |
302 use strict; | |
303 # use warnings; | |
304 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
305 use Time::Local; | |
306 @ISA = (); | |
307 | |
308 # 日付に関するオブジェクト | |
309 # Perl に標準なものがあるんだろうけど。 | |
310 # record とおなじインタフェースを持つべき | |
311 | |
312 my @monthname = ( 'Jan','Feb', 'Mar', 'Apr', 'May', 'Jun', | |
313 'Jul','Aug','Sep','Oct','Nov', 'Dec'); | |
314 my %monthname; | |
315 my $i; | |
316 foreach my $name (@monthname) { $monthname{$name} = $i++; } | |
317 | |
318 # use unix time scalar as an object | |
319 # < 1902/1/1-12/31 date in every year | |
320 # 1903/1/1 00:00-23:59 time in evey day | |
321 # 1903/1/1-7 every weekday | |
322 # It is better to use [$date,$tags] array for this class. | |
323 # あんまり良い実装じゃないね。せこすぎ。 | |
324 | |
325 my $every_day_min = timelocal(0,0,0,1,0,1902); | |
326 my $every_day_max = timelocal(0,0,0,1,0,1903); | |
327 my $every_time_min = timelocal(0,0,0,1,0,1903); | |
328 my $every_time_max = timelocal(59,59,23,1,0,1903); | |
329 my $every_weekday_min = timelocal(0,0,0,4,0,1903); # Sunday | |
330 my $every_weekday_max = timelocal(0,0,0,11,0,1903);# Sunday | |
331 | |
332 my $today = time - 24*3600; | |
333 | |
334 my %week = ( | |
335 'Sun'=> timelocal(0,0,0,4,0,1903), | |
336 'Mon'=> timelocal(0,0,0,5,0,1903), | |
337 'Tue'=> timelocal(0,0,0,6,0,1903), | |
338 'Wed'=> timelocal(0,0,0,7,0,1903), | |
339 'Thu'=> timelocal(0,0,0,8,0,1903), | |
340 'Fri'=> timelocal(0,0,0,9,0,1903), | |
341 'Sat'=> timelocal(0,0,0,10,0,1903), | |
342 ); | |
343 my @week_name = ( | |
344 'Sun', | |
345 'Mon', | |
346 'Tue', | |
347 'Wed', | |
348 'Thu', | |
349 'Fri', | |
350 'Sat', | |
351 ); | |
352 | |
353 sub is_allday { | |
354 my ($self) = @_; | |
355 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = | |
356 localtime($$self); | |
357 return ($sec==0 && $min==0 && $hour==0); | |
358 } | |
359 | |
360 sub is_day { | |
361 my ($self) = @_; | |
362 return ( $every_day_min <= $$self && $$self < $every_day_max ); | |
363 } | |
364 | |
365 sub is_time { | |
366 my ($date) = @_; | |
367 return ( $every_time_min <= $$date && $$date < $every_time_max ); | |
368 } | |
369 | |
370 sub future { | |
371 my ($self) = @_; | |
372 return ( $$self >= $today ); | |
373 } | |
374 | |
375 sub tomorrow { | |
376 my ($self) = @_; | |
377 return ( $today+24*3600*2 >= $$self && $$self >= $today-24*3600/2); | |
378 } | |
379 | |
380 sub is_weekday { | |
381 my ($date) = @_; | |
382 return ( $every_weekday_min <= $$date && $$date < $every_weekday_max ); | |
383 } | |
384 | |
385 sub localtime { | |
386 my ($self) = @_; | |
387 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = | |
388 localtime($$self); | |
389 return ($year+1900,$mon+1,$mday,$hour,$min); | |
390 } | |
391 | |
392 sub make_date { | |
393 my ($self,$date) = @_; | |
394 my ($year,$month,$day,$hour); | |
395 my ($sec,$min); | |
396 | |
397 $hour = $min = $sec = 0; | |
398 | |
399 if ($date =~ m-(\d+)/(\d+)/(\d+)-) { | |
400 # $year = $1 - 1900; this is no longer good for timelocal | |
401 $year = $1; | |
402 $month = $2-1; | |
403 $day = $3; | |
404 } elsif ($date =~ m-(\d+)/(\d+)-) { | |
405 $year = 1902; | |
406 $month = $1-1; | |
407 $day = $2; | |
408 } else { | |
409 if ($week{$date}) { | |
410 my $weekday = $week{$date}; | |
411 bless $date; | |
412 return $date; | |
413 } | |
414 if ($date =~ m-(\d+):(\d+)-) { | |
415 $hour = $1; | |
416 $min = $2; | |
417 } | |
418 $year = 1903; $month = 0; $day = 1; | |
419 return &make_date1($year,$month,$day,$hour,$min,$sec); | |
420 } | |
421 if ($date =~ m-(\d+):(\d+)-) { | |
422 $hour = $1; | |
423 $min = $2; | |
424 } | |
425 return &make_date1($year,$month,$day,$hour,$min,$sec); | |
426 } | |
427 | |
428 sub make_date1 { | |
429 my ($year,$month,$day,$hour,$min,$sec) = @_; | |
430 my ($date,$self); | |
431 | |
432 if ( eval '$date = timelocal($sec,$min,$hour,$day,$month,$year)' ) { | |
433 } else { | |
434 $date = timelocal(0,0,0,1,0,70); | |
435 } | |
436 $self = \$date; | |
437 bless $self; | |
438 } | |
439 | |
440 sub make_date_unix { | |
441 my ($self,$date) = @_; | |
442 $self = \$date; | |
443 bless $self; | |
444 } | |
445 | |
446 sub date { | |
447 my ($self) = @_; | |
448 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = | |
449 CORE::localtime($$self); | |
450 my $date; | |
451 if ($self->is_day()) { | |
452 $date = ($mon+1)."/$mday"; | |
453 } elsif ($self->is_weekday()) { | |
454 return $week_name[$wday]; | |
455 } elsif ($self->is_time()) { | |
456 $date = sprintf(" %02d:%02d",$hour,$min) if ($hour || $min); | |
457 } else { | |
458 $date = ($year+1900)."/".($mon+1)."/$mday"; | |
459 $date .= sprintf(" %02d:%02d",$hour,$min) if ($hour || $min); | |
460 } | |
461 return $date; | |
462 } | |
463 | |
464 sub unix_time { | |
465 my ($self) = @_; | |
466 $$self; | |
467 } | |
468 | |
469 sub add { | |
470 my ($self,$add) = @_; | |
471 my ($result); | |
4 | 472 return $self if (!defined($add)); |
1 | 473 $result = $$self + $add; |
474 bless \$result; | |
475 } | |
476 | |
477 sub date_after { | |
478 my ($self,$day2) = @_; | |
479 return $$self<$$day2; | |
480 } | |
481 | |
482 sub today { | |
483 my $today = time; | |
484 bless \$today; | |
485 } | |
486 | |
487 # record のインタフェース | |
488 | |
489 sub show { | |
490 my ($self) = @_; | |
491 print $self->date(); | |
492 } | |
493 | |
494 sub value { | |
495 my ($self) = @_; | |
496 $self->date(); | |
497 } | |
498 | |
499 sub equal { | |
500 my ($self,$date) = @_; | |
501 return ($self->unix_time() != $date->unix_time()); | |
502 } | |
503 | |
504 #######################################################################/ | |
505 | |
506 package Calcon::Reader ; | |
507 use strict; | |
508 # use warnings; | |
509 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
510 @ISA = ( 'Calcon::Basic' ); | |
511 | |
512 # Reader の基底クラス | |
513 | |
514 # Reader は decode method を持つ必要がある。 | |
515 | |
516 sub decode { | |
517 my ($self) = @_; | |
518 } | |
519 | |
520 sub set_output{ | |
521 my ($self,$out) = @_; | |
522 $self->{'-output'} = $out; | |
523 } | |
524 | |
525 # date_normalize は Date クラスに変換するので、Reader は必ず | |
526 # 呼ぶ必要がある。少し汎用すぎるか? | |
527 | |
528 sub date_normalize { | |
529 my ($self,$keys,$record) = @_; | |
530 my ($sday,$stime,$eday,$etime); | |
531 | |
532 if ($record->{'birth'}) { | |
533 $record->{'birth'} = $self->make_date($record->{'birth'}); | |
534 } | |
535 if ($record->{'modify-date'}) { | |
536 $record->{'modify-date'} = $self->make_date($record->{'modify-date'}); | |
537 } | |
538 return if (! $record->{'date'}); # internal error | |
539 # print ">**$record->{'date'}***\n"; | |
540 # print ">**$record->{'end-date'}***\n"; | |
541 # print ">**$record->{'time'}***\n"; | |
542 # print ">**$record->{'end-time'}***\n"; | |
4 | 543 # warning killer |
544 if (! defined($record->{'date'})) { $record->{'date'} = '';} | |
545 if (! defined($record->{'time'})) { $record->{'time'} = '';} | |
546 if (! defined($record->{'end-time'})) { $record->{'end-time'} = '';} | |
547 if (! defined($record->{'end-date'})) { $record->{'end-date'} = '';} | |
548 $sday = $eday = $stime = $etime = ''; | |
1 | 549 |
550 if ($record->{'time'} =~ /(\d+:\d+)\s*-\s*(\d+:\d+)/) { | |
551 $stime = $1; $etime = $2; | |
552 } elsif ($record->{'time'} =~ /(\d+:\d+)/) { | |
553 $stime = $1; | |
554 } | |
555 if ($record->{'date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)\s*-(\d+\/\d+\/\d+).*\s*(\d+:\d+)/) { | |
556 $sday = $1; $stime = $2; $eday = $3; $etime = $4; | |
557 } elsif ($record->{'date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)\s*-\s*(\d+:\d+)/) { | |
558 $sday = $1; $stime = $2; $etime = $3; | |
559 } elsif ($record->{'date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)/) { | |
560 $sday = $1; $stime = $2; | |
561 } elsif ($record->{'date'} =~ /(\d+\/\d+\/\d+)/) { | |
562 $sday = $1; | |
563 } | |
564 | |
565 # これらのチェックで end-time などが作られてしまうみたい。本来は、 | |
566 # defined で避けるべきなんだろうが... | |
567 | |
568 if ($record->{'end-time'} =~ /(\d+:\d+)/) { | |
569 $etime = $1; | |
570 } | |
571 if ($record->{'end-date'} =~ /(\d+\/\d+\/\d+).*\s+(\d+:\d+)/) { | |
572 $eday = $1; $etime = $2; | |
573 } elsif ($record->{'end-date'} =~ /(\d+\/\d+\/\d+)/) { | |
574 $eday = $1; | |
575 } elsif ( $etime ) { | |
576 $eday = $sday; | |
577 } | |
578 | |
579 $sday = $self->make_date("$sday $stime"); | |
580 if ($eday) { | |
581 $eday = $self->make_date("$eday $etime"); | |
582 if ($eday->date_after($sday)) { | |
583 undef $eday; | |
584 } | |
585 } | |
586 | |
587 # いったん消しておいて、 | |
588 foreach my $key ('end-date','date', 'time','end-time') { | |
589 undef $record->{$key}; | |
590 } | |
591 @$keys = grep(!/^end-date|^date|^time|^end-time/,@$keys); | |
592 | |
593 # もう一回作る。まったくね。 | |
594 | |
595 # print "@$keys\n"; | |
596 if ($eday) { | |
597 $record->{'end-date'} = $eday; | |
598 unshift(@$keys,'end-date'); | |
599 } | |
600 $record->{'date'} = $sday; | |
601 unshift(@$keys,'date'); | |
602 | |
603 # print "@$keys\n"; | |
604 # print "***$record->{'date'}***\n"; | |
605 # print "***$record->{'end-date'}***\n"; | |
606 } | |
607 | |
608 #######################################################################/ | |
609 | |
610 package Calcon::Writer ; | |
611 use strict; | |
612 # use warnings; | |
613 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
614 @ISA = ( 'Calcon::Basic' ); | |
615 use Carp; | |
616 | |
617 # Writer の基底クラス | |
618 | |
619 # Why this class is necessary? | |
620 sub initialize { | |
621 my ($self) = @_; | |
622 | |
623 # 書き出しファイルの切替え | |
624 # directory などに出力する場合は、-file を undef する。 | |
625 if (defined $self->{'-file'}) { | |
626 open(OUT,">".$self->{'-file'}) or | |
627 croak("Can't open $self->{'-file'}:$!\n"); | |
628 select OUT; | |
629 } | |
630 # いらないのは知っているが、拡張するかも知れないので。 | |
631 $self->SUPER::initialize(); | |
632 } | |
633 | |
634 # Writer の基本インタフェース (必ず上書きされる) | |
635 # Perl にもインタフェースが欲しいよね。 | |
636 | |
637 sub start_file { | |
638 my ($self,$type) = @_; | |
639 } | |
640 | |
641 sub end_file { | |
642 my ($self,$type) = @_; | |
643 } | |
644 | |
645 sub record { | |
646 my ($self,$record,$key) = @_; | |
647 } | |
648 | |
649 | |
650 #######################################################################/ | |
651 | |
652 package Calcon::File_write ; | |
653 | |
654 # ファイル形式への書き出し | |
655 # key: データ | |
656 # レコードのセパレータは "\n\n" | |
657 | |
658 use strict; | |
659 # use warnings; | |
660 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
661 @ISA = ('Calcon::Writer'); | |
662 | |
663 sub record { | |
664 my ($self,$keys,$items) = @_; | |
665 my @keys = @$keys; | |
666 my %items = %$items; | |
667 # should be override | |
668 if ($items->{'date'}) { return if ($self->{'-future-only'} && ! $items->{'date'}->future()); } | |
669 foreach my $key (@keys) { | |
670 my $value = $items{$key}; | |
671 if (ref $value) { | |
672 $value = $value->value(); | |
673 } | |
674 print "$key: $value\n" if (defined($value) && $value ne ''); | |
675 } | |
676 print "\n"; | |
677 } | |
678 | |
679 #######################################################################/ | |
680 | |
681 package Calcon::Print_write ; | |
682 | |
683 # 印刷形式。login時に表示するコンパクトな形式。 | |
684 | |
685 use strict; | |
686 # use warnings; | |
687 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
688 use NKF; | |
689 @ISA = ('Calcon::Writer'); | |
690 | |
691 sub initialize { | |
692 my ($self) = @_; | |
693 $self->SUPER::initialize(); | |
694 if ($self->{'-tomorrow'}) { | |
695 $self->{'-count'} = 5; | |
696 } else { | |
697 $self->{'-count'} = -1; | |
698 } | |
699 } | |
700 | |
701 sub record { | |
702 my ($self,$keys,$items) = @_; | |
703 my @keys = @$keys; | |
704 my %items = %$items; | |
705 # should be override | |
706 if (defined $items->{'date'}) { | |
707 my $date = $items->{'date'}; | |
708 return if ($self->{'-future-only'} && ! $date->future()); | |
709 return if ($self->{'-tomorrow'} && ! $date->tomorrow()); | |
710 return if ($self->{'-count'} == 0); | |
711 $self->{'-count'} --; | |
712 $date = $date->date(); | |
5 | 713 my $memo =''; |
714 $memo = $items->{'memo'} if (defined($items->{'memo'})); | |
1 | 715 $memo =~ s/\n+$//; |
716 if ($self->{'-tomorrow'}) { | |
717 print nkf('-e',"$date:\t$memo\n"); | |
718 } else { | |
719 $memo =~ s/^/$date:\t/mg; | |
720 print nkf('-e',"$memo\n"); | |
721 } | |
722 } else { | |
723 foreach my $key (@keys) { | |
724 my $value = $items{$key}; | |
725 if (ref $value) { | |
726 $value = $value->value(); | |
727 } | |
728 print nkf('-e',"$key: $value\n") if (defined($value) && $value ne ''); | |
729 } | |
730 print "\n"; | |
731 } | |
732 } | |
733 | |
734 #######################################################################/ | |
735 | |
736 package Calcon::Zaurus; | |
737 use strict; | |
738 # use warnings; | |
739 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
740 @ISA = (); | |
741 | |
742 # ザウルス関連の基底クラス | |
743 # フレーバとして使うので new がない。 | |
744 # 使用するクラスはZaurus_initialize を呼び出す必要がある。 | |
745 | |
746 my %item_type = ( | |
747 'ADR1'=>'s', 'ADR2'=>'s', 'ALRM'=>'d', 'ANN1'=>'d', 'ANN2'=>'d', 'ATSC'=>'u', | |
748 'ATTM'=>'u', 'ATTR'=>'u', 'BRTH'=>'d', 'CFIP'=>'s', 'CHK1'=>'b', 'CHK2'=>'b', | |
749 'CHK3'=>'b', 'CHK4'=>'b', 'CLAS'=>'s', 'CLSC'=>'u', 'CNTC'=>'u', 'COLR'=>'u', | |
750 'CPS1'=>'s', 'CTGR'=>'u', 'DB01'=>'u', 'DB02'=>'u', 'DB03'=>'u', 'DB04'=>'u', | |
751 'DB05'=>'u', 'DB06'=>'u', 'DB07'=>'u', 'DB08'=>'u', 'DB09'=>'u', 'DB10'=>'u', | |
752 'DB11'=>'u', 'DB12'=>'u', 'DB13'=>'u', 'DB14'=>'u', 'DB15'=>'u', 'DB16'=>'u', | |
753 'DB17'=>'u', 'DB18'=>'u', 'DB19'=>'u', 'DB20'=>'u', 'DB21'=>'u', 'DB22'=>'u', | |
754 'DB23'=>'u', 'DB24'=>'u', 'DB25'=>'u', 'DB26'=>'u', 'DB27'=>'u', 'DB28'=>'u', | |
755 'DBFN'=>'u', 'DBID'=>'u', 'DBIT'=>'u', 'DBSI'=>'u', 'DBST'=>'u', 'DNS1'=>'s', | |
756 'DNS2'=>'s', 'ECDT'=>'u', 'EDDY'=>'d', 'EDTM'=>'d', 'ETDY'=>'d', 'FAX1'=>'s', | |
757 'FAX2'=>'s', 'FINF'=>'b', 'FNDY'=>'d', 'HOL1'=>'d', 'HTXT'=>'h', 'IMG1'=>'i', | |
758 'IMGF'=>'g', 'IMJG'=>'j', 'IORR'=>'b', 'LKDT'=>'d', 'LKIF'=>'u', 'LTDY'=>'d', | |
759 'MAL1'=>'s', 'MARK'=>'u', 'MEM1'=>'s', 'MLAD'=>'s', 'MLCC'=>'s', 'MLFM'=>'s', | |
760 'MLID'=>'u', 'MLRP'=>'s', 'MLTO'=>'u', 'MPFB'=>'s', 'NAME'=>'s', 'NAPR'=>'s', | |
761 'NMSK'=>'s', 'OFCE'=>'s', 'OFPR'=>'s', 'OPT1'=>'u', 'OPT2'=>'u', 'PGR1'=>'s', | |
762 'POPA'=>'s', 'POPP'=>'s', 'PRBD'=>'u', 'PRF1'=>'u', 'PRTY'=>'u', 'PSTN'=>'s', | |
763 'PSWD'=>'s', 'RCCK'=>'b', 'RDCK'=>'b', 'RMRK'=>'s', 'RVTM'=>'u', 'SBJT'=>'u', | |
764 'SCCP'=>'s', 'SCTG'=>'u', 'SCTN'=>'s', 'SDDT'=>'d', 'SDTM'=>'u', 'SPKS'=>'s', | |
765 'STDY'=>'d', 'SVAD'=>'s', 'TCPS'=>'u', 'TEL1'=>'s', 'TEL2'=>'s', 'TIM1'=>'d', | |
766 'TIM2'=>'d', 'TITL'=>'s', 'TMNL'=>'u', 'USID'=>'s', 'XLIF'=>'u', 'ZCCP'=>'s', | |
767 'ZIP2'=>'s', 'ZIPC'=>'s', 'ZPKS'=>'s', 'ZRTF'=>'u', 'ZXLS'=>'u', 'mDTM'=>'d', | |
768 'mISC'=>'u', 'tPID'=>'u', | |
769 ); | |
770 | |
771 my %item_name = ( | |
772 'FNDY'=>'finish-date', | |
773 'ETDY'=>'start-date', | |
774 'LTDY'=>'deadline', | |
775 'STDY'=>'start-date', | |
776 'ADR1'=>'home-address', | |
777 'ADR2'=>'address', | |
778 'ANN1'=>'anniversary', | |
779 'BRTH'=>'birth', | |
780 'CLAS'=>'class', | |
781 'CPS1'=>'mobile-tel', | |
782 'DNS1'=>'DNS 1', | |
783 'DNS2'=>'DNS 2', | |
784 'EDTM'=>'edit-time', | |
785 'FAX1'=>'home-fax', | |
786 'FAX2'=>'fax', | |
787 'HTXT'=>'hand-text', | |
788 'IMG1'=>'image', | |
789 'IMGF'=>'gif', | |
790 'IMJG'=>'jpg', | |
791 'LKDT'=>'link-date', | |
792 'MAL1'=>'mail', | |
793 'MEM1'=>'memo', | |
794 'MLAD'=>'mail-adderess', | |
795 'MLTO'=>'mail-to', | |
796 'NAME'=>'name', | |
797 'NAPR'=>'name-yomi', | |
798 'NMSK'=>'mask', | |
799 'OFCE'=>'office', | |
800 'OFPR'=>'office-yomi', | |
801 'POPA'=>'pop 1', | |
802 'POPP'=>'pop p', | |
803 'PSTN'=>'position', | |
804 'PSWD'=>'password', | |
805 'RMRK'=>'remark', | |
806 'SCCP'=>'sccp', | |
807 'SCTN'=>'section', | |
808 'SDTM'=>'sdtm', | |
809 'SPKS'=>'spks', | |
810 'SVAD'=>'cvad', | |
811 'TEL1'=>'home-tel', | |
812 'TEL2'=>'tel', | |
813 'TIM1'=>'date', | |
814 'TIM2'=>'end-date', | |
815 'TITL'=>'title', | |
816 'USID'=>'user id', | |
817 'ZCCP'=>'zccp', | |
818 'ZIP2'=>'home-zip', | |
819 'ZIPC'=>'zip', | |
820 'ZPKS'=>'packats', | |
821 'mDTM'=>'modify-date', | |
822 ); | |
823 | |
824 | |
825 sub Zaurus_initialize { | |
826 my ($self) = @_; | |
827 $self->{'-item_type'} = \%item_type; | |
828 $self->{'-item_name'} = \%item_name; | |
829 $self->{'-offset'} = 8; | |
830 } | |
831 | |
832 # ザウルスのBOX形式に格納されている属性名リストの取出 | |
833 | |
834 sub item_list { | |
835 my ($self,$data) = @_; | |
836 my ($value,@index); | |
837 my ($debug) = $self->{'-debug'}; | |
838 | |
839 my $title_offset; | |
840 my $title_len = 0; | |
841 my $field_offset; | |
842 | |
843 my $version = unpack("n",substr($data,2,2)); | |
844 $self->{'-zaurus-version'} = $version; | |
845 # $title_offset += ($version < 0x1030)?2:0; | |
846 | |
847 if ($version <= 0x1002 ) { | |
848 $title_offset = 0x15; | |
849 $self->{'-title-begin'} = $title_offset; | |
850 $field_offset = 1; | |
851 } elsif ($version < 0x1030 ) { | |
852 $title_offset = unpack("V",substr($data,0x8,4)); | |
853 $self->{'-title-begin'} = $title_offset; | |
854 $title_offset += 2; | |
855 $field_offset = 2; | |
856 } else { | |
857 $title_offset = unpack("V",substr($data,0x8,4)); | |
858 $self->{'-title-begin'} = $title_offset; | |
859 $field_offset = 2; | |
860 } | |
861 | |
862 my $title_count = ord(substr($data,$title_offset,1)); | |
863 my $ptr = $title_offset+1; | |
864 my $i = 0; | |
865 print "\n\nfile:",$self->{'-file'},"\n\n" | |
866 if ($debug && defined ($self->{'-file'})); | |
867 while($title_count-->0) { | |
868 my $item_len = ord(substr($data,$ptr,1)); | |
869 $ptr += 2; | |
870 # print "item: ",unpack("H*",substr($data,$ptr,$item_len)) if ($debug); | |
871 my $id = $self->{'-item_id'}->[$i] = substr($data,$ptr+$field_offset,4); | |
872 my $name = $self->{'-item_name1'}->[$i] = | |
873 substr($data,$ptr+5,$item_len-5); | |
874 print "list:\t$i:$id:$item_len:$name\n" if ($debug); | |
875 $ptr += $item_len; | |
876 $i++; | |
877 } | |
878 print "title-len: $version $title_len ",$ptr - $title_offset,"\n" if ($debug); | |
879 $self->{'-item_name_count'} = $i; | |
880 $self->{'-title-length'} = $ptr-$title_offset; | |
881 } | |
882 | |
883 | |
884 #######################################################################/ | |
885 | |
886 package Calcon::Zaurus_read ; | |
887 | |
888 # BOX 形式からの読み込み | |
889 | |
890 use strict; | |
891 # use warnings; | |
892 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
893 @ISA = ('Calcon::Zaurus', 'Calcon::Reader'); | |
894 | |
895 sub initialize { | |
896 my ($self) = @_; | |
897 $self->SUPER::initialize(); | |
898 $self->Zaurus_initialize(); | |
899 | |
900 $self->{'-debug'} = 0; | |
901 $self->{'-offset'} = 8; | |
902 $self->{'-all'} = 0; | |
903 $self->{'-item_list'} = ''; # '' or 'original' or 'id' | |
904 } | |
905 | |
906 sub read { | |
907 my ($self,$file) = @_; | |
908 | |
909 $self->{'-file'} = $file; | |
910 open(F,"<".$file); | |
911 | |
912 local($/) ; | |
913 undef $/; | |
914 my $data = <F>; | |
915 $data; | |
916 } | |
917 | |
918 sub decode { | |
919 my ($self,$file) = @_; | |
920 my ($debug) = $self->{'-debug'}; | |
921 my $out = $self->{'-output'}; | |
922 | |
923 my $data = $self -> read($file); | |
924 $self -> item_list($data); | |
925 $out->start_file($file); | |
926 print "Zaurus version: $self->{'-zaurus-version'}\n" if ($debug); | |
927 if ($self->{'-zaurus-version'} <= 0x1002) { | |
928 $self->decode_old_data($data); | |
929 } elsif ($self->{'-zaurus-version'} == 0x1030) { | |
930 $self->{'-offset'} = 10; | |
931 $self->decode_data($data); | |
932 } else { | |
933 $self->decode_data($data); | |
934 } | |
935 $out->end_file($file); | |
936 } | |
937 | |
938 # 複雑なIndexの処理 | |
939 | |
940 sub decode_index { | |
941 my ($self,$data) = @_; | |
942 my ($debug) = $self->{'-debug'}; | |
943 | |
944 my ($length) = unpack("V",substr($data,0x10,4)); | |
945 if ($self->{'-zaurus-version'} eq 0x1030) { | |
946 $length = unpack("V",substr($data,0x8,4)); | |
947 } | |
948 my $offset = 0x50; | |
949 my ($value,@index); | |
950 my $i; | |
951 my $flag; | |
952 | |
953 do { | |
954 for($i=$offset;$i<$length;$i+=4) { | |
955 $value = unpack("V",substr($data,$i,4)); | |
956 next if ($value == 0xffffffff); | |
957 push(@index,$value) if ($value); | |
958 } | |
959 $offset = $value; | |
960 $flag = unpack("v",substr($data,$offset,2)); | |
961 | |
962 printf "next index %0x: %0x\n",$offset,"" if ($debug); | |
963 printf "flag: %0x\n",$flag if ($debug); | |
964 | |
965 if ($self->{'-zaurus-version'} eq 0x1030) { | |
966 $length = unpack("V",substr($data,$offset+2,4)); | |
967 $offset = $offset+6; | |
968 $length += $offset; | |
969 } else { | |
970 $length = unpack("v",substr($data,$offset+2,2)); | |
971 $offset = $offset+5; | |
972 $length += $offset; | |
973 } | |
974 printf "next index length %0x\n",$length if ($debug); | |
975 | |
976 } while ($flag == 0xfff0); | |
977 | |
978 return @index; | |
979 } | |
980 | |
981 # BOX形式の中のレコードの処理 | |
982 | |
983 sub decode_data { | |
984 my ($self,$data) = @_; | |
985 my ($offset) = $self->{'-offset'}; | |
986 my ($debug) = $self->{'-debug'}; | |
987 | |
988 my(@index) = $self->decode_index($data); | |
989 | |
990 foreach my $index (@index) { | |
991 printf "index %0x: %s\n",$index,"" if ($debug); | |
992 | |
993 last if (length(substr($data,$index,2))<2); | |
994 next if (substr($data,$index,2) eq "\xf0\xff"); | |
995 | |
996 my $record_number=ord(substr($data,$index,1)) + | |
997 ord(substr($data,$index+1,1))*256; | |
998 my $record_len=ord(substr($data,$index+2,1)) + | |
999 ord(substr($data,$index+3,1))*256; | |
1000 | |
1001 my $item_count=ord(substr($data,$index+6,1)); | |
1002 my $item_dummy=ord(substr($data,$index+10,1)); | |
1003 | |
1004 my @len = (); | |
1005 my $ptr = $index + $offset; | |
1006 my $total_len = 0; | |
1007 my $k = 1; | |
1008 for(my $j=$self->{'-item_name_count'}; $j>0; $j--) { | |
1009 my $i=ord(substr($data,$ptr,1)); | |
1010 if ($i>=0x80) { | |
1011 $ptr++; | |
1012 $i = ord(substr($data,$ptr,1))+($i-0x80)*256; | |
1013 } | |
1014 print "len:$k: $i\n" if ($debug); | |
1015 $k++; | |
1016 push(@len,$i); | |
1017 $total_len += $i; | |
1018 $ptr++; | |
1019 } | |
1020 printf "offset: %x\n",$ptr-$index if ($debug); | |
1021 | |
1022 # $ptr = $index+40+$item_dummy; should be this kind of method... | |
1023 # $ptr = $index+$record_len-$total_len+5; | |
1024 # $ptr = $index+8+$item_count; | |
1025 | |
1026 | |
1027 print "head: ",unpack("H*",substr($data,$index,50)),"\n" if ($debug); | |
1028 print "body: ",unpack("H*",substr($data,$ptr,50)),"\n" if ($debug); | |
1029 | |
1030 my $i = 0; | |
1031 my $record = $self->make_record; | |
1032 my @key_list = (); | |
1033 foreach my $len (@len) { | |
1034 my ($key,$item,$type) = | |
1035 $self->decode_item($i,substr($data,$ptr,$len)); | |
1036 if ($item) { | |
1037 if ($type eq 's' || $type eq 'd') { | |
1038 push(@key_list,$key); | |
1039 $record->{$key} = $item; | |
1040 } elsif ($self->{'-all'}) { | |
1041 push(@key_list,$key); | |
1042 $record->{$key} = $type.":".unpack("H*",$item); | |
1043 } | |
1044 } | |
1045 $i++; | |
1046 $ptr += $len; | |
1047 } | |
1048 $self->date_normalize(\@key_list,$record); | |
1049 $self->{'-output'}->record(\@key_list,$record); | |
1050 print "\n" if ($debug);; | |
1051 } | |
1052 } | |
1053 | |
1054 # たぶん、PI-7000以前の形式 | |
1055 | |
1056 sub decode_old_data { | |
1057 my ($self,$data) = @_; | |
1058 my $debug = $self->{'-debug'}; | |
1059 my @len = (); | |
1060 my $ptr = $self->{'-title-begin'} + $self->{'-title-length'}; | |
1061 | |
1062 my $old_number = 0; | |
1063 while(1) { | |
1064 my $record = $self->make_record; | |
1065 my @key_list = (); | |
1066 | |
1067 # my $record_number = ord(substr($data,$ptr++,1)); | |
1068 my $record_number = unpack("v",substr($data,$ptr,2)); | |
1069 my $optr = $ptr; | |
1070 while ($record_number != $old_number+1) { | |
1071 # $record_number = ord(substr($data,$ptr++,1)); | |
1072 $ptr += 1; | |
1073 $record_number = unpack("v",substr($data,$ptr,2)); | |
1074 return if ($ptr>length($data)); | |
1075 } | |
1076 print "offset: ",$ptr-$optr,"\n" if ($debug && $optr<$ptr); | |
1077 $ptr += 2; | |
1078 my $record_length = unpack("v",substr($data,$ptr,2)); | |
1079 $ptr += 2; | |
1080 print "record_number: $record_number\n" if ($debug); | |
1081 print "record_length: $record_length\n" if ($debug); | |
1082 $old_number = $record_number; | |
1083 # last if ($record_length == 0); | |
1084 my $record_end = $optr + $record_length+4; # - 3; | |
1085 my $i = 0; | |
1086 $ptr+=2; | |
1087 for(my $j=$self->{'-item_name_count'}; $j>0; $j--) { | |
1088 # while($ptr < $record_end) { | |
1089 my $len=ord(substr($data,$ptr++,1)); | |
1090 if ($len>=0x80) { | |
1091 $len = ord(substr($data,$ptr,1))+($len-0x80)*256; | |
1092 $ptr++; | |
1093 } | |
1094 print "len: $len\n" if ($debug); | |
1095 print "data: ",substr($data,$ptr,$len),"\n" if ($debug); | |
1096 my ($key,$item,$type) = | |
1097 $self->decode_item($i,substr($data,$ptr,$len)); | |
1098 if ($item) { | |
1099 if ($type eq 's' || $type eq 'd') { | |
1100 push(@key_list,$key); | |
1101 $record->{$key} = $item; | |
1102 } elsif ($self->{'-all'}) { | |
1103 push(@key_list,$key); | |
1104 $record->{$key} = $type.":".unpack("H*",$item); | |
1105 } | |
1106 } | |
1107 $i++; | |
1108 $ptr += $len; | |
1109 } | |
1110 if ($debug && $ptr != $record_end) { | |
1111 print "record_end: $ptr $record_end\n"; | |
1112 } | |
1113 $ptr = $record_end; | |
1114 print "\n" if ($debug);; | |
1115 $self->date_normalize(\@key_list,$record); | |
1116 $self->{'-output'}->record(\@key_list,$record); | |
1117 # } | |
1118 } | |
1119 } | |
1120 | |
1121 sub decode_time { | |
1122 my ($self,$t) = @_; | |
1123 | |
1124 return '' if (! $t); | |
1125 # print unpack("H*",substr($t,1,4)),"\n"; | |
1126 | |
1127 $t = hex(unpack("H*",substr($t,1,4))); | |
1128 my $year = ($t&0x0000000f)*16 ; | |
1129 $year += (($t&0x0000f000)>>12) + 1900; | |
1130 my $month = ($t&0x00000f00)>>8; | |
1131 my $day = ($t&0x00f80000)>>19; | |
1132 my $min = ($t&0x3f000000)>>24; | |
1133 my $hour =((($t&0xc0000000)>>30)&0x3)<<0; | |
1134 $hour += (($t&0x00070000)>>16)<<2; | |
1135 if ($year == 2155) { # unspecified case | |
1136 $t = sprintf("%d/%d",$month,$day); | |
1137 } else { | |
1138 $t = sprintf("%04d/%d/%d",$year,$month,$day); | |
1139 } | |
1140 if($min!=63) { | |
1141 $t .= sprintf(" %02d:%02d",$hour,$min); | |
1142 } | |
1143 $t; | |
1144 } | |
1145 | |
1146 # Zaurus レコード中の可変長データを属性名とともに変換する。 | |
1147 | |
1148 sub decode_item { | |
1149 my ($self,$i,$item) = @_; | |
1150 my $all = $self->{'-all'}; | |
1151 my $debug = $self->{'-debug'}; | |
1152 | |
1153 return if (! $item); | |
1154 # print $self->{'-item_id'}->[$i],": ",unpack("H*",$item),"\n"; | |
1155 my $id_name = $self->{'-item_id'}->[$i]; | |
1156 my $id_type = $self->{'-item_type'}->{$id_name}; | |
1157 | |
1158 if ($self->{'-item_list'} eq 'original') { | |
1159 $id_name = $self->{'-item_name1'}->[$i]; | |
1160 } elsif ($self->{'-item_list'} eq 'id') { | |
1161 } elsif (defined $self->{'-item_name'}->{$id_name}) { | |
1162 $id_name = $self->{'-item_name'}->{$id_name}; | |
1163 } | |
1164 | |
1165 if ( $id_type eq 'd' ) { | |
1166 $item = $self->decode_time($item); | |
1167 } | |
1168 return ($id_name,$item,$id_type); | |
1169 } | |
1170 | |
1171 #######################################################################/ | |
1172 | |
1173 package Calcon::Pool; | |
1174 | |
1175 # 差分などを取るための中間的なレコードバッファ | |
1176 # Unix の pipe みたいに使う | |
1177 # Writer/Reader を両方継承すべきかも知れない。けど、今のところ、Reader | |
1178 # を継承する利点は無い。decode ではなく、output を呼ぶ。 | |
1179 | |
1180 use strict; | |
1181 # use warnings; | |
1182 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
1183 use NKF; | |
1184 @ISA = ('Calcon::Writer'); | |
1185 # This also has Reader interface. | |
1186 | |
1187 sub record { | |
1188 my ($self,$keys,$record) = @_; | |
1189 | |
1190 if(defined($record->{'name'})) { | |
1191 $self->address($keys,$record); | |
1192 } elsif(defined($record->{'date'})) { | |
1193 if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); } | |
1194 $self->calendar($keys,$record); | |
1195 } else { | |
1196 # I don't know. | |
1197 } | |
1198 } | |
1199 | |
1200 sub address { | |
1201 my ($self,$keys,$record) = @_; | |
1202 push(@{$self->{'-address-index'}->{$record->{'name'}}},$record); | |
1203 } | |
1204 | |
1205 sub calendar { | |
1206 my ($self,$keys,$record) = @_; | |
1207 push(@{$self->{'-date-index'}->{$record->{'date'}->unix_time()}},$record); | |
1208 } | |
1209 | |
1210 sub set_contents { | |
1211 my ($self,$address,$calendar) = @_; | |
1212 $self->{'-date-index'} = $calendar; | |
1213 $self->{'-address-index'} = $address; | |
1214 } | |
1215 | |
1216 sub contents { | |
1217 my ($self) = @_; | |
1218 return ( $self->{'-date-index'}, $self->{'-address-index'}); | |
1219 } | |
1220 | |
1221 # Reader インターフェースの部分 | |
1222 | |
1223 sub set_output { | |
1224 my ($self,$out) = @_; | |
1225 $self->{'-output'} = $out; | |
1226 } | |
1227 | |
1228 sub output { | |
1229 my ($self,$out) = @_; | |
1230 | |
1231 $self->{'-output'} = $out; | |
1232 $self->{'-output'}->start_file(); | |
1233 $self->write_datebook(); | |
1234 $self->write_addressbook(); | |
1235 $self->{'-output'}->end_file(); | |
1236 } | |
1237 | |
1238 sub write_datebook { | |
1239 my ($self) = @_; | |
1240 for my $date ( sort {$a<=>$b} keys %{$self->{'-date-index'}} ) { | |
1241 for my $record ( @{$self->{'-date-index'}->{$date}} ) { | |
1242 my @keys = keys %{$record}; | |
1243 $self->{'-output'}->record(\@keys,$record); | |
1244 } | |
1245 } | |
1246 } | |
1247 | |
1248 sub write_addressbook { | |
1249 my ($self) = @_; | |
1250 for my $adr ( keys %{$self->{'-address-index'}} ) { | |
1251 for my $record ( @{$self->{'-address-index'}->{$adr}} ) { | |
1252 my @keys = keys %{$record}; | |
1253 $self->{'-output'}->record(\@keys,$record); | |
1254 } | |
1255 } | |
1256 } | |
1257 | |
1258 # 自分自身のクラスを切替えることで動作モードを切替える | |
1259 | |
1260 sub delete_mode { | |
1261 my ($self) = @_; | |
1262 bless $self,'Calcon::Pool::delete'; | |
1263 } | |
1264 | |
1265 sub merge_mode { | |
1266 my ($self) = @_; | |
1267 bless $self,'Calcon::Pool::merge'; | |
1268 } | |
1269 | |
1270 sub input_mode { | |
1271 my ($self) = @_; | |
1272 bless $self,'Calcon::Pool'; | |
1273 } | |
1274 | |
1275 # 以下のルーチンは、たぶん、Record クラスにあるべき | |
1276 | |
1277 sub same_record_in_list { | |
1278 my ($self,$list,$record) = @_; | |
1279 # print "\nCampare: ";$record->value; | |
1280 record: | |
1281 for (my $i = 0; $i<=$#{$list}; $i++) { | |
1282 my $r = $list->[$i]; | |
1283 # print "\nList: ";$r->value; | |
1284 next if (! $record->equal($r)); | |
1285 # print "\nResult: $i\n"; | |
1286 return $i; | |
1287 } | |
1288 # print "\nResult: -1\n"; | |
1289 return -1; | |
1290 } | |
1291 | |
1292 #######################################################################/ | |
1293 | |
1294 package Calcon::Pool::delete; | |
1295 | |
1296 # 自分のPoolから、与えれたレコードを削除する。差分計算。 | |
1297 | |
1298 use strict; | |
1299 # use warnings; | |
1300 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
1301 use NKF; | |
1302 @ISA = ('Calcon::Pool'); | |
1303 | |
1304 sub address { | |
1305 my ($self,$keys,$record) = @_; | |
1306 my $name = $record->{'name'}; | |
1307 if (my $list = $self->{'-address-index'}->{$name}) { | |
1308 my $i; | |
1309 if (($i = $self->same_record_in_list($list,$record)) >= 0 ) { | |
1310 splice(@{$list},$i,1); | |
1311 if (! @$list) { | |
1312 delete $self->{'-address-index'}->{$name}; | |
1313 } | |
1314 } | |
1315 } | |
1316 } | |
1317 | |
1318 sub calendar { | |
1319 my ($self,$keys,$record) = @_; | |
1320 my $date = $record->{'date'}->unix_time(); | |
1321 if (my $list = $self->{'-date-index'}->{$date}) { | |
1322 my $i; | |
1323 if (($i = $self->same_record_in_list($list,$record)) >= 0 ) { | |
1324 splice(@{$list},$i,1); | |
1325 if (! @$list) { | |
1326 delete $self->{'-date-index'}->{$date}; | |
1327 } | |
1328 } | |
1329 } | |
1330 } | |
1331 | |
1332 #######################################################################/ | |
1333 | |
1334 package Calcon::Pool::merge; | |
1335 | |
1336 # Pool にないレコードだったら、そのレコードを付け加える。 | |
1337 # 中身を見て、必要な情報のみを付け加える方が良い。 | |
1338 | |
1339 use strict; | |
1340 # use warnings; | |
1341 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
1342 use NKF; | |
1343 @ISA = ('Calcon::Pool'); | |
1344 | |
1345 sub address { | |
1346 my ($self,$keys,$record) = @_; | |
1347 my $name = $record->{'name'}; | |
1348 if (my $list = $self->{'-address-index'}->{$name}) { | |
1349 my $i; | |
1350 if (($i = $self->same_record_in_list($list,$record)) >= 0 ) { | |
1351 return; | |
1352 } | |
1353 push(@$list,$record); | |
1354 } else { | |
1355 push(@{$self->{'-address-index'}->{$name}},$record); | |
1356 } | |
1357 } | |
1358 | |
1359 sub calendar { | |
1360 my ($self,$keys,$record) = @_; | |
1361 my $date = $record->{'date'}->unix_time(); | |
1362 my $list = $self->{'-date-index'}->{$date}; | |
1363 if ($list) { | |
1364 my $r; | |
1365 return unless ($r = $self->new_info($list,$record)); | |
1366 push(@$list,$r); | |
1367 } else { | |
1368 push(@{$self->{'-date-index'}->{$date}},$record); | |
1369 } | |
1370 } | |
1371 | |
1372 | |
1373 #######################################################################/ | |
1374 | |
1375 package Calcon::Buffered_Writer; | |
1376 | |
1377 # 変換前にすべてを読み込む必要がある形式のために使うクラス。 | |
1378 # データの先頭に総レコード数を持つ形式とか。 | |
1379 | |
1380 use strict; | |
1381 # use warnings; | |
1382 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
1383 use NKF; | |
1384 @ISA = ('Calcon::Writer'); | |
1385 | |
1386 # | |
1387 # Some format requires whole record before write, because of | |
1388 # record count or sorted order. This plugin class perform | |
1389 # reading and queueing. | |
1390 # | |
1391 # write_datebook or write_address_book should be overwrited. | |
1392 # | |
1393 | |
1394 sub record { | |
1395 my ($self,$keys,$record) = @_; | |
1396 | |
1397 if(defined($record->{'name'})) { | |
1398 $self->{'-adr-max'}++; | |
1399 $self->address($keys,$record); | |
1400 } elsif(defined($record->{'date'})) { | |
1401 if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); } | |
1402 $self->{'-date-max'}++; | |
1403 $self->calendar($keys,$record); | |
1404 } else { | |
1405 # I don't know. | |
1406 } | |
1407 } | |
1408 | |
1409 sub address { | |
1410 my ($self,$keys,$record) = @_; | |
1411 push(@{$self->{'-address-records'}}, $record); | |
1412 } | |
1413 | |
1414 sub calendar { | |
1415 my ($self,$keys,$record) = @_; | |
1416 push(@{$self->{'-date-records'}}, $record); | |
1417 } | |
1418 | |
1419 sub end_file { | |
1420 my ($self) = @_; | |
4 | 1421 $self->write_datebook() if ( defined($self->{'-date-max'})); |
1422 $self->write_addressbook() if ( defined($self->{'-adr-max'})); | |
1 | 1423 } |
1424 | |
1425 sub write_datebook { | |
1426 my ($self) = @_; | |
1427 my $count = $self->{'-date-max'}; | |
1428 for my $dates ( @{$self->{'-date-records'}} ) { | |
1429 } | |
1430 } | |
1431 | |
1432 sub write_addressbook { | |
1433 my ($self) = @_; | |
1434 my $count = $self->{'-adr-max'}; | |
1435 for my $adr ( @{$self->{'-address-records'}} ) { | |
1436 } | |
1437 } | |
1438 | |
1439 | |
1440 #######################################################################/ | |
1441 | |
1442 package Calcon::Zaurus_backup_read ; | |
1443 | |
1444 # ザウルスのバックアップ形式 | |
1445 | |
1446 use strict; | |
1447 # use warnings; | |
1448 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
1449 @ISA = ( 'Calcon::Zaurus_read' ); | |
1450 | |
1451 sub decode { | |
1452 my ($self,$backup) = @_; | |
1453 my $out = $self->{'-output'}; | |
1454 | |
1455 my $data = $self->backup_read($backup); | |
1456 | |
1457 foreach my $file ( $self->backup_files($data) ) { | |
1458 next if ($file !~ /BOX$/); | |
1459 $self->SUPER::decode($file); | |
1460 } | |
1461 } | |
1462 | |
1463 sub backup_files { | |
1464 my ($self,$data) = @_; | |
1465 if ($data =~ /^\032*PABAK/) { | |
1466 return $self->text_backup($data); | |
1467 } else { | |
1468 return $self->ztar($data); | |
1469 } | |
1470 } | |
1471 | |
1472 sub initialize { | |
1473 my ($self) = @_; | |
1474 $self->SUPER::initialize(); | |
1475 | |
1476 # alphabet encoding | |
1477 # | |
1478 # 0-5 "0".."5" | |
1479 # 6-0x1f "A".."Z" | |
1480 # 0x20-0x25 "6"..";" | |
1481 # 0x26-0x3f "a".."z" | |
1482 # | |
1483 # make character replacement code | |
1484 # | |
1485 my $ya = ''; | |
1486 my $yb = ''; | |
1487 for(my $i=0;$i<0x40;$i++) { | |
1488 if( $i <= 0x05 ) { $ya .= pack("C",($i + 0x30));} | |
1489 elsif( $i <= 0x1f ) { $ya .= pack("C",($i + 0x3b));} | |
1490 elsif( $i <= 0x25 ) { $ya .= pack("C",($i + 0x16));} | |
1491 else { $ya .= pack("C",($i + 0x3b)); } | |
1492 # since . never matches \n, 0x40 is added | |
1493 $yb .= sprintf("\\%03o",$i+0x40); | |
1494 } | |
1495 eval "sub a_decode \{ y\/" . $ya . "/" . $yb . "/;}\n"; | |
1496 eval "sub a_encode \{ y\/" . $yb . "/" . $ya . "/;}\n"; | |
1497 | |
1498 } | |
1499 | |
1500 sub read { | |
1501 my ($self,$file) = @_; | |
1502 return $self->{'-files'}->{$file}; | |
1503 } | |
1504 | |
1505 ########################################################## | |
1506 # | |
1507 # Zaurus Binary Encoding | |
1508 # | |
1509 ########################################################## | |
1510 | |
1511 # bit encoding | |
1512 # s/..../&decode($&)/eg; | |
1513 # 76543210765432107654321076543210 | |
1514 # 00 11 22 001122 | |
1515 # 33221100332211003322110033221100 | |
1516 # 00 11 22 001122 | |
1517 | |
1518 sub bit_decode { | |
1519 my $bit = substr($_[0],0,3); | |
1520 vec($bit, 3,2) = vec($_[0],14,2); | |
1521 vec($bit, 7,2) = vec($_[0],13,2); | |
1522 vec($bit,11,2) = vec($_[0],12,2); | |
1523 return $bit; | |
1524 } | |
1525 | |
1526 sub bit_encode { | |
1527 my $bit = $_[0]; | |
1528 vec($bit,14,2) = vec($bit, 3,2); | |
1529 vec($bit,13,2) = vec($bit, 7,2); | |
1530 vec($bit,12,2) = vec($bit,11,2); | |
1531 # since . never matches \n, 0x40 is added | |
1532 vec($bit,11,2) = vec($bit,7,2) = vec($bit,3,2) = 1; | |
1533 return $bit; | |
1534 } | |
1535 | |
1536 sub z_encode { | |
1537 my ($i); | |
1538 $i = (length()%3); | |
1539 $_ .= "\0" x (3-$i) if($i); | |
1540 s/.../&bit_encode($&)/eg; | |
1541 &a_encode; | |
1542 } | |
1543 | |
1544 sub z_decode { | |
1545 my ($i); | |
1546 s/\s//g; | |
1547 &a_decode; | |
1548 $i = (length()%4); | |
1549 $_ .= "\0" x (4-$i) if($i); | |
1550 s/..../&bit_decode($&)/eg; | |
1551 } | |
1552 | |
1553 sub text_backup { | |
1554 my ($self,$data) = @_; | |
1555 my $debug = $self->{'-debug'}; | |
1556 my (@names,@size); | |
1557 | |
1558 print("\nBackup Directory\n") if ($debug); | |
1559 | |
1560 $data =~ s/^\032*PABAK.*\n([^\032]*\032)//; | |
1561 $_ = $1; | |
1562 &z_decode; | |
1563 my @title = (); my @attr = (); | |
1564 my $len = length($_) - 20; my $j = 0; | |
1565 for(my $i=6;$i<$len;$i+=20) { | |
1566 $title[$j] = substr($_,$i,12); | |
1567 $attr[$j] = unpack("H*",substr($_,$i+12,5)); | |
1568 $size[$j] = (ord(substr($_,$i+17,1)) | |
1569 +ord(substr($_,$i+18,1))*0x100 | |
1570 +ord(substr($_,$i+19,1))*0x10000); | |
1571 print($title[$j]."\t") if ($debug); | |
1572 print($attr[$j]."\t") if ($debug); | |
1573 print($size[$j]."\n") if ($debug); | |
1574 $j++; | |
1575 } | |
1576 my $i = 0; | |
1577 foreach (split(/\032/,$data)) { | |
1578 s/^PABAK.*\n//; | |
1579 &z_decode; | |
1580 $self->{'-files'}->{$title[$i++]} = $_; | |
1581 } | |
1582 return @title; | |
1583 } | |
1584 | |
1585 sub ztar { | |
1586 my ($self,$data) = @_; | |
1587 my $debug = $self->{'-debug'}; | |
1588 my (@names,@size); | |
1589 my $ptr = 0; | |
1590 | |
1591 $_ = substr($data,0,16); | |
1592 $ptr += 16; | |
1593 my $count = unpack("V",substr($_,4,4)); | |
1594 | |
1595 print unpack("H*",substr($_,0,8)),"\n" if ($debug); | |
1596 for ( my $i = 0; $i<$count ; $i++ ) { | |
1597 $_ = substr($data,$ptr,24); $ptr+=24; | |
1598 last if (substr($_,0,1) eq "\xff"); | |
1599 my $name = substr($_,0,12); $name =~ s/\0.*//; | |
1600 print "name: $name\n" if ($debug); | |
1601 push(@names,$name); | |
1602 my $size = unpack("V",substr($_,12,4)); | |
1603 print "size: $size\n" if ($debug); | |
1604 push(@size,$size); | |
1605 print unpack("H*",substr($_,12)),"\n" if ($debug); | |
1606 } | |
1607 | |
1608 for ( my $i = 0; $i<$count ; $i++ ) { | |
1609 $_ = substr($data,$ptr,$size[$i]); $ptr+=$size[$i]; | |
1610 my $name = $names[$i]; | |
1611 $self->{'-files'}->{$name} = $_; | |
1612 } | |
1613 return @names; | |
1614 } | |
1615 | |
1616 sub backup_read { | |
1617 my ($self,$file) = @_; | |
1618 | |
1619 $self->{'-file'} = $file; | |
1620 open(F,"<".$file); | |
1621 local($/) ; | |
1622 undef $/; | |
1623 my $data = <F>; | |
1624 $data; | |
1625 } | |
1626 | |
1627 | |
1628 | |
1629 #######################################################################/ | |
1630 | |
1631 package Calcon::iApp_read; | |
1632 | |
1633 # iCal/AddressBook からAppleScript 経由で読み込む。なので、 | |
1634 # Mac::AppleScript が必要。 | |
1635 | |
1636 use strict; | |
1637 # use warnings; | |
1638 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
1639 use Mac::AppleScript qw(RunAppleScript); | |
1640 use NKF; | |
1641 @ISA = ( 'Calcon::File_read' ) ; | |
1642 | |
1643 # We use Applescript, but it is very slow. | |
1644 | |
1645 my $tell; | |
1646 | |
1647 my %record_keys = ( | |
1648 "phone電話"=>"tel", | |
1649 "phoneファックス"=>"fax", | |
1650 "emailメール"=>"mail", | |
1651 "address住所"=>"address", | |
1652 ); | |
1653 | |
1654 sub initialize { | |
1655 my ($self) = @_; | |
1656 $self->SUPER::initialize(); | |
1657 $self->{'-labels'} = \%record_keys; | |
1658 } | |
1659 | |
1660 sub decode { | |
1661 my ($self,$file) = @_; | |
1662 my ($debug) = $self->{'-debug'}; | |
1663 my $out = $self->{'-output'}; | |
1664 my $record; | |
1665 my $keys; | |
1666 | |
1667 $out->start_file(''); | |
1668 $self->get_all_event() if (! $self->{'-address-only'}); | |
1669 $self->get_all_contact() if (! $self->{'-calendar-only'}); | |
1670 $out->end_file(''); | |
1671 | |
1672 } | |
1673 | |
1674 sub date { | |
1675 my ($self,$date)=@_; | |
1676 my @date = ($date =~ /(\d+)/g); | |
1677 if ($date =~ /PM$/) { | |
1678 if ($date[3]==12) { $date[3]=0;} | |
1679 $date[3]+=12; | |
1680 } | |
1681 return $self->make_date("$date[0]/$date[1]/$date[2] $date[3]:$date[4]"); | |
1682 } | |
1683 | |
1684 | |
1685 sub property { | |
1686 my ($self,$contact,$id,$property,$record,$key) = @_; | |
1687 my $result; | |
1688 $result = RunAppleScript("${tell}${property} of ${contact} $id\nend tell\n"); | |
1689 # it looks like apple event returns some garbage | |
1690 $result =~ s/^\"//; $result =~ s/\"$//; $result =~ s/\001.*$//; | |
1691 if (defined($record) && $result ne '') { | |
1692 if ($key =~ /date/ || $key =~ /birth/) { | |
1693 $record->{$key} = $self->date($result); | |
1694 } else { | |
1695 $record->{$key} = nkf('-eS',$result); | |
1696 } | |
1697 } else { | |
1698 nkf('-eS',$result); | |
1699 } | |
1700 } | |
1701 | |
1702 sub address { | |
1703 my($self,$id,$vid,$phone,$record) = @_; | |
1704 | |
1705 my ($street , $zip , $state , $country , $city); | |
5 | 1706 $street = $zip = $state = $country = $city = ''; |
1 | 1707 my $address = RunAppleScript("${tell}properties of ${phone} $vid of person $id\nend tell\n"); |
1708 | |
1709 # {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} | |
1710 | |
5 | 1711 $address =~ s/^\"//; $address =~ s/\"$//; |
1712 $address =~ s/\001.*$//; | |
1713 $address =~ s/\002.*?"/"/; | |
1 | 1714 $address = nkf('-eS',$address); |
1715 | |
1716 # my ($street , $zip , $state , $country , $city); | |
1717 $address =~ /street:"([^"]*)"/ && ($street = $1); | |
5 | 1718 $address =~ /zip:"([^"]*)"/ && ($zip = $1); |
1719 $address =~ /state:"([^"]*)"/ && ($state = $1); | |
1720 $address =~ /city:"([^"]*)"/ && ($city = $1); | |
1721 $address =~ /country:"([^"]*)"/ && ($country = $1); | |
1 | 1722 |
1723 my ($label) = ($address =~ /label:"(.*?)"/); | |
1724 if (! defined($self->{'-labels'}->{$phone.$label})) { | |
1725 print "## $phone$label not defined\n"; | |
1726 } else { | |
5 | 1727 $record->{$self->{'-labels'}->{$phone.$label}} = |
1728 "$state $city $street $country" | |
1729 if ($state||$city||$street||$country); | |
1730 if ($zip && $self->{'-labels'}->{$phone.$label} =~ /home/) { | |
1731 $record->{'home-zip'} = $zip; | |
1732 } else { | |
1733 $record->{'zip'} = $zip if ($zip); | |
1734 } | |
1 | 1735 } |
1736 } | |
1737 | |
1738 sub value { | |
1739 my($self,$id,$vid,$phone,$record) = @_; | |
1740 my $result = RunAppleScript("${tell}properties of ${phone} $vid of person $id\nend tell\n"); | |
1741 $result =~ s/^\"//; $result =~ s/\"$//; $result =~ s/\001.*$//; | |
1742 $result = nkf('-eS',$result); | |
1743 my ($value,$label) = ($result =~ /value:"(.*?)".*label:"(.*?)"/); | |
1744 if (! defined($self->{'-labels'}->{$phone.$label})) { | |
1745 print "## $phone$label not defined\n"; | |
5 | 1746 } else { |
1747 $record->{$self->{'-labels'}->{$phone.$label}} = $value; | |
1 | 1748 } |
1749 } | |
1750 | |
1751 | |
1752 sub get_all_contact { | |
1753 my ($self) = @_; | |
1754 $tell = "tell application \"Address Book\"\n"; | |
1755 | |
1756 my $count = RunAppleScript("${tell}count of person\nend tell\n"); | |
1757 foreach my $id ( 1..$count ) { | |
1758 $self->person($id); | |
1759 } | |
1760 } | |
1761 | |
1762 sub person { | |
1763 my ($self,$id) = @_; | |
1764 my $record = {}; | |
1765 | |
1766 my $phone_count = RunAppleScript("${tell}count of phone of person $id\nend tell\n"); | |
1767 foreach my $phone_id ( 1..$phone_count ) { | |
1768 $self->value($id,$phone_id,'phone',$record); | |
1769 } | |
1770 | |
1771 my $email_count = RunAppleScript("${tell}count of email of person $id\nend tell\n"); | |
1772 foreach my $email_id ( 1..$email_count ) { | |
1773 $self->value($id,$email_id,'email',$record); | |
1774 } | |
1775 | |
1776 my $address_count = RunAppleScript("${tell}count of address of person $id\nend tell\n"); | |
1777 foreach my $address_id ( 1..$address_count ) { | |
1778 $self->address($id,$address_id,'address',$record); | |
1779 } | |
1780 | |
1781 my $name = $self->property('person',$id,'last name'); | |
1782 my $first_name = $self->property('person',$id,'first name'); | |
1783 $record->{'name'} = ($name && $first_name)?"$name $first_name": | |
1784 ($name)?$name:$first_name; | |
1785 | |
1786 my $name_p = $self->property('person',$id,'phonetic last name'); | |
1787 my $first_name_p = $self->property('person',$id,'phonetic first name'); | |
1788 $record->{'name-yomi'} = ($name_p && $first_name_p)?"$name_p $first_name_p": | |
1789 ($name_p)?$name_p:$first_name_p; | |
1790 | |
1791 $self->property('person',$id,'job title',$record,'section'); | |
1792 $self->property('person',$id,'title',$record,'title'); | |
1793 | |
1794 # $self->property('person',$id,'birth date',$record,'birth'); | |
1795 $self->property('person',$id,'organization',$record,'office'); | |
1796 my $keys = []; | |
1797 push(@$keys,keys %{$record}); | |
1798 | |
1799 my $out = $self->{'-output'}; | |
1800 $out->record($keys,$record); | |
1801 } | |
1802 | |
1803 | |
1804 sub get_all_event { | |
1805 my ($self) = @_; | |
1806 | |
1807 $tell = "tell application \"iCal\"\n"; | |
1808 if ($self->{'-future-only'}) { | |
1809 my $today = $self->today(); | |
1810 my ($year,$mon,$mday,$hour,$min) = $today->localtime(); | |
1811 my $count = RunAppleScript("${tell}uid of every event of last calendar whose start date > date \"$year/$mon/$mday\"\nend tell\n"); | |
1812 for my $id ($count =~ /("[^"]*")/g) { | |
1813 $self->uid_event($id); | |
1814 } | |
1815 } else { | |
1816 my $count = RunAppleScript("${tell}count of event of last calendar\nend tell\n"); | |
1817 for(my $id=1; $id <= $count ;$id++) { | |
1818 $self->event($id); | |
1819 } | |
1820 } | |
1821 } | |
1822 | |
1823 sub uid_event { | |
1824 my ($self,$id) = @_; | |
1825 my $record = $self->make_record; | |
1826 | |
1827 # $self->property('event',$id,'all day event',$record,'all-day'); | |
1828 $self->property('some event of last calendar whose uid is',$id,'start date',$record,'date'); | |
1829 $self->property('some event of last calendar whose uid is',$id,'end date',$record,'end-date'); | |
1830 $self->property('some event of last calendar whose uid is',$id,'summary',$record,'summary'); | |
1831 $self->property('some event of last calendar whose uid is',$id,'description',$record,'memo'); | |
1832 my $keys = []; | |
1833 push(@$keys,keys %{$record}); | |
1834 | |
1835 my $out = $self->{'-output'}; | |
1836 $out->record($keys,$record); | |
1837 } | |
1838 | |
1839 sub event { | |
1840 my ($self,$id) = @_; | |
1841 my $record = $self->make_record; | |
1842 | |
1843 # $self->property('event',$id,'all day event',$record,'all-day'); | |
1844 $self->property('event',$id." of last calendar",'start date',$record,'date'); | |
1845 $self->property('event',$id." of last calendar",'end date',$record,'end-date'); | |
1846 $self->property('event',$id." of last calendar",'summary',$record,'summary'); | |
1847 $self->property('event',$id." of last calendar",'description',$record,'memo'); | |
1848 my $keys = []; | |
1849 push(@$keys,keys %{$record}); | |
1850 | |
1851 my $out = $self->{'-output'}; | |
1852 $out->record($keys,$record); | |
1853 } | |
1854 | |
1855 | |
1856 | |
1857 #######################################################################/ | |
1858 | |
1859 package Calcon::iApp_write ; | |
1860 | |
1861 # AppleScript 経由で iCal/AddressBook に書き出す。この実装では、 | |
1862 # Mac::AppleScript はいらない | |
1863 | |
1864 use strict; | |
1865 # use warnings; | |
1866 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
1867 use NKF; | |
1868 use Carp; | |
1869 | |
1870 @ISA = ( 'Calcon::Writer' ); | |
1871 | |
1872 sub initialize { | |
1873 my ($self) = @_; | |
1874 | |
1875 $self->SUPER::initialize(); | |
1876 if (defined $self->{'-file'}) { | |
1877 $self->{'-file-out'} = 1; | |
1878 } else { | |
1879 if (defined $self->{'-file-out'}) { | |
1880 $self->{'-file'} = "script-out"; | |
1881 } | |
1882 } | |
1883 | |
1884 $self->{'-fake-allday'} = 1; | |
1885 $self->{'-time-for-allday'} = 12*3600; | |
1886 $self->{'-add-time-for-allday'} = 2*3600; | |
1887 | |
1888 $self->{'-check-script'} = 1; | |
1889 $self->{'-check-group'} = 20; | |
1890 $self->{'-do-grouping'} = 1; | |
1891 | |
1892 # | perl -pe 's/[\177-\377]/sprintf "\\%03o",ord($&)/eg;' | |
1893 # | perl -pe 's/\\(\d\d\d)/sprintf "%c",oct($&)/eg;' | |
1894 | |
1895 $self->{"-phone-labels"} = { | |
1896 "tel"=>"電話", | |
1897 "tel-home"=>"自宅電話", | |
1898 "mobile-tel"=>"携帯", | |
1899 "home-fax"=>"自宅ファックス", | |
1900 "fax"=>"ファックス", | |
1901 | |
1902 }; | |
1903 $self->{"-mail-labels"} = { | |
1904 "mail"=>"メール", | |
1905 "mail-to"=>"メール2", | |
1906 "mail-address"=>"メール3", | |
1907 | |
1908 }; | |
1909 $self->{"-address-labels"} = { | |
1910 "address"=>"住所", | |
1911 "home-address"=>"自宅住所", | |
1912 }; | |
1913 $self->{"-zip-labels"} = { | |
1914 "zip"=>"郵便番号", | |
1915 "home-zip"=>"自宅郵便番号", | |
1916 }; | |
1917 $self->{'-groups'} = {}; | |
1918 $self->{'-init-file'} = "s000000"; | |
1919 $self->{'-check-script-count'} = 0; | |
1920 $self->{'-script-name'} = $self->{'-init-file'}; | |
1921 | |
1922 } | |
1923 | |
1924 sub start_file { | |
1925 my ($self,$type) = @_; | |
1926 undef $self->{'-application'}; | |
1927 if ($self->{'-file-out'}) { | |
1928 mkdir $self->{'-file'}; | |
1929 } | |
1930 } | |
1931 | |
1932 sub end_file { | |
1933 my ($self,$type) = @_; | |
1934 $self->close(); | |
1935 $self->{'-telling'} = 0; | |
1936 if ($self->{'-file-out'}) { | |
1937 $self->make_group(); | |
1938 while(<script-out/*.script>) { | |
1939 my $out = $_; | |
1940 $out =~ s/\.script$/.compile/; | |
1941 print STDERR "osacompile -o $out $_\n"; | |
1942 # system "osacompile -o $out $_"; | |
1943 # system "osascript $out"; | |
1944 } | |
1945 } | |
1946 } | |
1947 | |
1948 sub start_record { | |
1949 my ($self,$type) = @_; | |
1950 | |
1951 if ($self->{'-check-script'}) { | |
1952 my $i = $self->{'-check-script-count'}++; | |
1953 if ($i % $self->{'-check-group'}==0) { | |
1954 my $d = $self->{'-script-name'}++; | |
1955 $self->close() if ( $self->{'-telling'} ); | |
1956 $self->{'-telling'} = 0; | |
8 | 1957 if (1) { |
1 | 1958 if ($self->{'-file-out'}) { |
1959 open OUT,"> script-out/$d.script" or croak($!); | |
1960 } else { | |
1961 print STDERR "doing $i\n"; | |
1962 open OUT,"| osascript " or cloak($!); | |
1963 } | |
8 | 1964 } else { |
1965 if ($self->{'-file-out'}) { | |
1966 open OUT,"> script-out/$d.script" or croak($!); | |
1967 } else { | |
1968 print STDERR "doing $i\n"; | |
1969 open OUT,"| osascript " or cloak($!); | |
1970 } | |
1971 } | |
1 | 1972 select OUT; |
1973 } | |
1974 } | |
1975 } | |
1976 | |
1977 sub print { | |
1978 my ($self,@data) = @_; | |
1979 foreach (@data) { | |
1980 my $data = nkf('-s -Z',$_); | |
1981 $data =~ s/\354\276/\203_/g; | |
1982 $data =~ s/\356\276/ /g; | |
1983 $data =~ s/\356\277/ /g; | |
1984 $data =~ s/([^\200-\377])\\/$1\200/g; | |
1985 # $data =~ s/\201/\/g; | |
8 | 1986 $data =~ s/\\/\\\\/g; |
1 | 1987 print $data; |
1988 } | |
1989 } | |
1990 | |
1991 sub record { | |
1992 my ($self,$keys,$record) = @_; | |
1993 my ($application); | |
1994 | |
1995 $self->start_record(''); | |
1996 | |
1997 # check proper application | |
1998 if (defined $record->{'name'}) { | |
1999 $application = 'Address Book'; | |
2000 $self->set_application($application); | |
2001 $self->address_book($keys,$record); | |
2002 $self->print("end tell\n") if (! $self->{'-check-script'}) ; | |
2003 } elsif (defined $record->{'date'}) { | |
2004 if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); } | |
2005 $application = 'iCal'; | |
2006 $self->set_application($application); | |
2007 $self->ical($keys,$record); | |
2008 $self->print("end tell\n") if (! $self->{'-check-script'}) ; | |
2009 } else { | |
2010 # nothing to do | |
2011 } | |
2012 $self->print("\n"); | |
2013 } | |
2014 | |
2015 sub close { | |
2016 my ($self) = @_; | |
2017 my $application = $self->{'-application'}; | |
2018 if ($self->{'-check-script'}) { | |
2019 if ($application eq "Address Book") { | |
2020 $self->print("--close address\n"); | |
2021 $self->print("--close group\n"); | |
2022 # $self->print("with transaction\n"); | |
2023 $self->print("save addressbook\n"); | |
2024 # $self->print("end transaction\n"); | |
2025 } | |
2026 $self->print("quit saving yes\n") | |
2027 if (0 && $self->{'-check-script-count'} % 5 == 4); | |
2028 $self->print("end tell\n"); | |
2029 undef $self->{'-application'}; | |
2030 } | |
2031 $self->{'-telling'} = 0; | |
2032 } | |
2033 | |
2034 sub set_application { | |
2035 my ($self,$application) = @_; | |
2036 | |
2037 if ($application ne $self->{'-application'}) { | |
2038 $self->print("end tell\n") if ($self->{'-telling'} ); | |
2039 $self->{'-application'} = $application; | |
2040 $self->print("\ntell Application \"$application\"\n"); | |
2041 $self->{'-telling'} = 1; | |
2042 } | |
2043 } | |
2044 | |
2045 sub address_book { | |
2046 my ($self,$keys,$record) = @_; | |
2047 my @keys = @$keys; | |
2048 my %record = %$record; | |
2049 my ($tab) = ''; | |
2050 | |
2051 | |
2052 return if(! defined $record{'name'}); | |
2053 $tab .= ' '; | |
2054 | |
8 | 2055 # $self->print("with transaction\n"); |
1 | 2056 if(defined $record{'office'}) { |
2057 my $group = $record{'office'}; | |
2058 $self->print($tab,"if not exists some group whose name is "); | |
2059 $tab .= ' '; | |
2060 $self->print("\"$group\" then \n"); | |
2061 $self->print($tab,"make new group with properties "); | |
2062 $self->print("{name:\"$group\"}\n"); | |
2063 $tab =~ s/ $//; | |
2064 $self->print($tab,"end\n\n"); | |
2065 } | |
2066 $self->print($tab,"set aPerson to make new person with properties {"); | |
2067 $tab .= ' '; | |
2068 | |
2069 my @names; | |
2070 my $data = $record{'name'}; | |
2071 @names = split(/ +/,$data); | |
2072 | |
2073 $self->print("last name: \"",shift(@names),"\","); | |
2074 $self->print("first name: \"@names\"}\n"); | |
2075 | |
2076 $self->print($tab,"tell aPerson\n"); | |
2077 if(defined $record{'name-yomi'}) { | |
2078 if($record{'name-yomi'} =~ /\201H/) { # ? | |
2079 } else { | |
2080 my $data = $record{'name-yomi'}; | |
2081 if ($data =~ /,/) { | |
2082 @names = split(/,/,$data); | |
2083 $data = $names[1].' '.$names[0]; | |
2084 } | |
2085 $data = nkf('-sIZ --hiragana',$data); | |
2086 $data = $self->check_2byte($data); | |
2087 @names = split(/ +/,$data); | |
2088 # put one space to prevent a problem of incomplete Shift JIS | |
2089 $self->print($tab,"set phonetic last name to \"",shift(@names)," \"\n"); | |
2090 $self->print($tab,"set phonetic first name to \"@names \"\n") | |
2091 if (@names); | |
2092 } | |
2093 } | |
2094 | |
2095 if(defined $record{'section'}) { | |
2096 $self->print($tab,"set job title to \"$record{'section'}\"\n"); | |
2097 } | |
2098 if(defined $record{'title'}) { | |
2099 $self->print($tab,"set title to \"$record{'title'}\"\n"); | |
2100 } | |
2101 foreach my $address ('','home-') { | |
2102 my @data = (); | |
2103 if(defined $record{$address."address"}) { | |
2104 my $adr = nkf('-s -Z',$record{$address."address"}); | |
2105 if($adr=~ s/\201\247\s*(\d+)//) { | |
2106 $record{$address.'zip'} = $1; | |
2107 } | |
2108 if($record{$address.'zip'}) { | |
2109 push(@data,",zip:\"$self->{'-zip-labels'}->{$record{$address.'zip'}}\""); | |
2110 } | |
2111 $self->add_address($tab,$adr,$address."address",\@data); | |
2112 } | |
2113 } | |
2114 foreach my $phone ('tel','tel-home','mobile-tel','home-fax','fax') { | |
2115 if(defined $record{$phone}) { | |
2116 $self->add_phone($tab,$record{$phone},$phone); | |
2117 } | |
2118 } | |
2119 foreach my $mail ('mail','mail-to','mail-address') { | |
2120 if(defined $record{$mail}) { | |
2121 $self->add_mail($tab,$record{$mail},$mail); | |
2122 } | |
2123 } | |
2124 | |
2125 if(defined $record{'birth'}) { | |
2126 # it looks like Address Book's apple script has trouble with birth date | |
2127 # $self->print($tab,"set birth date to ",$self->date($record{'birth'}),"\n"); | |
2128 } | |
2129 if(defined $record{'office'}) { | |
2130 $self->print($tab,"set organization to \"$record{'office'}\"\n"); | |
2131 if ($self->{'-do-grouping'}) { | |
2132 $tab =~ s/ $//; | |
2133 $self->print($tab,"end tell\n"); | |
2134 $self->print($tab,"try\n"); | |
2135 $tab .= ' '; | |
2136 $self->print($tab,"add aPerson to some group whose name is \""); | |
2137 $self->print($record{'office'},"\"\n"); | |
2138 $tab =~ s/ $//; | |
2139 $self->print($tab,"end\n"); | |
8 | 2140 # $self->print("end transaction\n"); |
1 | 2141 $self->{'-groups'}->{$record{'office'}} = 1;; |
2142 return; | |
2143 } | |
2144 } | |
2145 $tab =~ s/ $//; | |
2146 $self->print($tab,"end tell\n"); | |
8 | 2147 # $self->print("end transaction\n"); |
1 | 2148 } |
2149 | |
2150 sub check_2byte { | |
2151 my ($self,$data) = @_; | |
2152 my $new = ''; | |
2153 my $tmp; | |
2154 | |
2155 while($data) { | |
2156 if ($data =~ s/^([\000-\177]*)([\200-\377])//) { | |
2157 $new .= $1; $tmp = $2; | |
2158 if (! $data ) { | |
2159 } elsif ($data =~ /^[!-\376]/) { | |
2160 $data =~ s/^.//; | |
2161 $new .= $tmp . $& | |
2162 } | |
2163 } else { | |
2164 $new .= $data; | |
2165 last; | |
2166 } | |
2167 } | |
2168 $new; | |
2169 } | |
2170 | |
2171 | |
2172 sub date { | |
2173 my ($self,$date) = @_; | |
2174 my ($year,$month,$day,$hour,$min) = $date->localtime(); | |
2175 | |
2176 $date = "date \"${year}N $month $day j"; | |
2177 if ($hour) { $date .= " $hour:$min";} | |
2178 $date .= "\""; | |
2179 return $date; | |
2180 } | |
2181 | |
2182 sub add_address { | |
2183 my ($self,$tab,$data,$label,$option) = @_; | |
2184 | |
2185 $label = nkf('-s',$self->{'-address-labels'}->{$label}); | |
2186 $self->print($tab,"make new address at end of address of aPerson "); | |
2187 $self->print("with properties {street:\"$data\", label:\"$label\"@$option}\n"); | |
2188 } | |
2189 | |
2190 sub add_phone { | |
2191 my ($self,$tab,$data,$label) = @_; | |
2192 | |
2193 $label = nkf('-s',$self->{'-phone-labels'}->{$label}); | |
2194 $self->print($tab,"make new phone at end of phone of aPerson with properties {value:\"$data\", label:\"$label\"}\n"); | |
2195 } | |
2196 | |
2197 sub add_mail { | |
2198 my ($self,$tab,$data,$label) = @_; | |
2199 | |
2200 $label = nkf('-s',$self->{'-mail-labels'}->{$label}); | |
2201 $self->print($tab,"make new email at end of email of aPerson with properties {value:\"$data\", label:\"$label\"}\n"); | |
2202 } | |
2203 | |
2204 sub make_group { | |
2205 my ($self) = @_; | |
2206 my (%groups) = %{$self->{'-groups'}}; | |
2207 my $tab = ' '; | |
2208 | |
2209 return if (! %groups); | |
2210 open OUT,"> script-out/group.script" or cloak($!); | |
2211 select OUT; | |
2212 $self->print("tell application \"Address Book\"\n"); | |
2213 foreach my $group (keys %groups) { | |
2214 $self->print($tab,"if not exists some group whose name is "); | |
2215 $tab .= ' '; | |
2216 $self->print("\"$group\" then \n"); | |
2217 $self->print($tab,"make new group with properties "); | |
2218 $self->print("{name:\"$group\"}\n"); | |
2219 $tab =~ s/ $//; | |
2220 $self->print($tab,"end\n"); | |
2221 } | |
2222 $self->print("close group\n"); | |
8 | 2223 # $self->print("with transaction\n"); |
1 | 2224 $self->print("save addressbook\n"); |
8 | 2225 # $self->print("end transaction\n"); |
1 | 2226 $self->print("quit saving yes\n"); |
2227 $self->print("end tell\n"); | |
2228 } | |
2229 | |
2230 sub ical { | |
2231 my ($self,$keys,$record) = @_; | |
2232 my @keys = @$keys; | |
2233 my %record = %$record; | |
2234 my ($tab) = ''; | |
2235 | |
2236 # $self->print("with transaction\n"); | |
2237 # $self->print($tab,"set aDay to "); | |
2238 $self->print("make new event at end of event of last calendar with properties {"); | |
2239 if ($record{'date'}->is_allday() && $self->{'-fake-allday'} ) { | |
2240 $record{'date'} = $record{'date'}->add($self->{'-time-for-allday'}); | |
2241 $record{'end-date'} = | |
2242 $record{'date'}->add($self->{'-add-time-for-allday'}); | |
2243 } | |
2244 $self->print($tab,"start date:",$self->date($record{'date'})); | |
2245 if (defined $record{'end-date'}) { | |
2246 if ($record{'date'}->value() == $record{'end-date'}->value()) { | |
2247 $record{'end-date'} = | |
2248 $record{'date'}->add($self->{'-add-time-for-allday'}); | |
2249 } | |
2250 $self->print($tab,",end date:",$self->date($record{'end-date'})) | |
2251 } | |
2252 $self->print($tab,",stamp date:",$self->date($record{'modify-date'})) | |
2253 if (defined $record{'modify-date'}); | |
2254 if (defined($record{'memo'})) { | |
2255 my ($summary,$memo); | |
2256 if (defined($record{'summary'})) { | |
2257 $summary = $record{'summary'}; | |
2258 $memo = $record{'memo'}; | |
2259 } else { | |
2260 $summary = $record{'memo'}; | |
2261 # if this contains double quote we have a problem. But | |
2262 # I cannot fix it without decoding shift JIS and backslash/0x80 | |
2263 # conversion. | |
2264 $summary =~ s/"//g; # oops | |
2265 $summary =~ s/[\r\n].*$//; $memo = $&; | |
2266 } | |
2267 | |
2268 $self->print($tab,",summary:\"",$summary,"\"") if ($summary); | |
2269 $self->print($tab,",description:\"",$memo,"\"") if ($memo); | |
2270 } | |
2271 $self->print($tab,"}\n"); | |
2272 | |
2273 # $self->print($tab,"tell aDay\n"); | |
2274 # $self->print($tab,"if start date = end date then\n"); | |
2275 # $self->print($tab," set end date to start date + ". | |
2276 # int($self->{'-add-time-for-allday'}/60)." * minutes\n"); | |
2277 # $self->print($tab,"end if\n"); | |
2278 # $self->print($tab,"end\n"); | |
2279 # $self->print("end transaction\n"); | |
2280 } | |
2281 | |
2282 #######################################################################/ | |
2283 | |
2284 package Calcon::Entourage_write ; | |
2285 | |
2286 # Mac のEntrourage に AppleScript 経由で書き出す。ここでも Mac::AppleScript | |
2287 # は使わない。 | |
2288 | |
2289 use strict; | |
2290 # use warnings; | |
2291 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
2292 use NKF; | |
2293 @ISA = ( 'Calcon::iApp_write' ); | |
2294 | |
2295 sub initialize { | |
2296 my ($self) = @_; | |
2297 $self->SUPER::initialize(); | |
2298 | |
2299 $self->{'-fake-allday'} = 0; | |
2300 $self->{'-time-for-allday'} = 12*3600; | |
2301 $self->{'-add-time-for-allday'} = 2*3600; | |
2302 | |
2303 $self->{'-check-script'} = 1; | |
2304 $self->{'-check-group'} = 20; | |
2305 | |
2306 $self->{'-init-file'} = "s000000"; | |
2307 $self->{'-check-script-count'} = 0; | |
2308 $self->{'-japanese-format'} = 1; | |
2309 $self->{'-script-name'} = $self->{'-init-file'}; | |
2310 | |
2311 $self->{"-phone-labels"} = { | |
2312 "tel"=>"business phone number", | |
2313 "tel-home"=>"home phone number", | |
2314 "mobile-tel"=>"mobile phone number", | |
2315 "home-fax"=>"home fax phone number", | |
2316 "fax"=>"business fax phone number", | |
2317 | |
2318 }; | |
2319 } | |
2320 | |
2321 sub record { | |
2322 my ($self,$keys,$record) = @_; | |
2323 | |
2324 $self->start_record(''); | |
2325 | |
2326 # check proper application | |
2327 if (defined $record->{'name'}) { | |
2328 my $application = 'Microsoft Entourage'; | |
2329 $self->set_application($application); | |
2330 $self->contact($keys,$record); | |
2331 $self->print("end tell\n") if (! $self->{'-check-script'}) ; | |
2332 } elsif (defined $record->{'date'}) { | |
2333 if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); } | |
2334 my $application = 'Microsoft Entourage'; | |
2335 $self->set_application($application); | |
2336 $self->event($keys,$record); | |
2337 $self->print("end tell\n") if (! $self->{'-check-script'}) ; | |
2338 } else { | |
2339 # nothing to do | |
2340 } | |
2341 $self->print("\n"); | |
2342 } | |
2343 | |
2344 sub close { | |
2345 my ($self) = @_; | |
2346 my $application = $self->{'-application'}; | |
2347 if ($self->{'-check-script'}) { | |
2348 $self->print("quit saving yes\n") | |
2349 if (0 && $self->{'-check-script-count'} % 5 == 4); | |
2350 $self->print("end tell\n"); | |
2351 undef $self->{'-application'}; | |
2352 } | |
2353 $self->{'-telling'} = 0; | |
2354 } | |
2355 | |
2356 sub make_group { | |
2357 } | |
2358 | |
2359 sub contact { | |
2360 my ($self,$keys,$record) = @_; | |
2361 my @keys = @$keys; | |
2362 my %record = %$record; | |
2363 my ($tab) = ''; | |
2364 my @names; | |
2365 my $data = $record{'name'}; | |
2366 @names = split(/ +/,$data); | |
2367 | |
8 | 2368 # $self->print("with transaction\n"); |
1 | 2369 $tab .= ' '; |
2370 | |
2371 | |
2372 # $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"; | |
2373 | |
2374 $self->print($tab,"set aPerson to make new contact with properties {"); | |
2375 | |
2376 $tab .= ' '; | |
2377 | |
2378 $self->print($tab,"last name: \"",shift(@names),"\","); | |
2379 $self->print($tab,"first name: \"@names\"}\n"); | |
2380 $tab =~ s/ //; | |
2381 # $self->print($tab,"end\n"); | |
2382 | |
2383 | |
2384 $self->print($tab,"tell aPerson\n"); | |
2385 if(defined $record{'name-yomi'}) { | |
2386 if($record{'name-yomi'} =~ /\201H/) { # ? | |
2387 } else { | |
2388 my $data = $record{'name-yomi'}; | |
2389 if ($data =~ /,/) { | |
2390 @names = split(/,/,$data); | |
2391 $data = $names[1].' '.$names[0]; | |
2392 } | |
2393 $data = nkf('-sIZ --hiragana',$data); | |
2394 $data = $self->check_2byte($data); | |
2395 @names = split(/ +/,$data); | |
2396 # put one space to prevent a problem of incomplete Shift JIS | |
2397 $self->print($tab,"set last name furigana to \"",shift(@names)," \"\n"); | |
2398 $self->print($tab,"set first name furigana to \"@names \"\n") | |
2399 if (@names); | |
2400 } | |
2401 } | |
2402 | |
2403 $self->print($tab,"set japanese format to true\n") if ($self->{'-japanese-format'}); | |
2404 if(defined $record{'section'}) { | |
2405 $self->print($tab,"set department to \"$record{'section'}\"\n"); | |
2406 } | |
2407 if(defined $record{'title'}) { | |
2408 $self->print($tab,"set job title to \"$record{'title'}\"\n"); | |
2409 } | |
2410 if(defined $record{'address'}) { | |
2411 $self->print($tab,"set business address to {", | |
2412 "zip:\"$record{'zip'}\",", | |
2413 "street address:\"$record{'address'}\"", | |
2414 "}\n" | |
2415 ); | |
2416 } | |
2417 if(defined $record{'home-address'}) { | |
2418 $self->print($tab,"set home address to {", | |
2419 "zip:\"$record{'home-zip'}\",", | |
2420 "street address:\"$record{'home-address'}\"", | |
2421 "}\n" | |
2422 ); | |
2423 } | |
2424 | |
2425 foreach my $phone ('tel','tel-home','mobile-tel','home-fax','fax') { | |
2426 if(defined $record{$phone}) { | |
2427 $self->print($tab,"set ",$self->{'-phone-labels'}->{$phone}, | |
2428 " to \"",$record{$phone},"\"\n" | |
2429 ); | |
2430 } | |
2431 } | |
2432 | |
2433 # $self->print($tab,"delete every email address of aPerson\n"); | |
2434 foreach my $mail ('mail','mail-to','mail-address') { | |
2435 if(defined $record{$mail}) { | |
2436 foreach my $m (split(/,/,$record{$mail})) { | |
2437 $self->print($tab,"make new email address of aPerson with data \"$m\"\n"); | |
2438 } | |
2439 } | |
2440 } | |
2441 | |
2442 if(defined $record{'birth'}) { | |
2443 $self->print($tab,"set birthday to \"",$self->birth_date($record{'birth'}),"\"\n"); | |
2444 } | |
2445 if(defined $record{'office'}) { | |
2446 $self->print($tab,"set company to \"$record{'office'}\"\n"); | |
2447 } | |
2448 if(defined $record{'office-yomi'}) { | |
2449 $self->print($tab,"set company furigana to \"$record{'office-yomi'}\"\n"); | |
2450 } | |
2451 $tab =~ s/ $//; | |
2452 $self->print($tab,"end tell\n"); | |
8 | 2453 # $self->print("end transaction\n"); |
1 | 2454 } |
2455 | |
2456 sub birth_date { | |
2457 my ($self,$date) = @_; | |
2458 my ($year,$month,$day,$hour,$min) = $date->localtime(); | |
2459 | |
2460 if (!$year) { $year = '';} else { $year = "$year/"; } | |
2461 $date = "$year$month/$day"; | |
2462 if ($hour) { $date .= " $hour:$min";} | |
2463 return $date; | |
2464 } | |
2465 | |
2466 | |
2467 sub event { | |
2468 my ($self,$keys,$record) = @_; | |
2469 my @keys = @$keys; | |
2470 my %record = %$record; | |
2471 my ($tab) = ''; | |
2472 | |
2473 # $self->print("with transaction\n"); | |
2474 # $self->print($tab,"set aDay to "); | |
2475 $self->print("make new event with properties {"); | |
2476 | |
2477 # make new event with properties {subject:"", location:"", content: | |
2478 # "", start time:date "2002N 11 13 j 0:00:00 PM", end time:date | |
2479 # "2002N 11 13 j 0:30:00 PM", all day event:false, recurring:false, | |
2480 # category:{}, links:{}, remind time:1440, recurrence:""} | |
2481 | |
2482 if ( $record{'date'}->is_allday()) { | |
2483 $self->print($tab,"all day event: true,"); | |
2484 $self->print($tab,"start time:",$self->date($record{'date'})); | |
2485 } else { | |
2486 $self->print($tab,"all day event: false,"); | |
2487 $self->print($tab,"start time:",$self->date($record{'date'})); | |
2488 if (defined $record{'end-date'}) { | |
2489 $self->print($tab,",end time:",$self->date($record{'end-date'})) | |
2490 } | |
2491 } | |
2492 # $self->print($tab,",stamp date:",$self->date($record{'modify-date'})) | |
2493 # if (defined $record{'modify-date'}); | |
2494 if (defined($record{'memo'})) { | |
2495 my ($summary,$memo); | |
2496 if (defined($record{'summary'})) { | |
2497 $summary = $record{'summary'}; | |
2498 $memo = $record{'memo'}; | |
2499 } else { | |
2500 $summary = $record{'memo'}; | |
2501 # if this contains double quote we have a problem. But | |
2502 # I cannot fix it without decoding shift JIS and backslash/0x80 | |
2503 # conversion. | |
2504 $summary =~ s/"//g; # oops | |
2505 $summary =~ s/[\r\n].*$//; $memo = $&; | |
2506 } | |
2507 | |
2508 $self->print($tab,",subject:\"",$summary,"\"") if ($summary); | |
2509 $self->print($tab,",content:\"",$memo,"\"") if ($memo); | |
2510 } | |
2511 $self->print($tab,"}\n"); | |
2512 | |
2513 } | |
2514 | |
2515 | |
2516 #######################################################################/ | |
2517 | |
2518 package Calcon::Sla300_read; | |
2519 | |
2520 # Linux Zaurus SLA300 の XML形式 | |
2521 # でもなんか新しくなって、これではなくなったらしい。しくしく。 | |
2522 | |
2523 use strict; | |
2524 # use warnings; | |
2525 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
2526 @ISA = ( 'Calcon::Reader') ; | |
2527 | |
2528 use NKF; | |
2529 use Time::Local; | |
2530 | |
2531 my %keys = ( | |
2532 'birthday'=>'birth', | |
2533 'businessfax'=>'fax', | |
2534 'businessmobile'=>'keitai', | |
2535 'businessphone'=>'tel', | |
2536 'businessstate'=>'state', | |
2537 'businessstreet'=>'address', | |
2538 'businesszip'=>'zip', | |
2539 'categories'=>'categories', | |
2540 'company'=>'office', | |
2541 'companypronunciation'=>'office-yomi', | |
2542 'department'=>'section', | |
2543 'description'=>'memo', | |
2544 'emails'=>'email', | |
2545 'end'=>'end-date', | |
2546 'firstname'=>'first-name', | |
2547 'firstnamepronunciation'=>'first-name-yomi', | |
2548 'homefax'=>'home-fax', | |
2549 'homemobile'=>'home-keitai', | |
2550 'homephone'=>'home-tel', | |
2551 'homestate'=>'home_state', | |
2552 'homestreet'=>'home-address', | |
2553 'homezip'=>'home-zip', | |
2554 'jobtitle'=>'title', | |
2555 'lastname'=>'name', | |
2556 'lastnamepronunciation'=>'name-yomi', | |
2557 'notes'=>'memo', | |
2558 'rid'=>'rid', | |
2559 'rinfo'=>'rinfo', | |
2560 'start'=>'date', | |
2561 'uid'=>'uid', | |
2562 ); | |
2563 | |
2564 sub initialize { | |
2565 my ($self) = @_; | |
2566 $self->SUPER::initialize(); | |
2567 $self->{'-keywords'} = \%keys; | |
2568 } | |
2569 | |
2570 sub decode { | |
2571 my ($self,$file) = @_; | |
2572 my $out = $self->{'-output'}; | |
2573 | |
2574 $self->{'-file'} = $file; | |
2575 open(F,"<".$file); | |
2576 | |
2577 $out->start_file(''); | |
2578 | |
2579 local($/) = ">"; | |
2580 while(<F>) { | |
2581 $self->xml_decode($_); | |
2582 } | |
2583 $out->end_file(''); | |
2584 } | |
2585 | |
2586 sub xml_decode { | |
2587 my($self,$xml) = @_; | |
2588 my($out) = $self->{'-output'}; | |
2589 my($convert) = $self->{'-keywords'}; | |
2590 | |
2591 $xml =~ s/^\s*<([^ ]*) // or return; | |
2592 my $type = $1; | |
2593 $xml =~ s=/>\s*$== or return; | |
2594 $type =~ tr/A-Z/a-z/; | |
2595 return if ($type ne 'contact' && $type ne 'event'); | |
2596 my $record = $self->make_record; | |
2597 my $keys = []; | |
2598 $_ = $xml; | |
2599 while($_) { | |
2600 if (s/^\s*([^\s]*)\s*\=\s*\"(.*?)\"\s*//) { | |
2601 my $key = $1; | |
2602 my $data = $2; | |
2603 $key =~ tr/A-Z/a-z/; | |
2604 $key = $convert->{$key} if ( $convert->{$key} ); | |
2605 if ($key =~ /birth$/) { | |
2606 my (@data) = ($data =~ /(\d+)/g); | |
2607 $data = $self->make_date(join("/",@data)); | |
2608 } elsif ($key =~ /date$/) { | |
2609 $data = $self->make_date_unix($data); | |
2610 } else { | |
2611 $data = nkf('-eZ -W',$data); | |
2612 } | |
2613 $record->{$key} = $data; | |
2614 push(@$keys,$key); | |
2615 } else { | |
2616 s/^[^\s]*\s*//; | |
2617 } | |
2618 } | |
5 | 2619 if (defined($record->{'type'}) && $record->{'type'} =~ /Allday/i) { |
1 | 2620 undef $record->{'end-date'}; |
2621 @$keys = grep(!/^end-date/,@$keys); | |
2622 } | |
2623 $out->record($keys,$record); | |
2624 } | |
2625 | |
2626 | |
2627 #######################################################################/ | |
2628 | |
2629 package Calcon::Sla300_write; | |
2630 | |
2631 # Linux Zaurus SLA300 の XML形式 | |
2632 # でもなんか新しくなって、これではなくなったらしい。しくしく。 | |
2633 | |
2634 use strict; | |
2635 # use warnings; | |
2636 use Time::Local; | |
2637 use NKF; | |
2638 use Carp; | |
2639 | |
2640 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
2641 @ISA = ('Calcon::Buffered_Writer'); | |
2642 | |
2643 # Mac OS X 10.2 's Address Book requires utf-16 | |
2644 # | nkf -Z -e|iconv -c -f EUC-JP -t UTF-16 | |
2645 # | |
2646 | |
2647 sub initialize { | |
2648 my ($self) = @_; | |
2649 $self->SUPER::initialize(); | |
2650 $self->{'-fake-allday'} = 0; | |
2651 $self->{'-time-for-allday'} = 12*3600; | |
2652 $self->{'-add-time-for-allday'} = 2*3600; | |
2653 } | |
2654 | |
2655 sub write_datebook { | |
2656 my ($self) = @_; | |
2657 my $count = $self->{'-date-max'}; | |
2658 | |
2659 open(CAL,">datebook.xml") or croak($!); | |
2660 $self->print ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"); | |
2661 $self->print ( "<!DOCTYPE DATEBOOK><DATEBOOK>\n"); | |
2662 $self->print ( "<RIDMax>$count</RIDMax>\n"); | |
2663 my $uid = -1032244274; | |
2664 my $rid = 11; | |
2665 | |
2666 for my $dates ( @{$self->{'-date-records'}} ) { | |
2667 | |
2668 my $end_date = $dates->{'end-date'}; | |
2669 if (! $end_date) { | |
2670 if ($dates->{'date'}->is_allday()) { | |
2671 if ($self->{'-fake-allday'}) { | |
2672 $dates->{'date'}= | |
2673 $dates->{'date'}->add($self->{'-time-for-allday'}); | |
2674 $dates->{'end-date'} = | |
2675 $dates->{'date'}->add($self->{'-add-time-for-allday'}); | |
2676 $dates->{'date'} = $self->unix_time($dates->{'date'}); | |
2677 } else { | |
2678 $end_date = $dates->{'date'}->add(23*3600+59*60); | |
2679 $dates->{'type'} = "AllDay"; | |
2680 $dates->{'date'} = $self->unix_time($dates->{'date'}); | |
2681 $dates->{'end-date'} = $self->unix_time($end_date); | |
2682 } | |
2683 } else { | |
2684 $end_date = | |
2685 $dates->{'date'}->add($self->{'-add-time-for-allday'}); | |
2686 $dates->{'date'} = $self->unix_time($dates->{'date'}); | |
2687 $dates->{'end-date'} = $self->unix_time($end_date); | |
2688 } | |
2689 } else { | |
2690 $dates->{'date'} = $self->unix_time($dates->{'date'}); | |
2691 $dates->{'end-date'} = $self->unix_time($dates->{'end-date'}) | |
2692 } | |
4 | 2693 # warning killer |
2694 if (! defined($dates->{'summary'})) { $dates->{'summary'} = '';}; | |
2695 if (! defined($dates->{'memo'})) { $dates->{'memo'} = '';}; | |
1 | 2696 $dates->{'memo'} = nkf('-w -Z3',$dates->{'summary'}.$dates->{'memo'}); |
2697 | |
2698 my $memo = $dates->{'memo'}; | |
2699 my $start_time = $dates->{'date'}; | |
2700 my $end_time = $dates->{'end-date'}; | |
2701 $self->print("<event description=\"$memo\" categories=\"\" uid=\"$uid\" rid=\"$rid\" rinfo=\"1\" start=\"$start_time\""); | |
2702 if ($dates->{'end-date'}) { | |
2703 $self->print(" end=\"$end_time\""); | |
2704 } | |
2705 if ($dates->{'type'}) { | |
2706 $self->print(" type=\"$dates->{'type'}\""); | |
2707 } | |
2708 $self->print("/>\n"); | |
2709 $uid++; | |
2710 $rid++; | |
2711 $count--; | |
2712 } | |
2713 $self->print("<events>\n"); | |
2714 $self->print("</events>\n"); | |
2715 $self->print("</DATEBOOK>\n"); | |
2716 } | |
2717 | |
2718 sub write_addressbook { | |
2719 my ($self) = @_; | |
2720 my $count = $self->{'-adr-max'}; | |
2721 | |
2722 open(CAL,">addressbook.xml") or croak($!); | |
2723 | |
2724 $self->print ( "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"); | |
2725 $self->print ( "<!DOCTYPE Addressbook ><AddressBook>\n"); | |
2726 $self->print ( "<RIDMax>$count</RIDMax>\n"); | |
2727 $self->print ( "<Groups></Groups>\n"); | |
2728 for my $adr ( @{$self->{'-address-records'}} ) { | |
2729 | |
2730 if (defined $adr->{'birth'}){ | |
4 | 2731 $adr->{'birth'} = $self->birth_date($adr->{'birth'}) ; |
1 | 2732 } |
2733 | |
2734 my ($address) = $adr->{'address'}; | |
2735 my ($birth) = $adr->{'birth'}; | |
2736 my ($company) = $adr->{'office'}; | |
2737 my ($email) = $adr->{'email'}; | |
2738 my ($fax) = $adr->{'fax'}; | |
2739 my ($first_name) = $adr->{'first-name'}; | |
2740 my ($first_name_yomi) = $adr->{'first-name-yomi'}; | |
2741 my ($home_address) = $adr->{'home-address'}; | |
2742 my ($home_fax) = $adr->{'home-fax'}; | |
2743 my ($home_keitai) = $adr->{'home-keitai'}; | |
2744 my ($home_state) = $adr->{'home_state'}; | |
2745 my ($home_tel) = $adr->{'home-tel'}; | |
2746 my ($home_zip) = $adr->{'home-zip'}; | |
2747 my ($keitai) = $adr->{'keitai'}; | |
2748 my ($last_name) = $adr->{'name'}; | |
2749 my ($memo) = $adr->{'memo'}; | |
2750 my ($name_yomi) = $adr->{'name-yomi'}; | |
2751 my ($name) = $adr->{'name'}; | |
2752 my ($office_yomi) = $adr->{'office-yomi'}; | |
2753 my ($section) = $adr->{'section'}; | |
2754 my ($state) = $adr->{'state'}; | |
2755 my ($tel) = $adr->{'tel'}; | |
2756 my ($title) = $adr->{'title'}; | |
2757 my ($zip) = $adr->{'zip'}; | |
2758 | |
2759 $self->print ( "<Contact "); | |
2760 $self->print ( "LastName=\"$last_name\" " ) if ($last_name); | |
2761 $self->print ( "FirstName=\"$first_name\" " ) if ($first_name); | |
2762 $self->print ( "JobTitle=\"$title\" " ) if ($title); | |
2763 $self->print ( "Department=\"$section\" " ) if ($section); | |
2764 $self->print ( "Company=\"$company\" " ) if ($company); | |
2765 $self->print ( "Birthday=\"$birth\" " ) if ($birth); | |
2766 $self->print ( "BusinessPhone=\"$tel\" " ) if ($tel); | |
2767 $self->print ( "BusinessFax=\"$fax\" " ) if ($fax); | |
2768 $self->print ( "BusinessStreet=\"$address\" " ) if ($address); | |
2769 $self->print ( "BusinessState=\"$state\" " ) if ($state); | |
2770 $self->print ( "BusinessZip=\"$zip\" " ) if ($zip); | |
2771 $self->print ( "BusinessMobile=\"$keitai\" " ) if ($keitai); | |
2772 $self->print ( "HomePhone=\"$home_tel\" " ) if ($home_tel); | |
2773 $self->print ( "HomeMobile=\"$home_keitai\" " ) if ($home_keitai); | |
2774 $self->print ( "HomeFax=\"$home_fax\" " ) if ($home_fax); | |
2775 $self->print ( "HomeStreet=\"$home_address\" " ) if ($home_address); | |
2776 $self->print ( "HomeState=\"$home_state\" " ) if ($home_state); | |
2777 $self->print ( "HomeZip=\"$home_zip\" " ) if ($home_zip); | |
2778 $self->print ( "Emails=\"$email\" " ) if ($email); | |
2779 $self->print ( "Notes=\"$memo\" " ) if ($memo); | |
2780 $self->print ( "rid=\"$count\" "); | |
2781 $self->print ( "rinfo=\"1\" "); | |
2782 $self->print ( "LastNamePronunciation=\"$name_yomi\" " ) if ($name_yomi); | |
2783 $self->print ( "FirstNamePronunciation=\"$first_name_yomi\" " ) if ($first_name_yomi); | |
2784 $self->print ( "CompanyPronunciation=\"$office_yomi\" " ) if ($office_yomi); | |
2785 $self->print ( "/>\n"); | |
2786 | |
2787 $count--; | |
2788 } | |
2789 $self->print ( "</Contact>\n"); | |
2790 $self->print ( "</AddressBook>\n"); | |
2791 } | |
2792 | |
2793 sub birth_date { | |
2794 my ($self,$date) = @_; | |
2795 my ($year,$month,$day,$hour,$min) = $date->localtime(); | |
2796 | |
2797 if ($date->is_day()) { | |
2798 return "$month/$day"; | |
2799 } | |
2800 return "$year/$month/$day"; | |
2801 } | |
2802 | |
2803 sub print { | |
2804 my ($self,@data) = @_; | |
5 | 2805 print CAL nkf("-w -Z3",@data); |
1 | 2806 } |
2807 | |
2808 #######################################################################/ | |
2809 | |
2810 package Calcon::Vcard_write; | |
2811 use strict; | |
2812 # use warnings; | |
2813 use NKF; | |
2814 | |
2815 # VCARD 形式 | |
2816 | |
2817 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
2818 @ISA = ( 'Calcon::Writer' ); | |
2819 | |
2820 # Mac OS X 10.2 's Address Book requires utf-16 | |
2821 # | nkf -Z -e|iconv -c -f EUC-JP -t UTF-16 | |
2822 # | |
2823 | |
2824 sub initialize { | |
2825 my ($self) = @_; | |
2826 $self->SUPER::initialize(); | |
2827 $self->{'-fake-allday'} = 1; | |
2828 $self->{'-time-for-allday'} = 12*3600; | |
2829 $self->{'-add-time-for-allday'} = 2*3600; | |
2830 } | |
2831 | |
2832 sub record { | |
2833 my ($self,$keys,$record) = @_; | |
2834 my ($application); | |
2835 | |
2836 if(defined($record->{'name'})) { | |
2837 $self->vcard($keys,$record); | |
2838 } elsif(defined($record->{'date'})) { | |
2839 if ($record->{'date'}) { return if ($self->{'-future-only'} && ! $record->{'date'}->future()); } | |
2840 $self->vcal($keys,$record); | |
2841 } else { | |
2842 # I don't know. | |
2843 } | |
2844 } | |
2845 | |
2846 sub end_file { | |
2847 my ($self) = @_; | |
2848 if ($self->{'-vcal-opening'}) { | |
2849 print "END:VCALENDAR\n"; | |
2850 $self->{'-vcal-opening'} = 0; | |
2851 } | |
2852 } | |
2853 | |
2854 sub print { | |
2855 my ($self,@data) = @_; | |
2856 foreach (@data) { | |
2857 my $data = nkf('-s -Z',$_); | |
2858 $data =~ s/\354\276/\203_/g; | |
2859 $data =~ s/\356\276/ /g; | |
2860 $data =~ s/\356\277/ /g; | |
2861 $data =~ s/([^\200-\377])\\/$1\200/g; | |
2862 # $data =~ s/\201/\/g; | |
2863 $data = nkf('-w',$_); | |
2864 $data =~ s/\000/ /g; | |
2865 print $data; | |
2866 } | |
2867 } | |
2868 | |
2869 sub vcal { | |
2870 my ($self,$keys,$record) = @_; | |
2871 my (%record) = %{$record}; | |
2872 my $data; | |
2873 | |
2874 my $timezone = "Asia/Tokyo"; | |
2875 | |
2876 if (! $self->{'-vcal-opening'}) { | |
2877 print(<<"EOFEOF"); | |
2878 BEGIN:VCALENDAR | |
2879 CALSCALE:GREGORIAN | |
2880 X-WR-TIMEZONE;VALUE=TEXT:Asia/Tokyo | |
2881 METHOD:PUBLISH | |
2882 VERSION:2.0 | |
2883 EOFEOF | |
2884 $self->{'-vcal-opening'} = 1; | |
2885 } | |
2886 | |
2887 if ($record{'date'}->is_allday() && $self->{'-fake-allday'}) { | |
2888 $record{'date'}=$record{'date'}->add($self->{'-time-for-allday'}); | |
2889 } | |
2890 my $dtstart = "\nDTSTART;TZID=$timezone:".$self->date($record{'date'}); | |
5 | 2891 my $dtend = ''; |
2892 my $dtstamp = ''; | |
1 | 2893 |
2894 if (! defined( $record{'end-date'}) || $record{'end-date'} == $record{'date'} ) { | |
2895 # $dtend = "\nDURATION:PT2H"; this is useless for iCal | |
2896 $record{'end-date'} = $record{'date'}->add( | |
2897 $self->{'-add-time-for-allday'}); | |
2898 $dtend = "\nDTEND;TZID=$timezone:".$self->date($record{'end-date'}); | |
2899 } else { | |
2900 $dtend = "\nDTEND;TZID=$timezone:".$self->date($record{'end-date'}); | |
2901 } | |
2902 if (defined( $record{'modify-date'})) { | |
2903 $dtstamp = "\nDTSTAMP;TZID=$timezone:".$self->date($record{'modify-date'}); | |
2904 } | |
2905 | |
5 | 2906 my $summary = ''; |
2907 my $description = ''; | |
1 | 2908 if (defined($record{'memo'})) { |
2909 $summary = $record{'memo'}; | |
2910 $summary =~ s/[\r\n].*$//; $description = $&; | |
2911 | |
2912 $description =~ s/[\n\r]/\n /mg; | |
2913 $description =~ s/\s*$//; | |
2914 $summary =~ s/[\n\r]/ /mg; | |
2915 $summary =~ s/\s*$//; | |
2916 } | |
2917 | |
2918 if ($description eq $summary) { | |
2919 $description = ""; | |
2920 } else { | |
2921 if ($description) { | |
2922 $description = "\nDESCRIPTION: $description"; | |
2923 } | |
2924 } | |
2925 return if (! $description && ! $summary ); | |
2926 | |
2927 # DURATION:PT1H = "DURATION:PT1H"; | |
2928 # X-WR-CALNAME;VALUE=TEXT:ホーム | |
2929 # X-WR-TIMEZONE;VALUE=TEXT:Asia/Tokyo | |
2930 # SEQUENCE:$i | |
2931 | |
2932 $self->print(<<"EOFEOF"); | |
2933 BEGIN:VEVENT | |
2934 SUMMARY:$summary$dtstart$dtend$description$dtstamp | |
2935 END:VEVENT | |
2936 EOFEOF | |
2937 # print "\n"; | |
2938 } | |
2939 | |
2940 sub date { | |
2941 my ($self,$date) = @_; | |
5 | 2942 my ($year,$month,$day,$hour,$min) = $self->localtime($date); |
1 | 2943 |
2944 $date = sprintf("%04d%02d%02dT%02d%02d%02d", | |
5 | 2945 $year,$month,$day,$hour,$min,0); |
1 | 2946 return $date; |
2947 } | |
2948 | |
2949 sub vcard { | |
2950 my ($self,$keys,$record) = @_; | |
2951 my (%record) = %{$record}; | |
2952 my $data; | |
2953 | |
2954 if(defined($record{'office'})) { | |
2955 $record{'office'} = 'etc' if(! $record{'office'}) ; | |
2956 } | |
2957 if(defined($record{'name-yomi'})) { | |
2958 $record{'name-yomi'} =~ s/^ *//; | |
2959 } | |
2960 if(defined($record{'office-yomi'})) { | |
2961 $record{'office-yomi'} =~ s/^ *//; | |
2962 } | |
2963 $record{'secret'} = ' ' if(! $record{'secret'}); | |
2964 $record{'alarm'} = ' ' if(! $record{'alarm'}) ; | |
2965 $record{'class'} = ' ' if(! defined($record{'class'})); | |
2966 $record{'print-format'} = '2220' if(! defined($record{'print-format'})); | |
2967 $record{'mark'} = '00' if(! defined($record{'mark'})); | |
2968 $record{'priority'} = '01' if(! defined($record{'priority'})); | |
2969 if ($record{'time'} =~ /(.*)-(.*)/) { | |
2970 $record{'time'} = $1; | |
2971 $record{'end-time'} = $2; | |
2972 } | |
2973 | |
2974 print "begin:vcard\n"; | |
2975 print "version:3.0\n"; | |
2976 if(defined $record{'name'}) { | |
2977 $data = $record{'name'}; | |
2978 print "FN:$data\n" if($data); | |
2979 if(0 && defined $record{'name-yomi'}) { | |
2980 $data = join(";",split(/ /,$record{'name-yomi'})); | |
2981 print "N:$data\n" if($data); | |
2982 } else { | |
2983 $data = join(";",split(/ /,$data)); | |
2984 print "N:$data\n" if($data); | |
2985 } | |
2986 if(defined $record{'name-yomi'}) { | |
2987 my ($last , $first , $last_yomi , $first_yomi ); | |
2988 $last = $first = $last_yomi = $first_yomi = ''; | |
2989 ($last,$first) = split(/ /,$record{'name'}); | |
2990 ($last_yomi,$first_yomi) = split(/ /,$record{'name-yomi'}), | |
8 | 2991 # print YOMI $last,"\n"; |
2992 # print YOMI $last_yomi,"\n"; | |
2993 # print YOMI $first,"\n"; | |
2994 # print YOMI $first_yomi,"\n"; | |
1 | 2995 } |
2996 | |
2997 # print "fn:$data\n" if($data); | |
2998 # if(defined $record{'office'}) { | |
2999 # $data = $data.";".$record{'office'}; | |
3000 # } | |
3001 # print "n:$data\n" if($data); | |
3002 } | |
3003 if(defined $record{'office'}) { | |
3004 $data = "$record{'office'}"; | |
3005 if(defined $record{'section'}) { | |
3006 $data .= ";".$record{'section'}; | |
3007 } | |
3008 print "org:$data\n" if($data); | |
3009 } | |
3010 if(defined $record{'title'}) { | |
3011 $data = "$record{'title'}"; | |
3012 print "title:$data\n" if($data); | |
3013 } | |
3014 if(defined $record{'address'}) { | |
3015 my ($adr1 , $adr2 , $adr_state , $adr_zip , $adr_country ); | |
3016 $adr1 = $adr2 = $adr_state = $adr_zip = $adr_country = ''; | |
3017 $data = $record{'address'}; | |
3018 $adr1 = $record{'address'}; | |
3019 # ADD:番地;;町村;沖縄;903-0213;日本 | |
3020 if(defined $record{'zip'}) { | |
3021 $adr_zip = $record{'zip'}; | |
3022 } | |
3023 # print "adr;type=work;type=pref:$data\n" if($data); | |
3024 print "adr;type=work;type=pref:;;$adr1;$adr2;$adr_state;$adr_zip;$adr_country\n" if ($data); | |
3025 print "label;type=work;type=pref:$adr_zip $data\n" if($data); | |
3026 } | |
3027 if(defined $record{'tel'}) { | |
3028 $data = $record{'tel'}; | |
3029 print "tel;type=work:$data\n" if($data); | |
3030 } | |
3031 if(defined $record{'tel2'}) { | |
3032 $data = $record{'tel2'}; | |
3033 print "tel;type=cell:$data\n" if($data); | |
3034 } | |
3035 if(defined $record{'fax'}) { | |
3036 $data = $record{'fax'}; | |
3037 print "tel;type=fax:$data\n" if($data); | |
3038 } | |
3039 if(defined $record{'mail'}) { | |
3040 $data = $record{'mail'}; | |
3041 print "email;internet:$data\n" if($data); | |
3042 } | |
3043 if(defined $record{'birth'}) { | |
3044 $data = $record{'birth'}; | |
8 | 3045 print "bday:".$data->date()."\n" if($data); |
1 | 3046 } |
3047 if(defined $record{'name-yomi'}) { | |
3048 $data = $record{'name-yomi'}; | |
3049 print "x-custom1:$data\n" if($data); | |
3050 } | |
3051 if(defined $record{'office-yomi'}) { | |
3052 $data = $record{'office-yomi'}; | |
3053 print "x-custom2:$data\n" if($data); | |
3054 } | |
3055 print "end:vcard\n"; | |
3056 print "\n"; | |
3057 } | |
3058 | |
3059 #######################################################################/ | |
3060 | |
8 | 3061 package Calcon::Vcard_Apple_write; |
3062 use strict; | |
3063 # use warnings; | |
3064 use NKF; | |
3065 | |
3066 # VCARD 形式 | |
3067 | |
3068 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
3069 @ISA = ( 'Calcon::Vcard_write' ); | |
3070 | |
3071 # Mac OS X 10.3 's Address Book requires utf-16 | |
3072 # | nkf -w16 | |
3073 # | |
3074 | |
3075 sub initialize { | |
3076 my ($self) = @_; | |
3077 $self->SUPER::initialize(); | |
9 | 3078 open(OUTPUT,"| nkf -w16") or die("nkf required."); |
3079 select OUTPUT; | |
8 | 3080 } |
3081 | |
3082 sub print { | |
3083 my ($self,@data) = @_; | |
3084 foreach (@data) { | |
3085 chop; | |
3086 s/\015/\\n/g; | |
3087 s/\012//g; | |
3088 print "$_\n"; | |
3089 } | |
3090 } | |
3091 | |
3092 sub vcard { | |
3093 my ($self,$keys,$record) = @_; | |
3094 my (%record) = %{$record}; | |
3095 my $data; | |
3096 $self->{'item'} = 1; | |
3097 | |
3098 if(defined($record{'office'})) { | |
3099 $record{'office'} = 'etc' if(! $record{'office'}) ; | |
3100 } | |
3101 if(defined($record{'name-yomi'})) { | |
3102 $record{'name-yomi'} =~ s/^ *//; | |
3103 } | |
3104 if(defined($record{'office-yomi'})) { | |
3105 $record{'office-yomi'} =~ s/^ *//; | |
3106 } | |
3107 $self->print("begin:vcard\n"); | |
3108 $self->print("version:3.0\n"); | |
3109 if(defined $record{'name'}) { | |
3110 $data = $record{'name'}; | |
3111 $self->print("FN:$data\n") if($data); | |
3112 if(0 && defined $record{'name-yomi'}) { | |
3113 $data = join(";",split(/ /,$record{'name-yomi'})); | |
3114 $self->print("N:$data\n") if($data); | |
3115 } else { | |
3116 $data = join(";",split(/ /,$data)); | |
3117 $self->print("N:$data\n") if($data); | |
3118 } | |
3119 if(defined $record{'name-yomi'}) { | |
3120 my ($last , $first , $last_yomi , $first_yomi ); | |
3121 $last = $first = $last_yomi = $first_yomi = ''; | |
3122 ($last,$first) = split(/ /,$record{'name'}); | |
3123 ($last_yomi,$first_yomi) = split(/ /,$record{'name-yomi'}), | |
3124 $self->print("X-PHONETIC-LAST-NAME:$last_yomi\n"); | |
3125 $self->print("X-PHONETIC-FIRST-NAME:$first_yomi\n"); | |
3126 } | |
3127 | |
3128 # print "fn:$data\n" if($data); | |
3129 # if(defined $record{'office'}) { | |
3130 # $data = $data.";".$record{'office'}; | |
3131 # } | |
3132 # print "n:$data\n" if($data); | |
3133 } | |
3134 # my $cat = 0; | |
3135 # if(defined $record{'group'}) { | |
3136 # $data = "$record{'group'}"; | |
3137 # $self->print("CATEGORIES:$data\n") if($data); | |
3138 # } | |
3139 if(defined $record{'office'}) { | |
3140 $data = "$record{'office'}"; | |
9 | 3141 $self->print("ORG:$data;\n") if($data); |
8 | 3142 # if ($cat==0) { |
3143 # $self->print("CATEGORIES:$data\n") if($data); | |
3144 # } | |
3145 } | |
3146 my $title; | |
3147 if(defined $record{'section'}) { | |
3148 $title = $record{'section'}; | |
3149 } | |
3150 if(defined $record{'title'}) { | |
3151 $title .= ($title?'\n':'')."$record{'title'}"; | |
3152 $self->print("title:$data\n") if($data); | |
3153 } | |
3154 if(defined $record{'address'}) { | |
3155 my $i = $self->{'item'}++; | |
3156 my ($adr1 , $adr2 , $adr_state , $adr_zip , $adr_country ); | |
3157 $adr1 = $adr2 = $adr_state = $adr_zip = $adr_country = ''; | |
3158 $data = $record{'address'}; | |
3159 $adr1 = $record{'address'}; | |
3160 # ADD:番地;;町村;沖縄;903-0213;日本 | |
3161 if(defined $record{'zip'}) { | |
3162 $adr_zip = $record{'zip'}; | |
3163 } | |
3164 $self->print("item$i.ADR;type=work;type=pref:;;$adr1;$adr2;$adr_state;$adr_zip;$adr_country\n") if ($data); | |
3165 } | |
3166 if(defined $record{'tel'}) { | |
9 | 3167 # my $i = $self->{'item'}++; |
8 | 3168 $data = $record{'tel'}; |
9 | 3169 $self->print("TEL;type=WORK:$data\n") if($data); |
3170 } | |
3171 if(defined $record{'mobile-tel'}) { | |
3172 # my $i = $self->{'item'}++; | |
3173 $data = $record{'mobile-tel'}; | |
3174 $self->print("TEL;type=CELL:$data\n") if($data); | |
8 | 3175 } |
3176 if(defined $record{'home-tel'}) { | |
9 | 3177 # my $i = $self->{'item'}++; |
8 | 3178 $data = $record{'tel'}; |
9 | 3179 $self->print("TEL;type=HOME:$data\n") if($data); |
8 | 3180 } |
3181 if(defined $record{'tel2'}) { | |
9 | 3182 # my $i = $self->{'item'}++; |
8 | 3183 $data = $record{'tel2'}; |
9 | 3184 $self->print("TEL;type=CELL:$data\n") if($data); |
8 | 3185 } |
3186 if(defined $record{'fax'}) { | |
9 | 3187 # my $i = $self->{'item'}++; |
8 | 3188 $data = $record{'fax'}; |
9 | 3189 $self->print( "TEL;type=FAX:$data\n") if($data); |
8 | 3190 } |
3191 if(defined $record{'home-address'}) { | |
3192 my $i = $self->{'item'}++; | |
3193 my ($adr1 , $adr2 , $adr_state , $adr_zip , $adr_country ); | |
3194 $adr1 = $adr2 = $adr_state = $adr_zip = $adr_country = ''; | |
3195 $data = $record{'home-address'}; | |
3196 $adr1 = $record{'home-address'}; | |
3197 # ADD:番地;;町村;沖縄;903-0213;日本 | |
3198 if(defined $record{'home-zip'}) { | |
3199 $adr_zip = $record{'home-zip'}; | |
3200 } | |
3201 $self->print("item$i.ADR;type=home;type=pref:;;$adr1;$adr2;$adr_state;$adr_zip;$adr_country\n") if ($data); | |
9 | 3202 # $self->print("item$1.X-ABADR:ja\n") if ($data); |
8 | 3203 } |
9 | 3204 if(defined $record{'mail2'}) { |
3205 # my $i = $self->{'item'}++; | |
3206 $data = $record{'mail2'}; | |
3207 $self->print("EMAIL;type=INTERNET;type=home:$data\n") if($data); | |
3208 } | |
8 | 3209 if(defined $record{'mail'}) { |
9 | 3210 # my $i = $self->{'item'}++; |
8 | 3211 $data = $record{'mail'}; |
9 | 3212 $self->print("EMAIL;type=INTERNET;type=pref:$data\n") if($data); |
8 | 3213 } |
3214 if(defined $record{'birth'}) { | |
3215 $data = $record{'birth'}; | |
3216 $self->print("bday:".$data->date()."\n") if($data); | |
3217 } | |
3218 if(defined $record{'memo'}) { | |
3219 $data = $record{'memo'}; | |
3220 $self->print("NOTE:$data\n") if($data); | |
3221 } | |
3222 # if(defined $record{'name-yomi'}) { | |
3223 # $data = $record{'name-yomi'}; | |
3224 # $self->print "x-custom1:$data\n" if($data); | |
3225 # } | |
3226 # if(defined $record{'office-yomi'}) { | |
3227 # $data = $record{'office-yomi'}; | |
3228 # $self->print "x-custom2:$data\n" if($data); | |
3229 # } | |
3230 $self->print("end:vcard\n"); | |
3231 $self->print("\n"); | |
3232 } | |
3233 | |
3234 #######################################################################/ | |
3235 | |
1 | 3236 package Calcon::File_read; |
3237 use strict; | |
3238 # use warnings; | |
3239 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
3240 @ISA = ( 'Calcon::Reader') ; | |
3241 | |
3242 # File 形式の読み込み。かなりいいかげんなものでも読み込むが... | |
3243 | |
3244 use NKF; | |
3245 | |
3246 sub initialize { | |
3247 my ($self) = @_; | |
3248 $self->SUPER::initialize(); | |
3249 $self->{'-email-extract'} = 1; | |
3250 } | |
3251 | |
3252 sub decode { | |
3253 my ($self,$file) = @_; | |
3254 my $out = $self->{'-output'}; | |
3255 | |
3256 $self->{'-file'} = $file; | |
3257 open(F,"<".$file); | |
3258 | |
3259 $out->start_file(''); | |
3260 | |
3261 local($/) = "\n\n"; | |
3262 while(<F>) { | |
3263 $self->buffer_decode($_); | |
3264 } | |
3265 $out->end_file(''); | |
3266 } | |
3267 | |
3268 # いいかげんなものでも読み込むためのルーチン | |
3269 | |
3270 sub buffer_decode { | |
3271 my ($self,$buf,%initial) = @_; | |
3272 my @data; | |
3273 my $key; | |
3274 my ($debug) = $self->{'-debug'}; | |
3275 my $i = 0; | |
3276 my $out = $self->{'-output'}; | |
3277 | |
3278 # $_ =~ s/\n\s+/ /g; | |
3279 # s/\n[ \t]/\037/g; | |
3280 | |
3281 $buf =~ s/^\s*//; | |
3282 @data = split(/\n/,$buf); | |
3283 my $record = $self->make_record; | |
3284 my $keys = []; | |
3285 | |
3286 foreach my $key (keys %initial) { | |
3287 $record->{$key} = $initial{$key}; | |
3288 push(@$keys,$key); | |
3289 } | |
3290 foreach $_ (@data) { | |
3291 if (s/^([A-Za-z][-A-Za-z0-9_]*):\s*//) { | |
3292 $key = $1; | |
3293 } else { | |
3294 $key = 'memo'; | |
3295 } | |
8 | 3296 $key = 'memo' if ($key eq ''); |
1 | 3297 if ($key eq 'Subject') { |
3298 $key = 'memo'; | |
3299 } | |
3300 s/^(\201\100)*//; | |
3301 $_ = nkf('-sZ',$_); | |
3302 if($key eq 'time' || $key eq 'end-time') { | |
3303 $record->{$key} = $_; | |
3304 next; | |
3305 } | |
3306 if(!($key eq 'date' || $key eq 'end-date')) { | |
3307 my $save = $_; | |
3308 my $savekey = $key; | |
3309 | |
3310 my $stime; | |
3311 my $etime; | |
3312 # use extra . to avoid regex bug | |
3313 if (/(\d+:\d+).*[-~].*?(\d+:\d+)/) { | |
3314 $stime = $1; | |
3315 $etime = $2; | |
3316 # print "*0** $stime $etime\n"; | |
3317 } elsif (/(\d+:\d+).*\201\140.*?(\d+:\d+)/) { # 〜 | |
3318 $stime = $1; | |
3319 $etime = $2; | |
3320 # print "*1** $stime $etime\n"; | |
3321 } elsif (/(\d+:\d+).*\201\250.*?(\d+:\d+)/) { # → | |
3322 $stime = $1; | |
3323 $etime = $2; | |
3324 # print "*2** $stime $etime\n"; | |
3325 } elsif (/(\d+:\d+)/) { | |
3326 $stime = $1; | |
3327 } | |
3328 if ($stime) { | |
3329 my $date = $record->{'date'}; | |
3330 if ($date) { | |
3331 if ($record->{'memo'}) { | |
3332 | |
3333 $self->date_normalize($keys,$record); | |
3334 $out->record($keys,$record); | |
3335 | |
3336 $record = $self->make_record; $keys = []; | |
3337 foreach my $key (keys %initial) { | |
3338 $record->{$key} = $initial{$key}; | |
3339 push(@$keys,$key); | |
3340 } | |
3341 $record->{'date'} = $date; | |
3342 push(@$keys,'date'); | |
3343 } | |
3344 if (! $record->{'time'}) { | |
3345 $record->{'time'} = $stime; | |
3346 push(@$keys,'time'); | |
3347 } | |
3348 if (! $record->{'end-time'}) { | |
3349 $record->{'end-time'} = $etime; | |
3350 push(@$keys,'end-time'); | |
3351 } | |
3352 $_ = $save; | |
3353 $key = $savekey; | |
3354 } | |
3355 } | |
3356 } else { | |
3357 # don't append time field | |
3358 push(@$keys,$key); | |
3359 $record->{$key} = $_; | |
3360 next; | |
3361 } | |
3362 if ($self->{'-email-extract'}) { | |
3363 if(s/[-a-zA-Z0-9.]+@[-a-zA-Z0-9.]+//) { | |
3364 if (defined($record->{'mail'})) { | |
3365 $record->{'mail'} .= ",".$&; | |
3366 } else { | |
3367 $record->{'mail'} = $&; | |
3368 push(@$keys,'mail'); | |
3369 } | |
3370 } | |
3371 } | |
3372 next if (! $_); | |
3373 if(defined $record->{$key}) { | |
3374 $record->{$key} .= "\n" . $_; # append for duplicated field | |
3375 } else { | |
3376 push(@$keys,$key); | |
3377 $record->{$key} = $_; | |
3378 } | |
3379 } | |
3380 $self->date_normalize($keys,$record); | |
3381 $out->record($keys,$record); | |
3382 } | |
3383 | |
3384 #######################################################################/ | |
3385 | |
3386 package Calcon::Xcalendar_read; | |
3387 | |
3388 # XCalendar 形式の読み込み。かなりいいかげんなものでも読み込むが... | |
3389 | |
3390 use strict; | |
3391 # use warnings; | |
3392 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
3393 use Time::Local; | |
3394 use NKF; | |
3395 | |
3396 @ISA = ( 'Calcon::File_read' ) ; | |
3397 | |
3398 sub decode { | |
3399 my ($self,$file) = @_; | |
3400 my @data; | |
3401 my $key; | |
3402 my ($debug) = $self->{'-debug'}; | |
3403 my $i = 0; | |
3404 my $out = $self->{'-output'}; | |
3405 | |
3406 $self->{'-file'} = $file; | |
3407 my $calendar = $file; | |
3408 | |
3409 # my $i = 0; | |
3410 my $found = 1; | |
3411 my $today = time; | |
3412 my $daytime = 60*60*24*2; | |
3413 | |
3414 my $all = 1; | |
3415 my $tomorrow = $self->{'-tomorrow'}; | |
3416 | |
3417 my %xcal; | |
3418 | |
3419 while(<$calendar/xc*>) { | |
3420 my $file = $_; | |
3421 my $date = $self->make_xcalendar_date($file); | |
3422 next if (! defined $date->unix_time); | |
3423 next if ($self->{'-tomorrow'} && ! $date->tomorrow()); | |
3424 next if ($self->{'-future-only'} && ! $date->future()); | |
3425 $xcal{$date->unix_time()} = $file; | |
3426 } | |
3427 | |
3428 $out->start_file(''); | |
3429 | |
3430 $i= $all ? -1 : 4; | |
3431 foreach my $key ( sort {$a <=> $b;} keys(%xcal) ) { | |
3432 $found = 0; | |
3433 open(XCAL,$xcal{$key}) || next; | |
3434 my ($sec,$min,$hour,$day,$month,$year,$wday,$date_,$isdst) = | |
3435 localtime($key); | |
3436 my $date; | |
3437 $date = ($year+1900)."/".($month+1)."/$day"; | |
3438 local($/) = "\n\n"; | |
3439 while(<XCAL>) { | |
3440 $self->buffer_decode($_,'date'=>$date); | |
3441 } | |
3442 last if($i-- == 0); | |
3443 } | |
3444 $out->end_file(''); | |
3445 } | |
3446 | |
3447 #######################################################################/ | |
3448 | |
3449 # 別に Xcalendar class のメソッドでもいいんだけど。 | |
3450 | |
3451 package Calcon::Date ; | |
3452 | |
3453 use vars qw(%monthname); | |
3454 | |
3455 sub make_xcalendar_date { | |
3456 my ($self,$name) = @_; | |
3457 | |
3458 my $date; | |
3459 if ($name =~ m^xc([0-9]+)([A-Za-z]+)([0-9]+)$^) { | |
3460 my $day = $1 ;my $month = $monthname{$2}; my $year = $3; | |
3461 # if($year > 1900) { $year -= 1900; } | |
3462 $date = &timelocal(0,0,0,$day,$month,$year,0,0,0); | |
3463 } | |
3464 bless \$date; | |
3465 } | |
3466 | |
3467 #######################################################################/ | |
3468 | |
3469 package Calcon::Basic ; | |
3470 | |
3471 sub make_xcalendar_date { | |
3472 my ($self,$name) = @_; | |
3473 $date_class->make_xcalendar_date($name); | |
3474 } | |
3475 | |
3476 #######################################################################/ | |
3477 | |
3478 package Calcon::Xcalendar_write ; | |
3479 | |
3480 # Xcalendar 形式の書き出し | |
3481 | |
3482 use strict; | |
3483 # use warnings; | |
3484 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
3485 @ISA = ('Calcon::Writer'); | |
3486 use NKF; | |
3487 | |
3488 sub initialize { | |
3489 my ($self) = @_; | |
3490 if (defined $self->{'-file'}) { | |
3491 $self->{'-directory'} = defined $self->{'-file'}; | |
3492 undef $self->{'-file'}; | |
3493 } else { | |
3494 $self->{'-directory'} = "$ENV{'HOME'}/Calendar.new"; | |
3495 } | |
3496 $self->SUPER::initialize(); | |
3497 mkdir $self->{'-directory'}; | |
3498 } | |
3499 | |
3500 sub record { | |
3501 my ($self,$keys,$record) = @_; | |
3502 my @keys = @$keys; | |
3503 my %record = %$record; | |
3504 # should be override | |
3505 return if (! $record->{'date'} ); | |
3506 return if ($self->{'-future-only'} && ! $record->{'date'}->future()); | |
3507 $self->open($record->{'date'}); | |
3508 foreach my $key (@keys) { | |
3509 my $value = $record{$key}; | |
3510 if (ref $value) { | |
3511 $value = $value->value(); | |
3512 } | |
3513 print nkf('-e',"$key: $value\n") if ($value); | |
3514 } | |
3515 print "\n"; | |
3516 $self->close(); | |
3517 } | |
3518 | |
3519 sub open { | |
3520 my ($self,$date) = @_; | |
4 | 3521 my $name = $date->xcalendar_file_name; |
3522 if (defined($self->{'-directory'})) { | |
3523 $name = $self->{'-directory'}."/".$name; | |
3524 } | |
1 | 3525 open(OUT,">>".$name); |
3526 select OUT; | |
3527 } | |
3528 | |
3529 sub close { | |
3530 close OUT; | |
3531 } | |
3532 | |
3533 #######################################################################/ | |
3534 | |
3535 package Calcon::Date; | |
3536 | |
3537 sub xcalendar_file_name { | |
3538 my ($self) = @_; | |
3539 my ($year,$month,$day,$hour,$min) = $self->localtime(); | |
3540 sprintf("xc%02d%s%04d",$day,$monthname[$month-1],$year); | |
3541 } | |
3542 | |
3543 #######################################################################/ | |
3544 | |
3545 package Calcon::Entourage_read; | |
3546 | |
3547 # Mac のEntourage から AppleScript 経由で読み込む | |
3548 # ファイルからでも読み込み可能 | |
3549 # Zaurus のCSVも読めた方が良いね | |
3550 # 日本語専用 | |
3551 | |
3552 use strict; | |
3553 # use warnings; | |
3554 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
3555 use Mac::AppleScript qw(RunAppleScript); | |
3556 use NKF; | |
3557 use Carp; | |
3558 @ISA = ( 'Calcon::File_read' ) ; | |
3559 | |
3560 # We use Applescript, but it is very slow. | |
3561 # get_all_event is slightly faster. | |
3562 # To convert contact, it is better to use export address in Entourage Menu. | |
3563 # If it has a file name other than '/dev/stdin', it assumes export file. | |
3564 | |
3565 my %item_keys = ( | |
3566 "名"=>"first name", | |
3567 "姓"=>"last name", | |
3568 "敬称"=>"sir name", | |
3569 "Suffix"=>"suffix", | |
3570 "ニックネーム"=>"nick name", | |
3571 "会社名"=>"company", | |
3572 "役職"=>"title", | |
3573 "部署"=>"department", | |
3574 "番地 (勤務先)"=>"business address street address", | |
3575 "市区町村 (勤務先)"=>"business address city", | |
3576 "都道府県 (勤務先)"=>"business address state", | |
3577 "郵便番号 (勤務先)"=>"business address zip", | |
3578 "国/地域 (勤務先)"=>"business address country", | |
3579 "Web ページ (勤務先)"=>"www", | |
3580 "番地 (自宅)"=>"home address street address", | |
3581 "市区町村 (自宅)"=>"home address city", | |
3582 "都道府県 (自宅)"=>"home address state", | |
3583 "郵便番号 (自宅)"=>"home address zip", | |
3584 "国/地域 (自宅)"=>"home address country", | |
3585 "Web ページ (自宅)"=>"home www", | |
3586 "電話 1 (自宅)"=>"home phone number", | |
3587 "電話 2 (自宅)"=>"home tel2", | |
3588 "FAX (自宅)"=>"home fax number", | |
3589 "電話 1 (勤務先)"=>"business phone number", | |
3590 "電話 2 (勤務先)"=>"tel2", | |
3591 "FAX (勤務先)"=>"business fax number", | |
3592 "ポケットベル"=>"pager", | |
3593 "携帯電話"=>"mobile phone number", | |
3594 "電話 (メイン)"=>"main phone number", | |
3595 "電話 (アシスタント)"=>"sub tel", | |
3596 "電話 (ユーザー設定 1)"=>"tel 1", | |
3597 "電話 (ユーザー設定 2)"=>"tel 2", | |
3598 "電話 (ユーザー設定 3)"=>"tel 3", | |
3599 "電話 (ユーザー設定 4)"=>"tel 4", | |
3600 "電子メール アドレス 1"=>"mail-address", | |
3601 "電子メール アドレス 2"=>"business mail", | |
3602 "電子メール アドレス 3"=>"mail", | |
3603 "電子メール アドレス 4"=>"mail-to", | |
3604 "電子メール アドレス 5"=>"mail 5", | |
3605 "電子メール アドレス 6"=>"mail 6", | |
3606 "電子メール アドレス 7"=>"mail 7", | |
3607 "電子メール アドレス 8"=>"mail 8", | |
3608 "電子メール アドレス 9"=>"mail 9", | |
3609 "電子メール アドレス 10"=>"mail 10", | |
3610 "電子メール アドレス 11"=>"mail 11", | |
3611 "電子メール アドレス 12"=>"mail 12", | |
3612 "電子メール アドレス 13"=>"mail 13", | |
3613 "メモ 1"=>"memo", | |
3614 "メモ 2"=>"memo 2", | |
3615 "メモ 3"=>"memo 3", | |
3616 "メモ 4"=>"memo 4", | |
3617 "メモ 5"=>"memo 5", | |
3618 "メモ 6"=>"memo 6", | |
3619 "メモ 7"=>"memo 7", | |
3620 "メモ 8"=>"memo 8", | |
3621 "日付 1 :"=>"date", | |
3622 "日付 2 :"=>"date 2", | |
3623 "配偶者"=>"spouse", | |
3624 "誕生日"=>"birthday", | |
3625 "記念日"=>"aniversary", | |
3626 "備考"=>"note", | |
3627 "年齢"=>"age", | |
3628 "星座"=>"astology sign", | |
3629 "血液型"=>"blood type", | |
3630 "会社名 (ふりがな)"=>"company furigana", | |
3631 "名 (ふりがな)"=>"first name furigana", | |
3632 "姓 (ふりがな)"=>"last name furigana", | |
3633 "配偶者名 (ふりがな)"=>"spouse furigana", | |
3634 "趣味"=>"play", | |
3635 ); | |
3636 | |
3637 $| = 0; | |
3638 # my $tell = "tell application \"Microsoft Entourage\"\n"; | |
3639 $tell = "tell application \"Microsoft Entourage\"\n"; | |
3640 | |
3641 sub decode { | |
3642 my ($self,$file) = @_; | |
3643 my ($debug) = $self->{'-debug'}; | |
3644 my $out = $self->{'-output'}; | |
3645 if (! $file || $file ne '/dev/stdin') { | |
3646 $self->read_export($file); | |
3647 } | |
3648 | |
3649 $out->start_file(''); | |
3650 $self->get_all_event() if (! $self->{'-address-only'}); | |
3651 $self->get_all_contact() if (! $self->{'-calendar-only'}); | |
3652 $out->end_file(''); | |
3653 | |
3654 } | |
3655 | |
3656 sub date { | |
3657 my ($self,$date)=@_; | |
3658 my @date = ($date =~ /(\d+)/g); | |
3659 if ($date =~ /PM$/) { | |
3660 if ($date[3]==12) { $date[3]=0;} | |
3661 $date[3]+=12; | |
3662 } | |
3663 return $self->make_date("$date[0]/$date[1]/$date[2] $date[3]:$date[4]"); | |
3664 } | |
3665 | |
3666 sub read_export { | |
3667 my ($self,$file) = @_; | |
3668 | |
3669 open(IN,"<$file") or cloak("$@"); | |
3670 local($/) = "\r"; | |
3671 | |
3672 my $title = <IN>; | |
3673 chop($title); | |
3674 | |
3675 return if (eof(IN)); | |
3676 | |
3677 my @keys = split(/\t/,nkf('-eS',$title)); | |
3678 my $i = 0; | |
3679 my %keys; | |
3680 foreach my $key (@keys) { | |
3681 $keys{$item_keys{$key}} = $i++; | |
3682 } | |
3683 # foreach my $key (@keys) { | |
3684 # print "$key:$item_keys{$key}:$keys{$item_keys{$key}}\n"; | |
3685 # } | |
3686 | |
3687 $self->{'-input-keys'} = \%keys; | |
3688 my $i0 = 0; | |
3689 while(<IN>) { | |
3690 my @items; | |
3691 chop; | |
3692 @items = split(/\t/,$_); | |
3693 $self->{'-input'}->[$i0++] = \@items; | |
3694 } | |
3695 $self->{'-input-count'} = $i0; | |
3696 } | |
3697 | |
3698 sub property { | |
3699 my ($self,$contact,$id,$property,$record,$key) = @_; | |
3700 my $result; | |
3701 if ($self->{'-input-count'}) { | |
3702 $result = $self->{'-input'}->[$id]->[$self->{'-input-keys'}->{$property}]; | |
3703 if (! defined($self->{'-input-keys'}->{$property}) ) { | |
3704 print "$property not found\n"; | |
3705 } | |
3706 } else { | |
3707 $result = RunAppleScript("${tell}${property} of ${contact} $id\nend tell\n"); | |
3708 } | |
3709 $result =~ s/^\"//; | |
3710 $result =~ s/\"$//; | |
3711 if (defined($record) && $result ne '') { | |
3712 if ($key =~ /date/ || $key =~ /birth/) { | |
3713 $record->{$key} = $self->date($result); | |
3714 } else { | |
3715 $record->{$key} = nkf('-eS',$result); | |
3716 } | |
3717 } else { | |
3718 nkf('-eS',$result); | |
3719 } | |
3720 } | |
3721 | |
3722 sub address { | |
3723 my ($self,$id,$property,$record,$key) = @_; | |
3724 my $address; | |
3725 my ($street , $zip , $state , $country , $city); | |
3726 | |
3727 if ($self->{'-input-count'}) { | |
3728 my $l = $self->{'-input'}->[$id]; | |
3729 my $k = $self->{'-input-keys'}; | |
3730 $address = $l->[$k->{"$property street address"}]; | |
3731 $zip = $l->[$k->{"$property zip"}]; | |
3732 $state = $l->[$k->{"$property state"}]; | |
3733 $city = $l->[$k->{"$property city"}]; | |
3734 $country = $l->[$k->{"$property country"}]; | |
3735 } else { | |
3736 $address = RunAppleScript("${tell}${property} of contact $id\nend tell\n"); | |
3737 $address =~ /street address:"([^"]*)"/ && ($street = $1); | |
3738 $zip =~ /zip:"([^"]*)"/ && ($zip = $1); | |
3739 $state =~ /state:"([^"]*)"/ && ($state = $1); | |
3740 $city =~ /city:"([^"]*)"/ && ($city = $1); | |
3741 $country =~ /country:"([^"]*)"/ && ($country = $1); | |
3742 } | |
3743 | |
3744 | |
3745 $record->{$key} = nkf('-eS',"$state $city $street $country") | |
3746 if ($state||$city||$street||$country); | |
3747 if ($zip && $key =~ /home/) { | |
3748 $record->{'home-zip'} = $zip; | |
3749 } else { | |
3750 $record->{'zip'} = $zip if ($zip); | |
3751 } | |
3752 } | |
3753 | |
3754 sub get_all_contact { | |
3755 my ($self) = @_; | |
3756 my $out = $self->{'-output'}; | |
3757 my $count; | |
3758 if ($self->{'-input-count'}) { | |
3759 $count = $self->{'-input-count'}; | |
3760 } else { | |
3761 $count = RunAppleScript("${tell}count of contact\nend tell\n") or croak("$@"); | |
3762 } | |
3763 | |
3764 foreach my $id ( 1..$count ) { | |
3765 $self->contact($id); | |
3766 } | |
3767 } | |
3768 | |
3769 sub contact { | |
3770 my ($self,$id) = @_; | |
3771 my $record = $self->make_record; | |
3772 | |
3773 $self->property('contact',$id,'business phone number',$record,'tel'); | |
3774 $self->property('contact',$id,'home phone number',$record,'tel-home'); | |
3775 $self->property('contact',$id,'mobile phone number',$record,'mobile-tel'); | |
3776 $self->property('contact',$id,'main phone number',$record,'tel'); | |
3777 $self->property('contact',$id,'home fax number',$record,'home-fax'); | |
3778 $self->property('contact',$id,'business fax number',$record,'fax'); | |
3779 | |
3780 my $name = $self->property('contact',$id,'last name'); | |
3781 my $first_name = $self->property('contact',$id,'first name'); | |
3782 $record->{'name'} = ($name && $first_name)?"$name $first_name": | |
3783 ($name)?$name:$first_name; | |
3784 | |
3785 my $name_p = $self->property('contact',$id,'last name furigana'); | |
3786 my $first_name_p = $self->property('contact',$id,'first name furigana'); | |
3787 $record->{'name-yomi'} = ($name_p && $first_name_p)?"$name_p $first_name_p": | |
3788 ($name_p)?$name_p:$first_name_p; | |
3789 | |
3790 $self->property('contact',$id,'department',$record,'section'); | |
3791 $self->property('contact',$id,'title',$record,'title'); | |
3792 | |
3793 $self->address($id,'business address',$record,'address'); | |
3794 $self->address($id,'home address',$record,'home-address'); | |
3795 | |
3796 my $mail = $self->property('contact',$id,'mail'); | |
3797 my $mail1 = $self->property('contact',$id,'mail-to'); | |
3798 if ($mail) { $mail .= ",".$mail1 ;} else { $mail = $mail1;} | |
3799 my $mail2 = $self->property('contact',$id,'mail-address'); | |
3800 if ($mail) { $mail .= ",".$mail1 ;} else { $mail = $mail2;} | |
3801 | |
3802 $self->property('contact',$id,'birthday',$record,'birth'); | |
3803 $self->property('contact',$id,'company',$record,'office'); | |
3804 $self->property('contact',$id,'company furigana',$record,'office-yomi'); | |
3805 | |
3806 my $keys = []; | |
3807 push(@$keys,keys %{$record}); | |
3808 | |
3809 # $self->date_normalize($keys,$record); | |
3810 my $out = $self->{'-output'}; | |
3811 $out->record($keys,$record); | |
3812 } | |
3813 | |
3814 sub get_all_event { | |
3815 my ($self) = @_; | |
3816 my $out = $self->{'-output'}; | |
3817 my $count ; | |
3818 if ($self->{'-input-count'}) { | |
3819 for(my $id=1; $id <= $count ;$id++) { | |
3820 $self->event($id); | |
3821 } | |
3822 return; | |
3823 } elsif ($self->{'-future-only'}) { | |
3824 my $today = $self->today(); | |
3825 my ($year,$mon,$mday,$hour,$min) = $today->localtime(); | |
3826 | |
3827 $_ = "${tell}id of every event whose start time > date \"$year/$mon/$mday\"\nend tell\n"; | |
3828 $count = RunAppleScript($_) or cloak("$@ $_"); | |
3829 for my $id ($count =~ /(\d+)/g) { | |
3830 $self->event_id($id); | |
3831 } | |
3832 } else { | |
3833 $count = RunAppleScript("${tell}count of event\nend tell\n") or croak("$@"); | |
3834 for(my $id=1; $id <= $count ;$id++) { | |
3835 $self->event($id); | |
3836 } | |
3837 } | |
3838 } | |
3839 | |
3840 sub event { | |
3841 my ($self,$id) = @_; | |
3842 my $record = $self->make_record; | |
3843 | |
3844 $self->property('event',$id,'all day event',$record,'all-day'); | |
3845 $self->property('event',$id,'start time',$record,'date'); | |
3846 | |
3847 if ($record->{'all-day'} ne "true") { | |
3848 $self->property('event',$id,'end time',$record,'end-date'); | |
3849 } | |
3850 $self->property('event',$id,'subject',$record,'summary'); | |
3851 $self->property('event',$id,'content',$record,'memo'); | |
3852 | |
3853 my $keys = []; | |
3854 push(@$keys,keys %{$record}); | |
3855 | |
3856 my $out = $self->{'-output'}; | |
3857 $out->record($keys,$record); | |
3858 } | |
3859 | |
3860 sub event_id { | |
3861 my ($self,$id) = @_; | |
3862 my $record = $self->make_record; | |
3863 | |
3864 $self->property('event id',$id,'all day event',$record,'all-day'); | |
3865 $self->property('event id',$id,'start time',$record,'date'); | |
3866 | |
3867 if ($record->{'all-day'} ne "true") { | |
3868 $self->property('event id',$id,'end time',$record,'end-date'); | |
3869 } | |
3870 $self->property('event id',$id,'subject',$record,'summary'); | |
3871 $self->property('event id',$id,'content',$record,'memo'); | |
3872 | |
3873 my $keys = []; | |
3874 push(@$keys,keys %{$record}); | |
3875 | |
3876 my $out = $self->{'-output'}; | |
3877 $out->record($keys,$record); | |
3878 } | |
3879 | |
3880 | |
3881 #######################################################################/ | |
3882 | |
3883 package Calcon::Vcard_read; | |
3884 | |
3885 # Vcard / Vcal 形式を読み込む | |
3886 # Vcard に読みがないのが日本語向きじゃないね | |
3887 | |
3888 use strict; | |
3889 # use warnings; | |
3890 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); | |
3891 | |
3892 @ISA = ( 'Calcon::File_read' ) ; | |
3893 | |
3894 sub decode { | |
3895 my ($self,$file) = @_; | |
3896 my ($debug) = $self->{'-debug'}; | |
3897 my $out = $self->{'-output'}; | |
3898 my $record; | |
3899 my $keys; | |
3900 | |
3901 $self->{'-file'} = $file; | |
3902 open(F,"<".$file); | |
3903 | |
3904 $out->start_file(''); | |
3905 | |
3906 while(<F>) { | |
3907 if (/^begin:\s*vcalendar/i) { | |
8 | 3908 } elsif (/^begin:\s*vcad/i) { |
1 | 3909 } elsif (/^adr(.*):\s*(.*)/i) { $self->items($record,'address',$1,$2); |
3910 } elsif (/^bday:\s*(.*)/i) { $record->{'birth'} = $self->make_date($1); | |
3911 } elsif (/^begin:\s*vcard/i) { $record = $self->make_record; | |
3912 } elsif (/^begin:\s*vevent/i) { $record = $self->make_record; | |
3913 } elsif (/^calscale:\s*(.*)/i) { | |
3914 } elsif (/^uid:\s*(.*)/i) { | |
3915 } elsif (/^description:\s*/i) { $record->{'memo'} .= $1; | |
3916 } elsif (/^dtend(.*):\s*(.*)/i) { $record->{'end-date'} = $self->date($2,$1?$1:$record->{'timezone'}); | |
3917 } elsif (/^dtstamp(.*):\s*(.*)/i) { $record->{'modify-date'} = $self->date($2,$1?$1:$record->{'timezone'}); | |
3918 } elsif (/^dtstart(.*):\s*(.*)/i) { $record->{'date'} = $self->date($2,$1?$1:$record->{'timezone'}); | |
3919 } elsif (/^duration:\s*(.*)/i) { $self->duration($record,$1); | |
3920 } elsif (/^email(.*):\s*(.*)/i) { $self->items($record,'email',$1,$2); | |
3921 } elsif (/^end:\s*vcard/i) { $self->vcard($record); | |
3922 } elsif (/^end:\s*vevent/i) { $self->event($record); | |
3923 } elsif (/^fn:\s*(.*)/i) { $self->name($record,$1); | |
3924 } elsif (/^label(.*):\s*(.*)/i) { $self->items($record,'address',$1,$2); | |
3925 } elsif (/^method:\s*(.*)/i) { $record->{'publish'} = $1; | |
3926 } elsif (/^n:\s*(.*)/i) { $self->name($record,split(/;/,$1)); | |
3927 } elsif (/^org:\s*(.*)/i) { $record->{'office'} = $1; | |
3928 } elsif (/^sequence:\s*(.*)/i) { $record->{'sequence'} = $1; | |
8 | 3929 } elsif (/^categories:\s*(.*)/i) { $record->{'group'} = $1; |
1 | 3930 } elsif (/^summary:\s*(.*)/i) { $record->{'summary'} = $1; |
3931 } elsif (/^tel(.*):\s*(.*)/i) { $self->items($record,'tel',$1,$2); | |
3932 } elsif (/^title:\s*/i) { $record->{'title'} = $1; | |
3933 } elsif (/^version:\s*(.*)/i) { $record->{'version'} = $1; | |
8 | 3934 } elsif (/^X-PHONETIC-LAST-NAME:\s*(.*)/i) { $record->{'name-yomi'} .= "$1 "; |
3935 } elsif (/^X-PHONETIC-FIRST-NAME:\s*(.*)/i) { $record->{'name-yomi'} .= "$1 "; | |
1 | 3936 } elsif (/^x-custom1:\s*(.*)/i) { $record->{'name-yomi'} = $1; |
3937 } elsif (/^x-custom2:\s*(.*)/i) { $record->{'office-yomi'} = $1; | |
3938 } elsif (/^x-wr-calname.*:\s*(.*)/i) { $record->{'calendar'} = $1; | |
3939 } elsif (/^x-wr-timezone.*:\s*(.*)/i) { $record->{'timezone'} = $1; | |
8 | 3940 } elsif (/^item\d+(.*):\s*(.*)/i) { $self->items($record,'address',$1,$2); |
1 | 3941 } else { $record->{'extra'} .= $_; |
3942 } | |
3943 } | |
3944 $out->end_file(''); | |
3945 } | |
3946 | |
3947 sub duration { | |
3948 my ($self,$record,$duration)=@_; | |
3949 if ($duration =~ /pt(\d+)h/) { | |
3950 $record->{'duration'} = "$1:00"; | |
3951 } | |
3952 } | |
3953 | |
3954 sub date { | |
3955 my ($self,$date,$timezone)=@_; | |
3956 if ($date =~ /(\d\d\d\d)(\d\d)(\d\d)t(\d\d)(\d\d)(\d\d)/i) { | |
3957 return $self->make_date("$1/$2/$3 $4:$5"); | |
3958 } elsif ($date =~ /(\d\d\d\d)(\d\d)(\d\d)/i) { | |
3959 return $self->make_date("$1/$2/$3"); | |
3960 } else { | |
3961 return ""; | |
3962 } | |
3963 } | |
3964 | |
3965 sub event { | |
3966 my ($self,$record)=@_; | |
3967 my $out = $self->{'-output'}; | |
3968 my $keys = []; | |
3969 push(@$keys,keys %{$record}); | |
3970 $out->record($keys,$record); | |
3971 } | |
3972 | |
3973 sub vcard { | |
3974 my ($self,$record)=@_; | |
3975 my $out = $self->{'-output'}; | |
3976 my $keys = []; | |
3977 push(@$keys,keys %{$record}); | |
3978 $out->record($keys,$record); | |
3979 } | |
3980 | |
3981 sub items { | |
3982 my ($self,$record,$label,$type,$value)=@_; | |
3983 # $record->{''} = $1;;type=work;type=pref; | |
3984 # $adr1;$adr2;$adr_state;$adr_zip;$adr_country | |
3985 if ($type =~ /home/i) { | |
3986 $label = "home-".$label; | |
3987 } elsif ($type =~ /voice/i) { | |
3988 } elsif ($type =~ /internet/i) { | |
3989 } elsif ($type =~ /fax/i) { | |
3990 $label = "fax"; | |
3991 } elsif ($type =~ /work/i) { | |
3992 } | |
3993 $record->{$label} = $value; | |
3994 } | |
3995 | |
3996 sub name { | |
3997 my ($self,$record,@names)=@_; | |
3998 $record->{'name'} = "@names"; | |
3999 } | |
4000 | |
4001 1; | |
4002 | |
4003 __END__ | |
4004 | |
4005 =cut | |
4006 | |
4007 =head1 NAME | |
4008 | |
4009 Calcon.pm -- Convert Various Calendar/Address data format | |
4010 | |
4011 =head1 SYNOPSIS | |
4012 | |
4013 use Calcon; | |
4014 | |
4015 =head1 ABSTRACT | |
4016 | |
6 | 4017 abstract |
4018 | |
1 | 4019 =head1 DESCRIPTION |
4020 | |
4021 =head2 EXPORT | |
4022 | |
4023 =head1 SEE ALSO | |
4024 | |
4025 =head1 AUTHOR | |
4026 | |
4027 Shinji KONO, E<lt>kono@ie.u-ryukyu.ac.jpE<gt> | |
4028 | |
4029 =head1 COPYRIGHT AND LICENSE | |
4030 | |
4031 #######################################################################/ | |
4032 ## | |
4033 ## Calendar/Address Format Converter | |
4034 ## | |
4035 ## Copyright (C) 2002 Shinji Kono | |
4036 ## | |
4037 ## このソースのいかなる複写,改変,修正も許諾します。ただし、 | |
4038 ## その際には、誰が貢献したを示すこの部分を残すこと。 | |
4039 ## 再配布や雑誌の付録などの問い合わせも必要ありません。 | |
4040 ## 営利利用も上記に反しない範囲で許可します。 | |
4041 ## バイナリの配布の際にはversion messageを保存することを条件とします。 | |
4042 ## このプログラムについては特に何の保証もしない、悪しからず。 | |
4043 ## | |
4044 ## Everyone is permitted to do anything on this program | |
4045 ## including copying, modifying, improving, | |
4046 ## as long as you don't try to pretend that you wrote it. | |
4047 ## i.e., the above copyright notice has to appear in all copies. | |
4048 ## Binary distribution requires original version messages. | |
4049 ## You don't have to ask before copying, redistribution or publishing. | |
4050 ## THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE. | |
4051 ## | |
4052 ## | |
4053 ## $Id$ | |
4054 #######################################################################/ | |
4055 | |
4056 | |
4057 =cut |