1# -*-Perl-*-
2################################################################
3###
4###			      Address.pm
5###
6### Author:  Internet Message Group <img@mew.org>
7### Created: Apr 23, 1997
8### Revised: Apr 23, 2007
9###
10
11my $PM_VERSION = "IM::Address.pm version 20161010(IM153)";
12
13package IM::Address;
14require 5.003;
15require Exporter;
16
17use IM::Util;
18use integer;
19use strict;
20use vars qw(@ISA @EXPORT);
21
22@ISA = qw(Exporter);
23@EXPORT = qw(extract_addr replace_addr fetch_addr);
24
25use vars qw($FOR_SMTP); # sub fetch_addr
26
27##### EXTRACT AN ADDRESS FROM AN ADDRESS EXPRESSION #####
28#
29# extract_addr(address)
30#	address: an address in any style
31#	return values: pure address portion (NULL if error)
32#
33sub extract_addr($) {
34    my $addrin = shift;
35
36    $addrin =~ s/\n\s+//g;
37    return (&fetch_addr($addrin, 1))[0];	# strip ()-style comment
38}
39
40##### REPLACE THE ADDRESS IN AN ADDRESS EXPRESSION #####
41#
42# replace_addr(expr, old, new)
43#	expr:
44#	old:
45#	new:
46#	return value: replaced expression
47#
48sub replace_addr($$$) {
49    my($expr, $old, $new) = @_;
50    my $qold = quotemeta($old);
51
52    if ($expr =~ /$qold.*$qold/) {
53	# multiple appearance
54	return $new;	# XXX drop comment portion
55    }
56    $expr =~ s/$qold/$new/;
57    return $expr if (&extract_addr($expr) eq $new);
58    # something wrong. why?
59    return $new;	# XXX drop comment portion
60}
61
62##### GET FIRST ADDRESS #####
63#
64# sub fetch_addr(addr_list, extract)
65#	addr_list: address list string (concatinated with ",")
66#	extract: extract pure address portion
67#	return values: (first, rest, friendly)
68#	  first: the first address in the list (NULL if error)
69#	  rest: rest of address in the list
70#	  friendly: user friendly portion of the first address
71#
72sub fetch_addr($$) {
73    my($addrin, $extract) = @_;
74    my($addrout, $pureout, $groupsyntax) = ('', '', '');
75    my($friendly1, $friendly2, $c) = ('', '', '');
76    my($inquote, $incomment, $addrquote) = (0, 0, 0);
77    my($gotpure, $groupcolon, $route) = (0, 0, 0);
78    im_debug("fetch_addr(in): $addrin\n") if (&debug('addr'));
79    $FOR_SMTP = (&progname =~ /imput/i) unless (defined($FOR_SMTP));
80    $addrin = '' unless (defined($addrin));
81    $route = 1 if ($addrin =~ /^\@/);
82    while ($addrin ne '') {
83	if ($addrin =~ /^([^\e"\\()<>:;,]+)(.*)/s) {  #"
84	    $c = $1;
85	    $addrin = $2;
86	} elsif ($addrin =~ /^\e/) {
87	    if ($FOR_SMTP) {
88		im_err("ESC sequence not allowed in address expression\n");
89		return ('', '', '');
90	    } else {
91		if ($addrin =~ /^(\e[^\e]+\e\([BJ])(.*)/s) {
92		    $c = $1;
93		    $addrin = $2;
94		} else {
95		    ($c, $addrin) = unpack('a a*', $addrin);
96		}
97	    }
98	} else {
99	    ($c, $addrin) = unpack('a a*', $addrin);
100	}
101
102	last if ($c eq ',' && !$inquote && !$incomment && !$groupcolon
103	         && !$route);
104	$friendly2 .= $c unless ($addrquote);
105	if ($inquote) {
106	    $addrout .= $c;
107	    $pureout .= $c unless ($gotpure);
108	    if ($c eq '"') {
109		$inquote = 0;
110	    } elsif ($c eq '\\') {
111		($c, $addrin) = unpack('a a*', $addrin);
112		$addrout .= $c;
113		$pureout .= $c unless ($gotpure);
114		$friendly2 .= $c unless ($addrquote);
115	    }
116	    next;
117	} elsif ($incomment) {
118	    $addrout .= $c unless ($extract);
119	    $friendly1 .= $c;
120	    if ($c eq '(') {
121		$incomment++;
122	    } elsif ($c eq ')') {
123		$incomment--;
124	    } elsif ($c eq '\\') {
125		($c, $addrin) = unpack('a a*', $addrin);
126		$friendly1 .= $c;
127		$friendly2 .= $c unless ($addrquote);
128		$addrout .= $c unless ($extract);
129	    }
130	    chop($friendly1) unless ($incomment);
131	    next;
132	} elsif ($c eq '"') {
133	    $inquote = 1;
134	} elsif ($c eq '(') {
135	    $incomment++;
136	    next if ($extract);
137	} elsif ($c eq ')') {
138	    im_err('Unbalanced comment parenthesis '
139	      ."('(', ')'): $addrout -- $addrin\n");
140	    return ('', '', '');
141	} elsif ($c eq '<') {
142	    $gotpure = 0;
143	    $pureout = '';
144	    chop($friendly2) unless ($addrquote);
145	    $addrquote++;
146	    $route = 1 if ($addrin =~ /^\@/);
147	} elsif ($c eq '>') {
148	    $gotpure = 1;
149	    $pureout =~ s/^<//;
150	    $addrquote--;
151	    $route = 0;
152	} elsif ($c eq '\\') {
153	    $addrout .= $c;
154	    $pureout .= $c unless ($gotpure);
155	    ($c, $addrin) = unpack('a a*', $addrin);
156	    $friendly2 .= $c unless ($addrquote);
157	} elsif ($c eq ':') {
158	    $addrout .= $c;
159	    $pureout .= $c unless ($gotpure);
160	    if ($addrin =~ /^([^"\()<>:;,]+)(.*)/s) {  #"
161		$c = $1;
162		$addrin = $2;
163	    } else {
164		($c, $addrin) = unpack('a a*', $addrin);
165	    }
166	    $friendly2 .= $c unless ($addrquote);
167	    $groupcolon = 1 if ($c ne ':');
168	} elsif ($c eq ';') {
169	    if ($groupcolon) {
170		$groupcolon = 0;
171		$groupsyntax = 1;
172	    }
173	} elsif ($c eq ',') {
174	    last unless ($groupcolon || $route);
175	}
176	$addrout .= $c;
177	$pureout .= $c unless ($gotpure);
178    }
179    im_debug("fetch_addr(out): $addrout\n") if (&debug('addr'));
180    if ($addrquote) {
181	im_err("Unbalanced address quotes ('<', '>'): $addrout\n");
182	return('', '', '');
183    }
184    if ($inquote) {
185	im_err("Unbalanced quotes ('\"'): $addrout\n");
186	return('', '', '');
187    }
188    if ($incomment) {
189	im_err("Unbalanced comment parenthesis ('(', ')'): $addrout\n");
190	return('', '', '');
191    }
192    if ($extract && !$groupsyntax) {
193	if ($addrout =~ /<.*>/) {
194	    $addrout = $pureout;
195	    $friendly1 = $friendly2;
196	}
197	$addrout =~ s/^\s+//;
198	$addrout =~ s/\s+$//;
199	$friendly1 =~ s/^\s+//;
200	$friendly1 =~ s/\s+$//;
201    }
202    return ($addrout, $addrin, $friendly1);
203}
204
2051;
206
207__END__
208
209=head1 NAME
210
211IM::Address - RFC822 style address parser
212
213=head1 SYNOPSIS
214
215 use IM::Address;
216
217 $pure_address_portion = &extract_addr($address_with_comment);
218
219 $replaced_address = &replace_addr($original_address_with_comment,
220     $pure_notation_of_old_address, $pure_notation_of_new_address);
221
222 ($first, $rest) = &fetch_addr($address_list, $pure_address_flag);
223
224=head1 DESCRIPTION
225
226The I<IM::Address> module is a parser for RFC822 style address.
227
228This modules is provided by IM (Internet Message).
229
230=head1 EXAMPLES
231
232 $a = "Motonori Nakamura <motonori\@econ.kyoto-u.ac.jp>";
233 &extract_addr($a) returns "motonori@econ.kyoto-u.ac.jp".
234
235 $a = "Motonori Nakamura <motonori\@econ.kyoto-u.ac.jp>";
236 $b = "motonori\@econ.kyoto-u.ac.jp";
237 $c = "motonori\@wide.ad.jp";
238 &replace_addr($a, $b, $c) returns "Motonori Nakamura <motonori@wide.ad.jp>".
239
240 $a = "kazu, nom, motonori";
241 &fetch_addr($a, 0) returns ("kazu", " nom, motonori").
242
243=head1 COPYRIGHT
244
245IM (Internet Message) is copyrighted by IM developing team.
246You can redistribute it and/or modify it under the modified BSD
247license.  See the copyright file for more details.
248
249=cut
250
251### Copyright (C) 1997, 1998, 1999 IM developing team
252### All rights reserved.
253###
254### Redistribution and use in source and binary forms, with or without
255### modification, are permitted provided that the following conditions
256### are met:
257###
258### 1. Redistributions of source code must retain the above copyright
259###    notice, this list of conditions and the following disclaimer.
260### 2. Redistributions in binary form must reproduce the above copyright
261###    notice, this list of conditions and the following disclaimer in the
262###    documentation and/or other materials provided with the distribution.
263### 3. Neither the name of the team nor the names of its contributors
264###    may be used to endorse or promote products derived from this software
265###    without specific prior written permission.
266###
267### THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
268### ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
269### IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
270### PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
271### LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
272### CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
273### SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
274### BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
275### WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
276### OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
277### IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
278