host1:~lace/src/PerlMail/ update.
[PerlMail.git] / PerlMail / Contacts / 9210.pm
1 #! /usr/bin/perl
2
3 #       $Id: 9210.pm,v 1.4 2004/12/19 11:47:47 short Exp $
4 # Copyright (C) 2002-2004 Jan Kratochvil <project-PerlMail@jankratochvil.net>
5
6 # This program is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 2 of the License, or
9 # (at your option) any later version.
10
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 # GNU General Public License for more details.
15
16 # You should have received a copy of the GNU General Public License
17 # along with this program; if not, write to the Free Software
18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
19
20
21 package PerlMail::Contacts::9210::Text::CSV::Simple;
22 use vars qw(@ISA);
23 require Text::CSV::Simple;
24 @ISA=qw(Text::CSV::Simple);
25 require Encode::Guess;
26 use bytes;
27
28 sub _contents
29 {
30 my($self)=@_;
31
32         my $pathname=$self->{"_file"};
33         my $F;
34         if (substr($pathname,0,1) eq "\x00") {
35                 $F=substr($pathname,1);
36                 }
37         else {
38                 local *F;
39                 open F,$pathname or die "open \"$pathname\": $!";
40                 $F=do { undef $/; <F>; };
41                 close F or die "close \"$pathname\": $!";
42                 }
43         my $encoding=Encode::Guess::guess_encoding($F);
44         ref $encoding or die "Cannot guess encoding of: $pathname";
45         my $F_utf8=$encoding->decode($F);
46         $F_utf8=~tr/\r\n/\n\n/s;
47         return split /\n/,$F_utf8;
48 }
49
50
51 package PerlMail::Contacts::9210;
52 use vars qw($VERSION);
53 $VERSION=do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf "%d.".("%03d"x$#r),@r; };
54 use strict;
55 use warnings;
56 use vars qw(@ISA);
57 require PerlMail::Contacts;
58 @ISA=qw(PerlMail::Contacts);
59
60
61 sub in
62 {
63 my($self,$data)=@_;
64
65         $self=$self->new() if !ref $self;
66         my @F=PerlMail::Contacts::9210::Text::CSV::Simple->new()->read_file("\x00".$data);
67         my @id=@{shift @F};
68         $id[0] eq "CntMngCsv 3.0.0" or die "Unknown file format";
69         shift @F;       # drop unknown header numbers;
70         my @names=@{shift @F};
71         $names[0] eq "ID" or die "field[0] not 'ID'";
72         my %id;
73         for my $fields (@F) {
74                 @names==@$fields or die "Fields line fields do not match the header names number";
75                 my $id=$fields->[0];
76                 my($omail_name,$omail_data);
77                 my($name_last,$name_first);
78                 my @mail;
79                 for my $fieldi (1..$#names) {
80                         my $string=$fields->[$fieldi];
81                         next if $string eq "";
82                         my $name=$names[$fieldi];
83                         my $first=!exists $id{$id}{$name};
84                         $id{$id}{$name}=$string if $first;
85                         if ($name eq "Last name") {
86                                 die "Non-matching field" if $string ne $id{$id}{$name};
87                                 $name_last=$string;
88                                 }
89                         elsif ($name eq "First name") {
90                                 die "Non-matching field" if $string ne $id{$id}{$name};
91                                 $name_first=$string;
92                                 }
93                         elsif ($name eq "Company") {
94                                 die "Non-matching field" if $string ne $id{$id}{$name};
95                                 push @{$id{$id}{""}},{
96             "FIELD"=>"Company",
97             "FIELD-DATA"=>$string,
98                                                 } if $first;
99                                 }
100                         elsif ($name eq "Other Mail desc.") {
101                                 $omail_name=$string;
102                                 }
103                         elsif ($name eq "Other Mail") {
104                                 $omail_data=$string;
105                                 }
106                         elsif ($name eq "Mail") {
107                                 push @mail,undef()=>$string;
108                                 }
109                         elsif ($name=~/^Mail [(](.*)[)]$/) {
110                                 push @mail,$1=>$string;
111                                 }
112                         }
113                 my $name=$name_last;
114                 $name.=" ".$name_first if defined $name_first;
115                 push @{$id{$id}{""}},{
116                                 "FIELD"=>"Name",
117                                 "FIELD-DATA"=>$name,
118                                 } if defined $name;
119                 push @mail,$omail_name=>$omail_data if defined $omail_data;
120                 while (@mail) {
121                         my $name=shift @mail;
122                         my $data=shift @mail;
123                         push @{$id{$id}{""}},{
124                                         "FIELD"=>"Mail",
125                                         "FIELD-NAME"=>$name,
126                                         "FIELD-DATA"=>$data,
127                                         };
128                         }
129                 }
130         return map(($id{$_}{""}||()),(sort { ($a<=>$b); } keys(%id)));
131 }
132
133 1;