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