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