view release on metacpan or  search on metacpan

lib/AddressBook/DB/BBDB.pm  view on Meta::CPAN

END

my $notes_pat = <<END;
(?:$nil_or_string_pat|           # Might be nil or just a string
\\(                              # An open (
   $alist_pat+                   # and at least one Alist
\\)                              # And a closed )
)
END

my $bbdb_entry_pat = <<END;
\\[                              # Opening vector [
$nil_or_string_pat   \\          # First name
$nil_or_string_pat   \\          # Last name
($aka_pat) \\                    # Also Known As
$nil_or_string_pat   \\          # Company name
($phone_pat) \\                  # Phone list
($address_pat) \\                # Address list
($net_pat)   \\                  # Net names list
($notes_pat) \\                  # Notes Alist
(?:nil\\ *)+                     # Always nil as far as I can tell
\\]                              # Closing vector ]
END

########################################################################
# I added some ()s inside the patterns above, to make it possible to 
# break out the sub fields of a bbdb record.  Once consequence of this 
# is to make it very difficult to figure out at what position the top
# level fields are, so the subroutine _figure_out_indices does exactly
# that.  It uses the sample data below, and searches the fields that are 
# matched by the $bbdb_entry_pat pattern above.  The results are stored
# in the %field_index hash so we can reference them by name, and perhaps
# change the ()s in the patterns above without breaking everything.
########################################################################

my @field_names = 
qw (first last aka company phone address net notes);
my %field_names;
@field_names{@field_names} = (0..$#field_names);

my $sample_data = <<END;
["first" "last" ("aka") "company" (["phone with integer" 123 456 789] ["phone with quotes" "123-456-789"]) (["address" "street1" "street2" "street3" "city" "state" ("zip")]) ("net") ((notes . "data")) nil]
END

my %field_index;
sub _figure_out_indices {
  my @fields = ($sample_data =~ m/^$bbdb_entry_pat$/ox);
  my @names = @field_names;
  my $i;
  for ($i=0; $i < @fields; $i++) {
    if ($fields[$i] =~ $names[0]) {
      $field_index{shift @names} = $i;
      last unless @names;
    }
  }
}
_figure_out_indices();

########################################################################

sub un_escape {
  my $s = shift;
  $s =~ s/\\(.)/$1/g;               # should just be " or \
  return $s;
}

########################################################################

sub decode {
  my ($self,$str) = @_;
  my @fields = ();
  unless (@fields = ($str =~ m/^$bbdb_entry_pat$/ox)) {
    if ($BBDB::debug) {
      my $pat = '';
      my @subpats = (
		     [ '\[', 'opening ['],
		     [ $nil_or_string_pat, 'First name'],
		     [ $nil_or_string_pat, 'Last name'],
		     [ $aka_pat, 'Also known as'],
		     [ $nil_or_string_pat, 'Company name'],
		     [ $phone_pat, 'Phone'],
		     [ $address_pat, 'Address'],
		     [ $net_pat, 'Net names' ],
		     [ $notes_pat, 'Notes'],
		     [ 'nil', 'Last nil'],
		     [ '\]', 'closing ]']
		    );
      my $i;
      foreach $i (@subpats) {
	$pat .= $i->[0];
	printf STDERR "No match at %s\n", $i->[1] and last unless
	  $str =~ m/^$pat/x;
	$pat .= '\ ' unless $i->[0] eq '\[' or $i->[0] eq 'nil' ;
      }
    }
    return undef;
  }


  my $i;
  local($_);

  foreach $i (@field_names) {
    $fields[$field_index{$i}] = ''
      if (!defined $fields[$field_index{$i}] or 
	  $fields[$field_index{$i}] eq 'nil');
  }

  my @aka = split(/$quoted_string_pat/ox,$fields[$field_index{aka}]);
  #    print "AKA=\n<",join(">\n<",@aka),">\nEND AKA\n";
  my $aka = [];
  for ($i=0; $i < @aka - 1; $i+=2) {
    push @$aka, un_escape($aka[$i+1]);
  }

  my @phone = split(/$single_phone_pat/ox,$fields[$field_index{phone}]);
  #    print "PHONE=\n<",join(">\n<",@phone),">\nEND PHONE\n";
  my $phone = [];
    for ($i=0; $i < @phone - 1; $i+=5) {
      push @$phone,[
		    un_escape($phone[$i+1]),
		     un_escape(defined $phone[$i+3] ? 
			       $phone[$i+3] : $phone[$i+4])
		   ];
    }

  my @address = split(/$single_address_pat/ox,$fields[$field_index{address}]);
  #    print "ADDRESS=\n<",join(">\n<",@address),">\nEND ADDRESS\n";
  my $address = [];
    for ($i=0; $i < @address - 1; $i+=9) {
      my $zip = $address[$i+7];
      $zip =~ s/^\((.*)\)$/$1/;   # remove ()
      if (defined $address[$i+8]) {  # we have quoted strings
	my @zip = split(/$quoted_string_pat/ox,$zip);
	#   print "ZIP = \n<",join(">\n<",@zip),">\nEND ZIP\n";
	$zip = join('',@zip);
      }
      push @$address,[
		      un_escape($address[$i+1]),
		      un_escape($address[$i+2]),
		      un_escape($address[$i+3]),
		      un_escape($address[$i+4]),
		      un_escape($address[$i+5]),
		      un_escape($address[$i+6]),
		      $zip
		     ];
    }

  my @net = split(/$quoted_string_pat/ox,$fields[$field_index{net}]);
  #    print "NET=\n<",join(">\n<",@net),">\nEND NET\n";
  my $net = [];
  for ($i=0; $i < @net - 1; $i+=2) {
    push @$net, un_escape($net[$i+1]);
  }


  my @notes = split(/$alist_pat/ox,$fields[$field_index{notes}]);
  #    print "NOTES=\n<",join(">\n<",@notes),">\nEND NOTES\n";
  my $notes = [];
  for ($i=0; $i < @notes - 1; $i+=4) {
    push @$notes, [
		   $notes[$i+2],
		   un_escape($notes[$i+3])
		  ]
  }

  $self->{'data'} =  [
	  un_escape($fields[$field_index{first}]),
	  un_escape($fields[$field_index{last}]),
	  $aka,
	  un_escape($fields[$field_index{company}]),
	  $phone,
	  $address,
	  $net,
	  $notes
	 ];
  return 1;
}

########################################################################

sub quoted_stringify {               # escape \ and " in a string
  my $s = shift;                     # and return it surrounded by
  $s =~ s/(\\|")/\\$1/g;             # quotes
  return "\"$s\"";
}

sub nil_or_string {                  # return nil if empty string
  return 'nil' if $_[0] eq '';       # otherwise quote it
  return quoted_stringify(@_);
}

sub nil_or_list {                    # return nil if empty string
  return 'nil' if $_[0] eq '';       # otherwise quote it and add ()s
  return '(' . quoted_stringify(@_) . ')' ;
}

########################################################################

sub encode {
  my $self = shift;
  my ($first, $last, $aka, $company, 
      $phone, $address, $net, $notes) = @{$self->{'data'}};
  my ($i,@result,$s);
  push @result,nil_or_string($first);
  push @result,nil_or_string($last);

  if (@$aka) {
    my @aka;
    foreach $i (@$aka) {
      push @aka, quoted_stringify($i);
    }
    push @result, "(@aka)";
  } else {
    push @result, 'nil';
  }

  push @result,nil_or_string($company);

  if (@$phone) {
    my @phone;
    foreach $i (@$phone) {
      my $number;
      if ( $i->[1] =~ m/^\D?(\d{3})\D(\d{3})\D+(\d{4})\D?(\d*)$/ ) {
	$number = "$1 $2 $3 ";
	$number .= $4 ? $4 : '0';
      } else {
	$number = quoted_stringify($i->[1]);
      }
      push @phone,"[" . quoted_stringify($i->[0]) . " $number]";
      ;
    }
    push @result, "(@phone)";
  } else {
    push @result, 'nil';
  }
  if (@$address) {
    my @address;
    foreach $i (@$address) {
      my $zip = $i->[6];
      if ($zip =~ m/^(\d{5})\D?(\d{4})?$/) {
	$zip = $1;