1#!/usr/bin/perl 2# Copyright (c) 2015-2018 by Pali <pali@cpan.org> 3 4# Before `make install' is performed this script should be runnable with 5# `make test'. After `make install' it should work as `perl Email-Address-XS.t' 6 7######################### 8 9use strict; 10use warnings; 11 12# perl version which needs "use utf8;" for comparing utf8 and latin1 strings 13BEGIN { 14 require utf8 if $] < 5.006001; 15 utf8->import() if $] < 5.006001; 16}; 17 18use Carp; 19$Carp::Internal{'Test::Builder'} = 1; 20$Carp::Internal{'Test::More'} = 1; 21 22use Test::More tests => 511; 23use Test::Builder; 24 25local $SIG{__WARN__} = sub { 26 local $Test::Builder::Level = $Test::Builder::Level + 1; 27 fail('following test does not throw warning'); 28 warn $_[0]; 29}; 30 31sub with_warning(&) { 32 my ($code) = @_; 33 local $Test::Builder::Level = $Test::Builder::Level + 1; 34 my $warn; 35 local $SIG{__WARN__} = sub { $warn = 1; }; 36 my @ret = wantarray ? $code->() : scalar $code->(); 37 ok($warn, 'following test throws warning'); 38 return wantarray ? @ret : $ret[0]; 39} 40 41sub obj_to_hashstr { 42 my ($self) = @_; 43 my $out = ""; 44 foreach ( qw(user host phrase comment) ) { 45 next unless exists $self->{$_}; 46 $out .= $_ . ':' . (defined $self->{$_} ? $self->{$_} : '(undef)') . ';'; 47 } 48 return $out; 49} 50 51######################### 52 53BEGIN { 54 use_ok('Email::Address::XS', qw(parse_email_addresses parse_email_groups format_email_addresses format_email_groups)); 55}; 56 57######################### 58 59require overload; 60my $obj_to_origstr = overload::Method 'Email::Address::XS', '""'; 61my $obj_to_hashstr = \&obj_to_hashstr; 62 63# set stringify and eq operators for comparision used in is_deeply 64{ 65 local $SIG{__WARN__} = sub { }; 66 overload::OVERLOAD 'Email::Address::XS', '""' => $obj_to_hashstr; 67 overload::OVERLOAD 'Email::Address::XS', 'eq' => sub { obj_to_hashstr($_[0]) eq obj_to_hashstr($_[1]) }; 68} 69 70######################### 71 72{ 73 74 { 75 my $subtest = 'test method new() without arguments'; 76 my $address = Email::Address::XS->new(); 77 ok(!$address->is_valid(), $subtest); 78 is($address->phrase(), undef, $subtest); 79 is($address->user(), undef, $subtest); 80 is($address->host(), undef, $subtest); 81 is($address->address(), undef, $subtest); 82 is($address->comment(), undef, $subtest); 83 is($address->name(), '', $subtest); 84 is(with_warning { $address->format() }, '', $subtest); 85 } 86 87 { 88 my $subtest = 'test method new() with one argument'; 89 my $address = Email::Address::XS->new('Addressless Outer Party Member'); 90 ok(!$address->is_valid(), $subtest); 91 is($address->phrase(), 'Addressless Outer Party Member', $subtest); 92 is($address->user(), undef, $subtest); 93 is($address->host(), undef, $subtest); 94 is($address->address(), undef, $subtest); 95 is($address->comment(), undef, $subtest); 96 is($address->name(), 'Addressless Outer Party Member', $subtest); 97 is(with_warning { $address->format() }, '', $subtest); 98 } 99 100 { 101 my $subtest = 'test method new() with two arguments as array'; 102 my $address = Email::Address::XS->new(undef, 'user@oceania'); 103 ok($address->is_valid(), $subtest); 104 is($address->phrase(), undef, $subtest); 105 is($address->user(), 'user', $subtest); 106 is($address->host(), 'oceania', $subtest); 107 is($address->address(), 'user@oceania', $subtest); 108 is($address->comment(), undef, $subtest); 109 is($address->name(), 'user', $subtest); 110 is($address->format(), 'user@oceania', $subtest); 111 } 112 113 { 114 my $subtest = 'test method new() with two arguments as hash'; 115 my $address = Email::Address::XS->new(address => 'winston.smith@recdep.minitrue'); 116 ok($address->is_valid(), $subtest); 117 is($address->phrase(), undef, $subtest); 118 is($address->user(), 'winston.smith', $subtest); 119 is($address->host(), 'recdep.minitrue', $subtest); 120 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 121 is($address->comment(), undef, $subtest); 122 is($address->name(), 'winston.smith', $subtest); 123 is($address->format(), 'winston.smith@recdep.minitrue', $subtest); 124 } 125 126 { 127 my $subtest = 'test method new() with two arguments as array'; 128 my $address = Email::Address::XS->new(Julia => 'julia@ficdep.minitrue'); 129 ok($address->is_valid(), $subtest); 130 is($address->phrase(), 'Julia', $subtest); 131 is($address->user(), 'julia', $subtest); 132 is($address->host(), 'ficdep.minitrue', $subtest); 133 is($address->address(), 'julia@ficdep.minitrue', $subtest); 134 is($address->comment(), undef, $subtest); 135 is($address->name(), 'Julia', $subtest); 136 is($address->format(), 'Julia <julia@ficdep.minitrue>', $subtest); 137 } 138 139 { 140 my $subtest = 'test method new() with three arguments'; 141 my $address = Email::Address::XS->new('Winston Smith', 'winston.smith@recdep.minitrue', 'Records Department'); 142 ok($address->is_valid(), $subtest); 143 is($address->phrase(), 'Winston Smith', $subtest); 144 is($address->user(), 'winston.smith', $subtest); 145 is($address->host(), 'recdep.minitrue', $subtest); 146 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 147 is($address->comment(), 'Records Department', $subtest); 148 is($address->name(), 'Winston Smith', $subtest); 149 is($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue> (Records Department)', $subtest); 150 } 151 152 { 153 my $subtest = 'test method new() with four arguments user & host as hash'; 154 my $address = Email::Address::XS->new(user => 'julia', host => 'ficdep.minitrue'); 155 ok($address->is_valid(), $subtest); 156 is($address->phrase(), undef, $subtest); 157 is($address->user(), 'julia', $subtest); 158 is($address->host(), 'ficdep.minitrue', $subtest); 159 is($address->address(), 'julia@ficdep.minitrue', $subtest); 160 is($address->comment(), undef, $subtest); 161 is($address->name(), 'julia', $subtest); 162 is($address->format(), 'julia@ficdep.minitrue', $subtest); 163 } 164 165 { 166 my $subtest = 'test method new() with four arguments phrase & address as hash'; 167 my $address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'); 168 ok($address->is_valid(), $subtest); 169 is($address->phrase(), 'Julia', $subtest); 170 is($address->user(), 'julia', $subtest); 171 is($address->host(), 'ficdep.minitrue', $subtest); 172 is($address->address(), 'julia@ficdep.minitrue', $subtest); 173 is($address->comment(), undef, $subtest); 174 is($address->name(), 'Julia', $subtest); 175 is($address->format(), 'Julia <julia@ficdep.minitrue>', $subtest); 176 } 177 178 { 179 my $subtest = 'test method new() with four arguments as array'; 180 my $address = with_warning { Email::Address::XS->new('Julia', 'julia@ficdep.minitrue', 'Fiction Department', 'deprecated_original_string') }; 181 ok($address->is_valid(), $subtest); 182 is($address->phrase(), 'Julia', $subtest); 183 is($address->user(), 'julia', $subtest); 184 is($address->host(), 'ficdep.minitrue', $subtest); 185 is($address->address(), 'julia@ficdep.minitrue', $subtest); 186 is($address->comment(), 'Fiction Department', $subtest); 187 is($address->name(), 'Julia', $subtest); 188 is($address->format(), 'Julia <julia@ficdep.minitrue> (Fiction Department)', $subtest); 189 } 190 191 { 192 my $subtest = 'test method new() with four arguments as hash (phrase is string "address")'; 193 my $address = Email::Address::XS->new(phrase => 'address', address => 'user@oceania'); 194 ok($address->is_valid(), $subtest); 195 is($address->phrase(), 'address', $subtest); 196 is($address->user(), 'user', $subtest); 197 is($address->host(), 'oceania', $subtest); 198 is($address->address(), 'user@oceania', $subtest); 199 is($address->comment(), undef, $subtest); 200 is($address->name(), 'address', $subtest); 201 is($address->format(), 'address <user@oceania>', $subtest); 202 } 203 204 { 205 my $subtest = 'test method new() with copy argument'; 206 my $address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'); 207 my $copy = Email::Address::XS->new(copy => $address); 208 ok($address->is_valid(), $subtest); 209 ok($copy->is_valid(), $subtest); 210 is($copy->phrase(), 'Julia', $subtest); 211 is($copy->user(), 'julia', $subtest); 212 is($copy->host(), 'ficdep.minitrue', $subtest); 213 is($copy->address(), 'julia@ficdep.minitrue', $subtest); 214 is($copy->comment(), undef, $subtest); 215 $copy->phrase('Winston Smith'); 216 $copy->address('winston.smith@recdep.minitrue'); 217 $copy->comment('Records Department'); 218 is($address->phrase(), 'Julia', $subtest); 219 is($address->user(), 'julia', $subtest); 220 is($address->host(), 'ficdep.minitrue', $subtest); 221 is($address->address(), 'julia@ficdep.minitrue', $subtest); 222 is($address->comment(), undef, $subtest); 223 $address->phrase(undef); 224 $address->address(undef); 225 $address->comment(undef); 226 is($copy->phrase(), 'Winston Smith', $subtest); 227 is($copy->user(), 'winston.smith', $subtest); 228 is($copy->host(), 'recdep.minitrue', $subtest); 229 is($copy->address(), 'winston.smith@recdep.minitrue', $subtest); 230 is($copy->comment(), 'Records Department', $subtest); 231 } 232 233 { 234 my $subtest = 'test method new() with invalid email address'; 235 my $address = Email::Address::XS->new(address => 'invalid_address'); 236 ok(!$address->is_valid(), $subtest); 237 is($address->phrase(), undef, $subtest); 238 is($address->user(), undef, $subtest); 239 is($address->host(), undef, $subtest); 240 is($address->address(), undef, $subtest); 241 is($address->comment(), undef, $subtest); 242 is($address->name(), '', $subtest); 243 is(with_warning { $address->format() }, '', $subtest); 244 } 245 246 { 247 my $subtest = 'test method new() with copy argument of invalid email address'; 248 my $address = Email::Address::XS->new(address => 'invalid_address'); 249 my $copy = Email::Address::XS->new(copy => $address); 250 ok(!$address->is_valid(), $subtest); 251 ok(!$copy->is_valid(), $subtest); 252 } 253 254 { 255 my $subtest = 'test method new() with empty strings for user and non empty for host and phrase'; 256 my $address = Email::Address::XS->new(user => '', host => 'host', phrase => 'phrase'); 257 ok($address->is_valid(), $subtest); 258 is($address->phrase(), 'phrase', $subtest); 259 is($address->user(), '', $subtest); 260 is($address->host(), 'host', $subtest); 261 is($address->address(), '""@host', $subtest); 262 is($address->comment(), undef, $subtest); 263 is($address->name(), 'phrase', $subtest); 264 is($address->format(), 'phrase <""@host>', $subtest); 265 } 266 267 { 268 my $subtest = 'test method new() with empty strings for host and non empty for user and phrase'; 269 my $address = Email::Address::XS->new(user => 'user', host => '', phrase => 'phrase'); 270 ok(!$address->is_valid(), $subtest); 271 is($address->phrase(), 'phrase', $subtest); 272 is($address->user(), 'user', $subtest); 273 is($address->host(), undef, $subtest); 274 is($address->address(), undef, $subtest); 275 is($address->comment(), undef, $subtest); 276 is($address->name(), 'phrase', $subtest); 277 is(with_warning { $address->format() }, '', $subtest); 278 } 279 280 { 281 my $subtest = 'test method new() with all named arguments'; 282 my $address = Email::Address::XS->new(phrase => 'Julia', user => 'julia', host => 'ficdep.minitrue', comment => 'Fiction Department'); 283 ok($address->is_valid(), $subtest); 284 is($address->phrase(), 'Julia', $subtest); 285 is($address->user(), 'julia', $subtest); 286 is($address->host(), 'ficdep.minitrue', $subtest); 287 is($address->address(), 'julia@ficdep.minitrue', $subtest); 288 is($address->comment(), 'Fiction Department', $subtest); 289 is($address->name(), 'Julia', $subtest); 290 is($address->format(), 'Julia <julia@ficdep.minitrue> (Fiction Department)', $subtest); 291 } 292 293 { 294 my $subtest = 'test method new() that address takes precedence over user and host'; 295 my $address = Email::Address::XS->new(user => 'winston.smith', host => 'recdep.minitrue', address => 'julia@ficdep.minitrue' ); 296 is($address->user(), 'julia', $subtest); 297 is($address->host(), 'ficdep.minitrue', $subtest); 298 is($address->address(), 'julia@ficdep.minitrue', $subtest); 299 } 300 301 { 302 my $subtest = 'test method new() with UNICODE characters'; 303 my $address = Email::Address::XS->new(phrase => "\x{2606} \x{2602}", user => "\x{263b} \x{265e}", host => "\x{262f}.\x{262d}", comment => "\x{2622} \x{20ac}"); 304 ok($address->is_valid(), $subtest); 305 is($address->phrase(), "\x{2606} \x{2602}", $subtest); 306 is($address->user(), "\x{263b} \x{265e}", $subtest); 307 is($address->host(), "\x{262f}.\x{262d}", $subtest); 308 is($address->address(), "\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}", $subtest); 309 is($address->comment(), "\x{2622} \x{20ac}", $subtest); 310 is($address->name(), "\x{2606} \x{2602}", $subtest); 311 is($address->format(), "\"\x{2606} \x{2602}\" <\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}> (\x{2622} \x{20ac})", $subtest); 312 } 313 314 { 315 my $subtest = 'test method new() with Latin1 characters'; 316 my $address = Email::Address::XS->new(user => "L\x{e1}tin1", host => "L\x{e1}tin1"); 317 ok($address->is_valid(), $subtest); 318 is($address->phrase(), undef, $subtest); 319 is($address->user(), "L\x{e1}tin1", $subtest); 320 is($address->host(), "L\x{e1}tin1", $subtest); 321 is($address->address(), "L\x{e1}tin1\@L\x{e1}tin1", $subtest); 322 is($address->comment(), undef, $subtest); 323 is($address->name(), "L\x{e1}tin1", $subtest); 324 is($address->format(), "L\x{e1}tin1\@L\x{e1}tin1", $subtest); 325 } 326 327 { 328 my $subtest = 'test method new() with mix of Latin1 and UNICODE characters'; 329 my $address = Email::Address::XS->new(user => "L\x{e1}tin1", host => "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"); 330 ok($address->is_valid(), $subtest); 331 is($address->phrase(), undef, $subtest); 332 is($address->user(), "L\x{e1}tin1", $subtest); 333 is($address->host(), "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}", $subtest); 334 is($address->address(), "L\x{e1}tin1\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}", $subtest); 335 is($address->comment(), undef, $subtest); 336 is($address->name(), "L\x{e1}tin1", $subtest); 337 is($address->format(), "L\x{e1}tin1\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}", $subtest); 338 } 339 340} 341 342######################### 343 344{ 345 346 my $address = Email::Address::XS->new(); 347 is($address->phrase(), undef, 'test method phrase()'); 348 349 is($address->phrase('Winston Smith'), 'Winston Smith', 'test method phrase()'); 350 is($address->phrase(), 'Winston Smith', 'test method phrase()'); 351 352 is($address->phrase('Julia'), 'Julia', 'test method phrase()'); 353 is($address->phrase(), 'Julia', 'test method phrase()'); 354 355 is($address->phrase(undef), undef, 'test method phrase()'); 356 is($address->phrase(), undef, 'test method phrase()'); 357 358} 359 360######################### 361 362{ 363 364 my $address = Email::Address::XS->new(); 365 is($address->user(), undef, 'test method user()'); 366 367 is($address->user('winston'), 'winston', 'test method user()'); 368 is($address->user(), 'winston', 'test method user()'); 369 370 is($address->user('julia'), 'julia', 'test method user()'); 371 is($address->user(), 'julia', 'test method user()'); 372 373 is($address->user(undef), undef, 'test method user()'); 374 is($address->user(), undef, 'test method user()'); 375 376} 377 378######################### 379 380{ 381 382 my $address = Email::Address::XS->new(); 383 is($address->host(), undef, 'test method host()'); 384 385 is($address->host('eurasia'), 'eurasia', 'test method host()'); 386 is($address->host(), 'eurasia', 'test method host()'); 387 388 is($address->host('eastasia'), 'eastasia', 'test method host()'); 389 is($address->host(), 'eastasia', 'test method host()'); 390 391 is($address->host(undef), undef, 'test method host()'); 392 is($address->host(), undef, 'test method host()'); 393 394} 395 396######################### 397 398{ 399 400 my $address = Email::Address::XS->new(); 401 is($address->address(), undef, 'test method address()'); 402 403 is($address->address('winston.smith@recdep.minitrue'), 'winston.smith@recdep.minitrue', 'test method address()'); 404 is($address->address(), 'winston.smith@recdep.minitrue', 'test method address()'); 405 is($address->user(), 'winston.smith', 'test method address()'); 406 is($address->host(), 'recdep.minitrue', 'test method address()'); 407 408 is($address->user('julia@outer"party'), 'julia@outer"party', 'test method address()'); 409 is($address->user(), 'julia@outer"party', 'test method address()'); 410 is($address->host(), 'recdep.minitrue', 'test method address()'); 411 is($address->address(), '"julia@outer\\"party"@recdep.minitrue', 'test method address()'); 412 413 is($address->address('julia@ficdep.minitrue'), 'julia@ficdep.minitrue', 'test method address()'); 414 is($address->address(), 'julia@ficdep.minitrue', 'test method address()'); 415 is($address->user(), 'julia', 'test method address()'); 416 is($address->host(), 'ficdep.minitrue', 'test method address()'); 417 418 is($address->address(undef), undef, 'test method address()'); 419 is($address->address(), undef, 'test method address()'); 420 is($address->user(), undef, 'test method address()'); 421 is($address->host(), undef, 'test method address()'); 422 423 is($address->address('julia@ficdep.minitrue'), 'julia@ficdep.minitrue', 'test method address()'); 424 is($address->address('invalid_address'), undef, 'test method address()'); 425 is($address->address(), undef, 'test method address()'); 426 427} 428 429######################### 430 431{ 432 433 my $address = Email::Address::XS->new(); 434 is($address->comment(), undef, 'test method comment()'); 435 436 is($address->comment('Fiction Department'), 'Fiction Department', 'test method comment()'); 437 is($address->comment(), 'Fiction Department', 'test method comment()'); 438 439 is($address->comment('Records Department'), 'Records Department', 'test method comment()'); 440 is($address->comment(), 'Records Department', 'test method comment()'); 441 442 is($address->comment(undef), undef, 'test method comment()'); 443 is($address->comment(), undef, 'test method comment()'); 444 445 is($address->comment('(comment)'), '(comment)', 'test method comment()'); 446 is($address->comment(), '(comment)', 'test method comment()'); 447 448 is($address->comment('string (comment) string'), 'string (comment) string', 'test method comment()'); 449 is($address->comment(), 'string (comment) string', 'test method comment()'); 450 451 is($address->comment('string (comment (nested ()comment)another comment)()'), 'string (comment (nested ()comment)another comment)()', 'test method comment()'); 452 is($address->comment(), 'string (comment (nested ()comment)another comment)()', 'test method comment()'); 453 454 is($address->comment('string (comment \(not nested ()comment\)\)(nested\(comment()))'), 'string (comment \(not nested ()comment\)\)(nested\(comment()))', 'test method comment()'); 455 is($address->comment(), 'string (comment \(not nested ()comment\)\)(nested\(comment()))', 'test method comment()'); 456 457 is($address->comment('string\\\\()'), 'string\\\\()', 'test method comment()'); 458 is($address->comment(), 'string\\\\()', 'test method comment()'); 459 460 is($address->comment('string\\\\\\\\()'), 'string\\\\\\\\()', 'test method comment()'); 461 is($address->comment(), 'string\\\\\\\\()', 'test method comment()'); 462 463 is($address->comment('string ((not balanced comment)'), undef, 'test method comment()'); 464 is($address->comment(), undef, 'test method comment()'); 465 466 is($address->comment('string )(()not balanced'), undef, 'test method comment()'); 467 is($address->comment(), undef, 'test method comment()'); 468 469 is($address->comment('string \()not balanced'), undef, 'test method comment()'); 470 is($address->comment(), undef, 'test method comment()'); 471 472 is($address->comment('string(\)not balanced'), undef, 'test method comment()'); 473 is($address->comment(), undef, 'test method comment()'); 474 475 is($address->comment('string(\\\\\)not balanced'), undef, 'test method comment()'); 476 is($address->comment(), undef, 'test method comment()'); 477 478 is($address->comment("string\x00string"), undef, 'test method comment()'); 479 is($address->comment(), undef, 'test method comment()'); 480 481 is($address->comment("string\\\x00string"), "string\\\x00string", 'test method comment()'); 482 is($address->comment(), "string\\\x00string", 'test method comment()'); 483 484} 485 486######################### 487 488{ 489 490 my $address = Email::Address::XS->new(); 491 is($address->name(), '', 'test method name()'); 492 493 $address->user('user1'); 494 is($address->name(), 'user1', 'test method name()'); 495 496 $address->user('user2'); 497 is($address->name(), 'user2', 'test method name()'); 498 499 $address->host('host'); 500 is($address->name(), 'user2', 'test method name()'); 501 502 $address->address('winston.smith@recdep.minitrue'); 503 is($address->name(), 'winston.smith', 'test method name()'); 504 505 $address->comment('Winston'); 506 is($address->name(), 'Winston', 'test method name()'); 507 508 $address->phrase('Long phrase'); 509 is($address->name(), 'Long phrase', 'test method name()'); 510 511 $address->phrase('Long phrase 2'); 512 is($address->name(), 'Long phrase 2', 'test method name()'); 513 514 $address->user('user3'); 515 is($address->name(), 'Long phrase 2', 'test method name()'); 516 517 $address->comment('winston'); 518 is($address->name(), 'Long phrase 2', 'test method name()'); 519 520 $address->phrase(undef); 521 is($address->name(), 'winston', 'test method name()'); 522 523 $address->comment(undef); 524 is($address->name(), 'user3', 'test method name()'); 525 526 $address->address(undef); 527 is($address->name(), '', 'test method name()'); 528 529 $address->phrase('Long phrase 3'); 530 is($address->phrase(), 'Long phrase 3', 'test method name()'); 531 532} 533 534######################### 535 536{ 537 538 # set original stringify operator 539 { 540 local $SIG{__WARN__} = sub { }; 541 overload::OVERLOAD 'Email::Address::XS', '""' => $obj_to_origstr; 542 } 543 544 my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'); 545 is("$address", '"Winston Smith" <winston.smith@recdep.minitrue>', 'test object stringify'); 546 547 $address->phrase('Winston'); 548 is("$address", 'Winston <winston.smith@recdep.minitrue>', 'test object stringify'); 549 550 $address->address('winston@recdep.minitrue'); 551 is("$address", 'Winston <winston@recdep.minitrue>', 'test object stringify'); 552 553 $address->phrase(undef); 554 is("$address", 'winston@recdep.minitrue', 'test object stringify'); 555 556 $address->address(undef); 557 is(with_warning { "$address" }, '', 'test object stringify'); 558 559 # revert back 560 { 561 local $SIG{__WARN__} = sub { }; 562 overload::OVERLOAD 'Email::Address::XS', '""' => $obj_to_hashstr; 563 } 564 565} 566 567######################### 568 569{ 570 571 my $address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'); 572 is($address->format(), '"Winston Smith" <winston.smith@recdep.minitrue>', 'test method format()'); 573 574 $address->phrase('Julia'); 575 is($address->format(), 'Julia <winston.smith@recdep.minitrue>', 'test method format()'); 576 577 $address->address('julia@ficdep.minitrue'); 578 is($address->format(), 'Julia <julia@ficdep.minitrue>', 'test method format()'); 579 580 $address->phrase(undef); 581 is($address->format(), 'julia@ficdep.minitrue', 'test method format()'); 582 583 $address->address(undef); 584 is(with_warning { $address->format() }, '', 'test method format()'); 585 586 $address->user('julia'); 587 is(with_warning { $address->format() }, '', 'test method format()'); 588 589 $address->host('ficdep.minitrue'); 590 is($address->format(), 'julia@ficdep.minitrue', 'test method format()'); 591 592 $address->user(undef); 593 is(with_warning { $address->format() }, '', 'test method format()'); 594 595} 596 597######################### 598 599{ 600 601 is_deeply( 602 [ with_warning { Email::Address::XS->parse() } ], 603 [], 604 'test method parse() without argument', 605 ); 606 607 is_deeply( 608 [ with_warning { Email::Address::XS->parse(undef) } ], 609 [], 610 'test method parse() with undef argument', 611 ); 612 613 is_deeply( 614 [ Email::Address::XS->parse('') ], 615 [], 616 'test method parse() on empty string', 617 ); 618 619 { 620 my $subtest = 'test method parse() on invalid not parsable line'; 621 my @addresses = Email::Address::XS->parse('invalid_line'); 622 is_deeply( 623 \@addresses, 624 [ Email::Address::XS->new(phrase => 'invalid_line') ], 625 $subtest, 626 ) and do { 627 ok(!$addresses[0]->is_valid(), $subtest); 628 is($addresses[0]->original(), 'invalid_line', $subtest); 629 }; 630 } 631 632 { 633 my $subtest = 'test method parse() on string with valid addresses'; 634 my @addresses = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, user@oceania'); 635 is_deeply( 636 \@addresses, 637 [ 638 Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), 639 Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), 640 Email::Address::XS->new(address => 'user@oceania') 641 ], 642 $subtest, 643 ) and do { 644 ok($addresses[0]->is_valid(), $subtest); 645 ok($addresses[1]->is_valid(), $subtest); 646 ok($addresses[2]->is_valid(), $subtest); 647 is($addresses[0]->original(), '"Winston Smith" <winston.smith@recdep.minitrue>', $subtest); 648 is($addresses[1]->original(), 'Julia <julia@ficdep.minitrue>', $subtest); 649 is($addresses[2]->original(), 'user@oceania', $subtest); 650 }; 651 } 652 653 { 654 my $subtest = 'test method parse() in scalar context on empty string'; 655 my $address = Email::Address::XS->parse(''); 656 ok(!$address->is_valid(), $subtest); 657 is($address->original(), '', $subtest); 658 is($address->phrase(), undef, $subtest); 659 is($address->address(), undef, $subtest); 660 } 661 662 { 663 my $subtest = 'test method parse() in scalar context with one address'; 664 my $address = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue>'); 665 ok($address->is_valid(), $subtest); 666 is($address->original(), '"Winston Smith" <winston.smith@recdep.minitrue>', $subtest); 667 is($address->phrase(), 'Winston Smith', $subtest); 668 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 669 } 670 671 { 672 my $subtest = 'test method parse() in scalar context with more addresses'; 673 my $address = Email::Address::XS->parse('"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, user@oceania'); 674 ok(!$address->is_valid(), $subtest); 675 is($address->original(), '"Winston Smith" <winston.smith@recdep.minitrue>', $subtest); 676 is($address->phrase(), 'Winston Smith', $subtest); 677 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 678 } 679 680 { 681 my $subtest = 'test method parse() in scalar context with invalid, but parsable angle address'; 682 my $address = Email::Address::XS->parse('"Winston Smith" <winston.smith.@recdep.minitrue>'); 683 ok(!$address->is_valid(), $subtest); 684 is($address->original(), '"Winston Smith" <winston.smith.@recdep.minitrue>', $subtest); 685 is($address->phrase(), 'Winston Smith', $subtest); 686 is($address->user(), 'winston.smith.', $subtest); 687 is($address->host(), 'recdep.minitrue', $subtest); 688 is($address->address(), '"winston.smith."@recdep.minitrue', $subtest); 689 } 690 691 { 692 my $subtest = 'test method parse() in scalar context with invalid, but parsable bare address'; 693 my $address = Email::Address::XS->parse('winston.smith.@recdep.minitrue'); 694 ok(!$address->is_valid(), $subtest); 695 is($address->original(), 'winston.smith.@recdep.minitrue', $subtest); 696 is($address->user(), 'winston.smith.', $subtest); 697 is($address->host(), 'recdep.minitrue', $subtest); 698 is($address->address(), '"winston.smith."@recdep.minitrue', $subtest); 699 } 700 701} 702 703######################### 704 705{ 706 707 { 708 my $subtest = 'test method parse_bare_address() without argument'; 709 my $address = with_warning { Email::Address::XS->parse_bare_address() }; 710 ok(!$address->is_valid(), $subtest); 711 is($address->original(), undef, $subtest); 712 is($address->address(), undef, $subtest); 713 } 714 715 { 716 my $subtest = 'test method parse_bare_address() with undef argument'; 717 my $address = with_warning { Email::Address::XS->parse_bare_address(undef) }; 718 ok(!$address->is_valid(), $subtest); 719 is($address->original(), undef, $subtest); 720 is($address->address(), undef, $subtest); 721 } 722 723 { 724 my $subtest = 'test method parse_bare_address() on empty string'; 725 my $address = Email::Address::XS->parse_bare_address(''); 726 ok(!$address->is_valid(), $subtest); 727 is($address->original(), '', $subtest); 728 is($address->address(), undef, $subtest); 729 } 730 731 { 732 my $subtest = 'test method parse_bare_address() on invalid not parsable address'; 733 my $address = Email::Address::XS->parse_bare_address('invalid_line'); 734 ok(!$address->is_valid(), $subtest); 735 is($address->original(), 'invalid_line', $subtest); 736 is($address->address(), undef, $subtest); 737 } 738 739 { 740 my $subtest = 'test method parse_bare_address() on invalid input string - address with angle brackets'; 741 my $address = Email::Address::XS->parse_bare_address('<winston.smith@recdep.minitrue>'); 742 ok(!$address->is_valid(), $subtest); 743 is($address->original(), '<winston.smith@recdep.minitrue>', $subtest); 744 is($address->address(), undef, $subtest); 745 } 746 747 { 748 my $subtest = 'test method parse_bare_address() on invalid input string - phrase with address'; 749 my $address = Email::Address::XS->parse_bare_address('Winston Smith <winston.smith@recdep.minitrue>'); 750 ok(!$address->is_valid(), $subtest); 751 is($address->original(), 'Winston Smith <winston.smith@recdep.minitrue>', $subtest); 752 is($address->address(), undef, $subtest); 753 } 754 755 { 756 my $subtest = 'test method parse_bare_address() on invalid input string - two addresses'; 757 my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue, julia@ficdep.minitrue'); 758 ok(!$address->is_valid(), $subtest); 759 is($address->original(), 'winston.smith@recdep.minitrue, julia@ficdep.minitrue', $subtest); 760 is($address->address(), undef, $subtest); 761 } 762 763 { 764 my $subtest = 'test method parse_bare_address() on valid input string'; 765 my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue'); 766 ok($address->is_valid(), $subtest); 767 is($address->original(), 'winston.smith@recdep.minitrue', $subtest); 768 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 769 } 770 771 { 772 my $subtest = 'test method parse_bare_address() on valid input string with comment'; 773 my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue(comment)'); 774 ok($address->is_valid(), $subtest); 775 is($address->original(), 'winston.smith@recdep.minitrue(comment)', $subtest); 776 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 777 } 778 779 { 780 my $subtest = 'test method parse_bare_address() on valid input string with comment'; 781 my $address = Email::Address::XS->parse_bare_address('winston.smith@recdep.minitrue (comment)'); 782 ok($address->is_valid(), $subtest); 783 is($address->original(), 'winston.smith@recdep.minitrue (comment)', $subtest); 784 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 785 } 786 787 { 788 my $subtest = 'test method parse_bare_address() on valid input string with comment'; 789 my $address = Email::Address::XS->parse_bare_address('(comment)winston.smith@recdep.minitrue'); 790 ok($address->is_valid(), $subtest); 791 is($address->original(), '(comment)winston.smith@recdep.minitrue', $subtest); 792 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 793 } 794 795 { 796 my $subtest = 'test method parse_bare_address() on valid input string with comment'; 797 my $address = Email::Address::XS->parse_bare_address('(comment) winston.smith@recdep.minitrue'); 798 ok($address->is_valid(), $subtest); 799 is($address->original(), '(comment) winston.smith@recdep.minitrue', $subtest); 800 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 801 } 802 803 { 804 my $subtest = 'test method parse_bare_address() on valid input string with two comments'; 805 my $address = Email::Address::XS->parse_bare_address('(comment)winston.smith@recdep.minitrue(comment)'); 806 ok($address->is_valid(), $subtest); 807 is($address->original(), '(comment)winston.smith@recdep.minitrue(comment)', $subtest); 808 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 809 } 810 811 { 812 my $subtest = 'test method parse_bare_address() on valid input string with two comments'; 813 my $address = Email::Address::XS->parse_bare_address('(comment) winston.smith@recdep.minitrue (comment)'); 814 ok($address->is_valid(), $subtest); 815 is($address->original(), '(comment) winston.smith@recdep.minitrue (comment)', $subtest); 816 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 817 } 818 819 { 820 my $subtest = 'test method parse_bare_address() on valid input string with lot of comments'; 821 my $address = Email::Address::XS->parse_bare_address('(comm(e)nt) (co(m)ment) winston (comment) . smith@recdep.minitrue (c(o)mment) (comment)'); 822 ok($address->is_valid(), $subtest); 823 is($address->original(), '(comm(e)nt) (co(m)ment) winston (comment) . smith@recdep.minitrue (c(o)mment) (comment)', $subtest); 824 is($address->address(), 'winston.smith@recdep.minitrue', $subtest); 825 } 826 827} 828 829######################### 830 831{ 832 833 is( 834 format_email_addresses(), 835 '', 836 'test function format_email_addresses() with empty list of addresses', 837 ); 838 839 is( 840 with_warning { format_email_addresses('invalid string') }, 841 '', 842 'test function format_email_addresses() with invalid string argument', 843 ); 844 845 is( 846 format_email_addresses(Email::Address::XS::Derived->new(user => 'user', host => 'host')), 847 'user_derived_suffix@host', 848 'test function format_email_addresses() with derived object class', 849 ); 850 851 is( 852 with_warning { format_email_addresses(Email::Address::XS::NotDerived->new(user => 'user', host => 'host')) }, 853 '', 854 'test function format_email_addresses() with not derived object class', 855 ); 856 857 is( 858 with_warning { format_email_addresses(bless([], 'invalid_object_class')) }, 859 '', 860 'test function format_email_addresses() with invalid object class', 861 ); 862 863 is( 864 format_email_addresses( 865 Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), 866 Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), 867 Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'), 868 Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania'), 869 Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'), 870 Email::Address::XS->new(address => 'user@oceania'), 871 Email::Address::XS->new(phrase => 'Escape " also , characters ;', address => 'user2@oceania'), 872 Email::Address::XS->new(phrase => 'user5@oceania" <user6@oceania> , "', address => 'user4@oceania'), 873 Email::Address::XS->new(user => '.user7', host => 'oceania'), 874 Email::Address::XS->new(user => 'user8.', host => 'oceania'), 875 Email::Address::XS->new(phrase => '"', address => 'user9@oceania'), 876 Email::Address::XS->new(phrase => "Mr. '", address => 'user10@oceania'), 877 ), 878 q("Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, O'Brien <o'brien@thought.police.oceania>, "Mr. Charrington" <"charrington\"@\"shop"@thought.police.oceania>, "Emmanuel Goldstein" <goldstein@brotherhood.oceania>, user@oceania, "Escape \" also , characters ;" <user2@oceania>, "user5@oceania\" <user6@oceania> , \"" <user4@oceania>, ".user7"@oceania, "user8."@oceania, "\"" <user9@oceania>, "Mr. '" <user10@oceania>), 879 'test function format_email_addresses() with list of different type of addresses', 880 ); 881 882} 883 884######################### 885 886{ 887 888 is_deeply( 889 [ with_warning { parse_email_addresses(undef) } ], 890 [], 891 'test function parse_email_addresses() with undef argument', 892 ); 893 894 is_deeply( 895 [ parse_email_addresses('') ], 896 [], 897 'test function parse_email_addresses() on empty string', 898 ); 899 900 is_deeply( 901 [ parse_email_addresses('incorrect') ], 902 [ Email::Address::XS->new(phrase => 'incorrect') ], 903 'test function parse_email_addresses() on incorrect string', 904 ); 905 906 is_deeply( 907 [ parse_email_addresses('Winston Smith <winston.smith@recdep.minitrue>') ], 908 [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], 909 'test function parse_email_addresses() on string with unquoted phrase', 910 ); 911 912 is_deeply( 913 [ parse_email_addresses('"Winston Smith" <winston.smith@recdep.minitrue>') ], 914 [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], 915 'test function parse_email_addresses() on string with quoted phrase', 916 ); 917 918 is_deeply( 919 [ parse_email_addresses('"Winston Smith" "suffix" suffix2 <winston.smith@recdep.minitrue>') ], 920 [ Email::Address::XS->new(phrase => 'Winston Smith suffix suffix2', address => 'winston.smith@recdep.minitrue') ], 921 'test function parse_email_addresses() on string with more words in phrase', 922 ); 923 924 is_deeply( 925 [ parse_email_addresses('winston.smith@recdep.minitrue') ], 926 [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue') ], 927 'test function parse_email_addresses() on string with just address', 928 ); 929 930 is_deeply( 931 [ parse_email_addresses('winston.smith@recdep.minitrue (Winston Smith)') ], 932 [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue', comment => 'Winston Smith') ], 933 'test function parse_email_addresses() on string with comment after address', 934 ); 935 936 is_deeply( 937 [ parse_email_addresses('<winston.smith@recdep.minitrue>') ], 938 [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue') ], 939 'test function parse_email_addresses() on string with just address in angle brackets', 940 ); 941 942 is_deeply( 943 [ parse_email_addresses('"user@oceania" : winston.smith@recdep.minitrue') ], 944 [ Email::Address::XS->new(address => 'winston.smith@recdep.minitrue') ], 945 'test function parse_email_addresses() on string with character @ inside group name', 946 ); 947 948 is_deeply( 949 [ parse_email_addresses('"user@oceania" <winston.smith@recdep.minitrue>') ], 950 [ Email::Address::XS->new(phrase => 'user@oceania', address => 'winston.smith@recdep.minitrue') ], 951 'test function parse_email_addresses() on string with character @ inside phrase', 952 ); 953 954 is_deeply( 955 [ parse_email_addresses('"User <user@oceania>" <winston.smith@recdep.minitrue>') ], 956 [ Email::Address::XS->new(phrase => 'User <user@oceania>', address => 'winston.smith@recdep.minitrue') ], 957 'test function parse_email_addresses() on string with email address inside phrase', 958 ); 959 960 is_deeply( 961 [ parse_email_addresses('"julia@outer\\"party"@ficdep.minitrue') ], 962 [ Email::Address::XS->new(user => 'julia@outer"party', host => 'ficdep.minitrue') ], 963 'test function parse_email_addresses() on string with quoted and escaped mailbox part of address', 964 ); 965 966 is_deeply( 967 [ parse_email_addresses('"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>') ], 968 [ 969 Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), 970 Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), 971 ], 972 'test function parse_email_addresses() on string with two items', 973 ); 974 975 is_deeply( 976 [ parse_email_addresses('"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, user@oceania') ], 977 [ 978 Email::Address::XS->new('Winston Smith', 'winston.smith@recdep.minitrue'), 979 Email::Address::XS->new('Julia', 'julia@ficdep.minitrue'), Email::Address::XS->new(address => 'user@oceania'), 980 ], 981 'test function parse_email_addresses() on string with three items', 982 ); 983 984 is_deeply( 985 [ parse_email_addresses('(leading comment)"Winston (Smith)" <winston.smith@recdep.minitrue(.oceania)> (comment after), Julia (Unknown) <julia(outer party)@ficdep.minitrue> (additional comment)') ], 986 [ 987 Email::Address::XS->new(phrase => 'Winston (Smith)', address => 'winston.smith@recdep.minitrue', comment => 'comment after'), 988 Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue', comment => 'additional comment'), 989 ], 990 'test function parse_email_addresses() on string with a lots of comments', 991 ); 992 993 is_deeply( 994 [ parse_email_addresses('Winston Smith( <user@oceania>, Julia) <winston.smith@recdep.minitrue>') ], 995 [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], 996 'test function parse_email_addresses() on string with comma in comment', 997 ); 998 999 is_deeply( 1000 [ parse_email_addresses('"Winston Smith" ( <user@oceania>, (Julia) <julia(outer(.)party)@ficdep.minitrue>, ) <winston.smith@recdep.minitrue>' ) ], 1001 [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue') ], 1002 'test function parse_email_addresses() on string with nested comments', 1003 ); 1004 1005 is_deeply( 1006 [ parse_email_addresses('Winston Smith <winston .smith @ recdep(comment). minitrue>' ) ], 1007 [ Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue', comment => 'comment') ], 1008 'test function parse_email_addresses() on string with obsolate white spaces', 1009 ); 1010 1011 is_deeply( 1012 [ parse_email_addresses("\302\257\302\257`\302\267.\302\245\302\253P\302\256\303\216\303\221\303\247\342\202\254\303\230fTh\342\202\254\303\220\303\205\302\256K\302\273\302\245.\302\267`\302\257\302\257 <email\@example.com>, \"(> \\\" \\\" <) ( ='o'= ) (\\\")___(\\\") sWeEtAnGeLtHePrInCeSsOfThEsKy\" <email2\@example.com>, \"(i)cRiStIaN(i)\" <email3\@example.com>, \"(S)MaNu_vuOLeAmMazZaReNimOe(*)MiAo(\@)\" <email4\@example.com>\n") ], 1013 [ 1014 Email::Address::XS->new(phrase => "\302\257\302\257`\302\267.\302\245\302\253P\302\256\303\216\303\221\303\247\342\202\254\303\230fTh\342\202\254\303\220\303\205\302\256K\302\273\302\245.\302\267`\302\257\302\257", user => 'email', host => 'example.com'), 1015 Email::Address::XS->new(phrase => '(> " " <) ( =\'o\'= ) (")___(") sWeEtAnGeLtHePrInCeSsOfThEsKy', user => 'email2', host => 'example.com'), 1016 Email::Address::XS->new(phrase => '(i)cRiStIaN(i)', user => 'email3', host => 'example.com'), 1017 Email::Address::XS->new(phrase => '(S)MaNu_vuOLeAmMazZaReNimOe(*)MiAo(@)', user => 'email4', host => 'example.com'), 1018 ], 1019 'test function parse_email_addresses() on CVE-2015-7686 string', 1020 ); 1021 1022 is_deeply( 1023 [ parse_email_addresses('aaaa@') ], 1024 [ Email::Address::XS->new(user => 'aaaa') ], 1025 'test function parse_email_addresses() on CVE-2017-14461 string', 1026 ); 1027 1028 is_deeply( 1029 [ parse_email_addresses('a(aa') ], 1030 [ Email::Address::XS->new() ], 1031 'test function parse_email_addresses() on CVE-2017-14461 string', 1032 ); 1033 1034 is_deeply( 1035 [ parse_email_addresses('"Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>, O\'Brien <o\'brien@thought.police.oceania>, "Mr. Charrington" <"charrington\"@\"shop"@thought.police.oceania>, "Emmanuel Goldstein" <goldstein@brotherhood.oceania>, user@oceania, "Escape \" also , characters ;" <user2@oceania>, "user5@oceania\" <user6@oceania> , \"" <user4@oceania>') ], 1036 [ 1037 Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), 1038 Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), 1039 Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'), 1040 Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania'), 1041 Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'), 1042 Email::Address::XS->new(address => 'user@oceania'), 1043 Email::Address::XS->new(phrase => 'Escape " also , characters ;', address => 'user2@oceania'), 1044 Email::Address::XS->new(phrase => 'user5@oceania" <user6@oceania> , "', address => 'user4@oceania'), 1045 ], 1046 'test function parse_email_addresses() on string with lots of different types of addresses', 1047 ); 1048 1049 is_deeply( 1050 [ parse_email_addresses('winston.smith@recdep.minitrue', 'Email::Address::XS::Derived') ], 1051 [ bless({ phrase => undef, user => 'winston.smith', host => 'recdep.minitrue', comment => undef }, 'Email::Address::XS::Derived') ], 1052 'test function parse_email_addresses() with second derived class name argument', 1053 ); 1054 1055 is_deeply( 1056 [ with_warning { parse_email_addresses('winston.smith@recdep.minitrue', 'Email::Address::XS::NotDerived') } ], 1057 [], 1058 'test function parse_email_addresses() with second not derived class name argument', 1059 ); 1060 1061} 1062 1063######################### 1064 1065{ 1066 1067 my $winstons_address = Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'); 1068 my $julias_address = Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'); 1069 my $obriens_address = Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'); 1070 my $charringtons_address = Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania'); 1071 my $goldsteins_address = Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'); 1072 my $users_address = Email::Address::XS->new(address => 'user@oceania'); 1073 my $user2s_address = Email::Address::XS->new(phrase => 'Escape " also , characters', address => 'user2@oceania'); 1074 my $user3s_address = Email::Address::XS->new(address => 'user3@oceania'); 1075 my $user4s_address = Email::Address::XS->new(phrase => 'user5@oceania" <user6@oceania> , "', address => 'user4@oceania'); 1076 1077 my $winstons_mime_address = Email::Address::XS->new(phrase => '=?US-ASCII?Q?Winston?= Smith', address => 'winston.smith@recdep.minitrue'); 1078 my $julias_mime_address = Email::Address::XS->new(phrase => '=?US-ASCII?Q?Julia?=', address => 'julia@ficdep.minitrue'); 1079 1080 my $derived_object = Email::Address::XS::Derived->new(user => 'user', host => 'host'); 1081 my $not_derived_object = Email::Address::XS::NotDerived->new(user => 'user', host => 'host'); 1082 1083 my $nameless_group = ''; 1084 my $brotherhood_group = 'Brotherhood'; 1085 my $minitrue_group = 'Ministry of "Truth"'; 1086 my $thoughtpolice_group = 'Thought Police'; 1087 my $users_group = 'users@oceania'; 1088 my $undisclosed_group = 'undisclosed-recipients'; 1089 my $mime_group = '=?US-ASCII?Q?MIME?='; 1090 1091 is( 1092 with_warning { format_email_groups('first', 'second', 'third') }, 1093 undef, 1094 'test function format_email_groups() with odd number of arguments', 1095 ); 1096 1097 is( 1098 with_warning { format_email_groups('name', undef) }, 1099 'name:;', 1100 'test function format_email_groups() with invalid type second argument (undef)', 1101 ); 1102 1103 is( 1104 with_warning { format_email_groups('name', 'string') }, 1105 'name:;', 1106 'test function format_email_groups() with invalid type second argument (string)', 1107 ); 1108 1109 is( 1110 format_email_groups(), 1111 '', 1112 'test function format_email_groups() with empty list of groups', 1113 ); 1114 1115 is( 1116 format_email_groups(undef() => []), 1117 '', 1118 'test function format_email_groups() with empty list of addresses in one undef group', 1119 ); 1120 1121 is( 1122 format_email_groups(undef() => [ $users_address ]), 1123 'user@oceania', 1124 'test function format_email_groups() with one email address in undef group', 1125 ); 1126 1127 is( 1128 format_email_groups($nameless_group => [ $users_address ]), 1129 '"": user@oceania;', 1130 'test function format_email_groups() with one email address in nameless group', 1131 ); 1132 1133 is( 1134 format_email_groups($undisclosed_group => []), 1135 'undisclosed-recipients:;', 1136 'test function format_email_groups() with empty list of addresses in one named group', 1137 ); 1138 1139 is( 1140 format_email_groups(undef() => [ $derived_object ]), 1141 'user_derived_suffix@host', 1142 'test function format_email_groups() with derived object class', 1143 ); 1144 1145 is( 1146 with_warning { format_email_groups(undef() => [ $not_derived_object ]) }, 1147 '', 1148 'test function format_email_groups() with not derived object class', 1149 ); 1150 1151 is( 1152 format_email_groups($brotherhood_group => [ $winstons_address, $julias_address ]), 1153 'Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;', 1154 'test function format_email_groups() with two addresses in one named group', 1155 ); 1156 1157 is( 1158 format_email_groups( 1159 $brotherhood_group => [ $winstons_address, $julias_address ], 1160 undef() => [ $users_address ] 1161 ), 1162 'Brotherhood: "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, user@oceania', 1163 'test function format_email_groups() with addresses in two groups', 1164 ); 1165 1166 is( 1167 format_email_groups( 1168 $mime_group => [ $winstons_mime_address, $julias_mime_address ], 1169 ), 1170 '=?US-ASCII?Q?MIME?=: =?US-ASCII?Q?Winston?= Smith <winston.smith@recdep.minitrue>, =?US-ASCII?Q?Julia?= <julia@ficdep.minitrue>;', 1171 'test function format_email_groups() that does not quote MIME encoded strings', 1172 ); 1173 1174 is( 1175 format_email_groups("\x{2764} \x{2600}" => [ Email::Address::XS->new(phrase => "\x{2606} \x{2602}", user => "\x{263b} \x{265e}", host => "\x{262f}.\x{262d}", comment => "\x{2622} \x{20ac}") ]), 1176 "\"\x{2764} \x{2600}\": \"\x{2606} \x{2602}\" <\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}> (\x{2622} \x{20ac});", 1177 'test function format_email_groups() that preserves unicode characters and UTF-8 status flag', 1178 ); 1179 1180 is( 1181 format_email_groups("ASCII" => [], "L\x{e1}tin1" => []), 1182 "ASCII:;, L\x{e1}tin1:;", 1183 'test function format_email_groups() that correctly compose Latin1 string from ASCII and Latin1 parts', 1184 ); 1185 1186 is( 1187 format_email_groups("ASCII" => [ Email::Address::XS->new(user => "L\x{e1}tin1", host => "L\x{e1}tin1") ]), 1188 "ASCII: L\x{e1}tin1\@L\x{e1}tin1;", 1189 'test function format_email_groups() that correctly compose Latin1 string from Latin1 parts', 1190 ); 1191 1192 is( 1193 format_email_groups("ASCII" => [ Email::Address::XS->new(user => "L\x{e1}tin1", host => "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}") ]), 1194 "ASCII: L\x{e1}tin1\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404};", 1195 'test function format_email_groups() that correctly compose UNICODE string from ASCII, Latin1 and UNICODE parts', 1196 ); 1197 1198 is( 1199 format_email_groups( 1200 $minitrue_group => [ $winstons_address, $julias_address ], 1201 $thoughtpolice_group => [ $obriens_address, $charringtons_address ], 1202 undef() => [ $users_address, $user2s_address ], 1203 $undisclosed_group => [], 1204 undef() => [ $user3s_address ], 1205 $brotherhood_group => [ $goldsteins_address ], 1206 $users_group => [ $user4s_address ], 1207 ), 1208 '"Ministry of \\"Truth\\"": "Winston Smith" <winston.smith@recdep.minitrue>, Julia <julia@ficdep.minitrue>;, "Thought Police": O\'Brien <o\'brien@thought.police.oceania>, "Mr. Charrington" <"charrington\\"@\\"shop"@thought.police.oceania>;, user@oceania, "Escape \" also , characters" <user2@oceania>, undisclosed-recipients:;, user3@oceania, Brotherhood: "Emmanuel Goldstein" <goldstein@brotherhood.oceania>;, "users@oceania": "user5@oceania\\" <user6@oceania> , \\"" <user4@oceania>;', 1209 'test function format_email_groups() with different type of addresses in more groups', 1210 ); 1211 1212} 1213 1214######################### 1215 1216{ 1217 tie my $str1, 'TieScalarCounter', 'str1'; 1218 tie my $str2, 'TieScalarCounter', 'str2'; 1219 tie my $str3, 'TieScalarCounter', 'str3'; 1220 tie my $str4, 'TieScalarCounter', 'str4'; 1221 tie my $str5, 'TieScalarCounter', undef; 1222 my $list1 = [ Email::Address::XS->new(), Email::Address::XS->new() ]; 1223 my $list2 = [ Email::Address::XS->new(), Email::Address::XS->new() ]; 1224 my $list3 = [ Email::Address::XS->new() ]; 1225 my $list4 = [ Email::Address::XS->new() ]; 1226 tie $list1->[0]->{user}, 'TieScalarCounter', 'ASCII'; 1227 tie $list1->[0]->{host}, 'TieScalarCounter', 'ASCII'; 1228 tie $list1->[0]->{phrase}, 'TieScalarCounter', 'ASCII'; 1229 tie $list1->[0]->{comment}, 'TieScalarCounter', 'ASCII'; 1230 tie $list1->[1]->{user}, 'TieScalarCounter', 'ASCII'; 1231 tie $list1->[1]->{host}, 'TieScalarCounter', "L\x{e1}tin1"; 1232 tie $list1->[1]->{phrase}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1233 tie $list1->[1]->{comment}, 'TieScalarCounter', 'ASCII'; 1234 tie $list2->[0]->{user}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1235 tie $list2->[0]->{host}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1236 tie $list2->[0]->{phrase}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1237 tie $list2->[0]->{comment}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1238 tie $list2->[1]->{user}, 'TieScalarCounter', "L\x{e1}tin1"; 1239 tie $list2->[1]->{host}, 'TieScalarCounter', "L\x{e1}tin1"; 1240 tie $list2->[1]->{phrase}, 'TieScalarCounter', "L\x{e1}tin1"; 1241 tie $list2->[1]->{comment}, 'TieScalarCounter', "L\x{e1}tin1"; 1242 tie $list3->[0]->{user}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1243 tie $list3->[0]->{host}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1244 tie $list3->[0]->{phrase}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1245 tie $list3->[0]->{comment}, 'TieScalarCounter', "\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}"; 1246 tie $list4->[0]->{user}, 'TieScalarCounter', "L\x{e1}tin1"; 1247 tie $list4->[0]->{host}, 'TieScalarCounter', "L\x{e1}tin1"; 1248 tie $list4->[0]->{phrase}, 'TieScalarCounter', "L\x{e1}tin1"; 1249 tie $list4->[0]->{comment}, 'TieScalarCounter', "L\x{e1}tin1"; 1250 is( 1251 format_email_groups($str1 => $list1, $str2 => $list2), 1252 "str1: ASCII <ASCII\@ASCII> (ASCII), \x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404} <ASCII\@L\x{e1}tin1> (ASCII);, str2: \x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404} <\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}> (\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}), L\x{e1}tin1 <L\x{e1}tin1\@L\x{e1}tin1> (L\x{e1}tin1);", 1253 'test function format_email_groups() with magic scalars in ASCII, Latin1 and UNICODE', 1254 ); 1255 is( 1256 format_email_groups($str3 => $list3), 1257 "str3: \x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404} <\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}\@\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404}> (\x{1d414}\x{1d40d}\x{1d408}\x{1d402}\x{1d40e}\x{1d403}\x{1d404});", 1258 'test function format_email_groups() with magic scalars in UNICODE', 1259 ); 1260 is( 1261 format_email_groups($str4 => $list4), 1262 "str4: L\x{e1}tin1 <L\x{e1}tin1\@L\x{e1}tin1> (L\x{e1}tin1);", 1263 'test function format_email_groups() with magic scalars in Latin1', 1264 ); 1265 is( 1266 format_email_groups($str5 => []), 1267 '', 1268 'test function format_email_groups() with magic scalar which is undef', 1269 ); 1270 is(tied($str1)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1271 is(tied($str2)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1272 is(tied($str3)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1273 is(tied($str4)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1274 is(tied($str1)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1275 is(tied($str2)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1276 is(tied($str3)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1277 is(tied($str4)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1278 is(tied($str5)->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1279 is(tied($str5)->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1280 foreach ( @{$list1}, @{$list2}, @{$list3}, @{$list4} ) { 1281 is(tied($_->{user})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1282 is(tied($_->{host})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1283 is(tied($_->{phrase})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1284 is(tied($_->{comment})->{fetch}, 1, 'test function format_email_groups() that called GET magic exacly once'); 1285 is(tied($_->{user})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1286 is(tied($_->{host})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1287 is(tied($_->{phrase})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1288 is(tied($_->{comment})->{store}, 0, 'test function format_email_groups() that did not call SET magic'); 1289 } 1290} 1291 1292######################### 1293 1294{ 1295 1296 is_deeply( 1297 [ with_warning { parse_email_groups(undef) } ], 1298 [], 1299 'test function parse_email_groups() with undef argument', 1300 ); 1301 1302 is_deeply( 1303 [ parse_email_groups('') ], 1304 [], 1305 'test function parse_email_groups() on empty string', 1306 ); 1307 1308 is_deeply( 1309 [ parse_email_groups('incorrect') ], 1310 [ 1311 undef() => [ 1312 Email::Address::XS->new(phrase => 'incorrect'), 1313 ], 1314 ], 1315 'test function parse_email_groups() on incorrect string', 1316 ); 1317 1318 is_deeply( 1319 [ parse_email_groups('winston.smith@recdep.minitrue', 'Email::Address::XS::Derived') ], 1320 [ 1321 undef() => [ 1322 bless({ phrase => undef, user => 'winston.smith', host => 'recdep.minitrue', comment => undef }, 'Email::Address::XS::Derived'), 1323 ], 1324 ], 1325 'test function parse_email_groups() with second derived class name argument', 1326 ); 1327 1328 is_deeply( 1329 [ with_warning { parse_email_groups('winston.smith@recdep.minitrue', 'Email::Address::XS::NotDerived') } ], 1330 [], 1331 'test function parse_email_groups() with second not derived class name argument', 1332 ); 1333 1334 is_deeply( 1335 [ parse_email_groups('=?US-ASCII?Q?MIME=3A=3B?= : =?US-ASCII?Q?Winston=3A_Smith?= <winston.smith@recdep.minitrue>, =?US-ASCII?Q?Julia=3A=3B_?= <julia@ficdep.minitrue> ;') ], 1336 [ 1337 '=?US-ASCII?Q?MIME=3A=3B?=' => [ 1338 Email::Address::XS->new(phrase => '=?US-ASCII?Q?Winston=3A_Smith?=', address => 'winston.smith@recdep.minitrue'), 1339 Email::Address::XS->new(phrase => '=?US-ASCII?Q?Julia=3A=3B_?=', address => 'julia@ficdep.minitrue'), 1340 ], 1341 ], 1342 'test function parse_email_groups() on MIME string with encoded colons and semicolons', 1343 ); 1344 1345 is_deeply( 1346 [ parse_email_groups("\"\x{2764} \x{2600}\": \"\x{2606} \x{2602}\" <\"\x{263b} \x{265e}\"\@\x{262f}.\x{262d}> (\x{2622} \x{20ac});") ], 1347 [ "\x{2764} \x{2600}" => [ Email::Address::XS->new(phrase => "\x{2606} \x{2602}", user => "\x{263b} \x{265e}", host => "\x{262f}.\x{262d}", comment => "\x{2622} \x{20ac}") ] ], 1348 'test function parse_email_groups() that preserve unicode characters and UTF-8 status flag', 1349 ); 1350 1351 is_deeply( 1352 [ parse_email_groups('"Ministry of \\"Truth\\"": "Winston Smith" ( <user@oceania>, (Julia _ (Unknown)) <julia_(outer(.)party)@ficdep.minitrue>, ) <winston.smith@recdep.minitrue>, (leading comment) Julia <julia@ficdep.minitrue>;, "Thought Police" (group name comment) : O\'Brien <o\'brien@thought.police.oceania>, Mr. (c)Charrington <(mr.)"charrington\\"@\\"shop"@thought.police.oceania> (junk shop);, user@oceania (unknown_display_name in comment), "Escape \" also , characters" <user2@oceania>, undisclosed-recipients:;, user3@oceania (nested (comment)), Brotherhood(s):"Emmanuel Goldstein"<goldstein@brotherhood.oceania>; , "users@oceania" : "user5@oceania\\" <user6@oceania> , \\"" <user4@oceania>;, "":;' ) ], 1353 [ 1354 'Ministry of "Truth"' => [ 1355 Email::Address::XS->new(phrase => 'Winston Smith', address => 'winston.smith@recdep.minitrue'), 1356 Email::Address::XS->new(phrase => 'Julia', address => 'julia@ficdep.minitrue'), 1357 ], 1358 'Thought Police' => [ 1359 Email::Address::XS->new(phrase => "O'Brien", user => "o'brien", host => 'thought.police.oceania'), 1360 Email::Address::XS->new(phrase => 'Mr. Charrington', user => 'charrington"@"shop', host => 'thought.police.oceania', comment => 'junk shop'), 1361 ], 1362 undef() => [ 1363 Email::Address::XS->new(address => 'user@oceania', comment => 'unknown_display_name in comment'), 1364 Email::Address::XS->new(phrase => 'Escape " also , characters', address => 'user2@oceania'), 1365 ], 1366 'undisclosed-recipients' => [], 1367 undef() => [ 1368 Email::Address::XS->new(address => 'user3@oceania', comment => 'nested (comment)'), 1369 ], 1370 Brotherhood => [ 1371 Email::Address::XS->new(phrase => 'Emmanuel Goldstein', address => 'goldstein@brotherhood.oceania'), 1372 ], 1373 'users@oceania' => [ 1374 Email::Address::XS->new(phrase => 'user5@oceania" <user6@oceania> , "', address => 'user4@oceania'), 1375 ], 1376 "" => [], 1377 ], 1378 'test function parse_email_groups() on string with nested comments and quoted characters', 1379 ); 1380 1381} 1382 1383######################### 1384 1385{ 1386 is_deeply( 1387 [ parse_email_groups("\"string1\\\x00string2\"") ], 1388 [ undef() => [ Email::Address::XS->new(phrase => "string1\x00string2") ] ], 1389 'test function parse_email_groups() on string with nul character', 1390 ); 1391 is_deeply( 1392 [ parse_email_groups("\"\\\x00string1\\\x00string2\"") ], 1393 [ undef() => [ Email::Address::XS->new(phrase => "\x00string1\x00string2") ] ], 1394 'test function parse_email_groups() on string which begins with nul character', 1395 ); 1396 is_deeply( 1397 [ parse_email_groups("\"string1\\\x00string2\\\x00\"") ], 1398 [ undef() => [ Email::Address::XS->new(phrase => "string1\x00string2\x00") ] ], 1399 'test function parse_email_groups() on string which ends with nul character', 1400 ); 1401 is_deeply( 1402 [ parse_email_groups(qq("\\\t" <"\\\t"\@host>)) ], 1403 [ undef() => [ Email::Address::XS->new(phrase => "\t", user => "\t", host => 'host') ] ], 1404 'test function parse_email_groups() on string with TAB characters', 1405 ); 1406 is( 1407 format_email_groups(undef() => [ Email::Address::XS->new(phrase => "string1\x00string2", user => 'user', host => 'host') ]), 1408 "\"string1\\\x00string2\" <user\@host>", 1409 'test function format_email_groups() with nul character in phrase', 1410 ); 1411 is( 1412 format_email_groups(undef() => [ Email::Address::XS->new(phrase => "\x00string1\x00string2\x00", user => 'user', host => 'host') ]), 1413 "\"\\\x00string1\\\x00string2\\\x00\" <user\@host>", 1414 'test function format_email_groups() with nul character in phrase', 1415 ); 1416 is( 1417 format_email_groups(undef() => [ Email::Address::XS->new(user => "string1\x00string2", host => 'host') ]), 1418 "\"string1\\\x00string2\"\@host", 1419 'test function format_email_groups() with nul character in user part of address', 1420 ); 1421 is( 1422 format_email_groups(undef() => [ Email::Address::XS->new(user => "\x00string1\x00string2\x00", host => 'host') ]), 1423 "\"\\\x00string1\\\x00string2\\\x00\"\@host", 1424 'test function format_email_groups() with nul character in user part of address', 1425 ); 1426 is( 1427 with_warning { format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => "string1\x00string2") ]) }, 1428 '', 1429 'test function format_email_groups() with nul character in host part of address', 1430 ); 1431 is( 1432 with_warning { format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => "\x00string1\x00string2\x00") ]) }, 1433 '', 1434 'test function format_email_groups() with nul character in host part of address', 1435 ); 1436 is( 1437 format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => 'host', comment => "string1\\\x00string2") ]), 1438 "user\@host (string1\\\x00string2)", 1439 'test function format_email_groups() with nul character in comment', 1440 ); 1441 is( 1442 format_email_groups(undef() => [ Email::Address::XS->new(user => 'user', host => 'host', comment => "\\\x00string1\\\x00string2\\\x00") ]), 1443 "user\@host (\\\x00string1\\\x00string2\\\x00)", 1444 'test function format_email_groups() with nul character in comment', 1445 ); 1446 is( 1447 format_email_groups(undef() => [ Email::Address::XS->new(user => qq("\\\x00\t\n\r), host => 'host') ]), 1448 qq("\\"\\\\\\\x00\\\t\\\n\\\r"\@host), 1449 'test function format_email_groups() with lot of non-qtext characters in user part of address' 1450 ); 1451} 1452 1453######################### 1454 1455{ 1456 tie my $input, 'TieScalarCounter', 'winston.smith@recdep.minitrue'; 1457 is_deeply( 1458 [ parse_email_groups($input) ], 1459 [ 1460 undef() => [ 1461 bless({ phrase => undef, user => 'winston.smith', host => 'recdep.minitrue', comment => undef }, 'Email::Address::XS::Derived'), 1462 ], 1463 ], 1464 'test function parse_email_groups() with magic scalar', 1465 ); 1466 is(tied($input)->{fetch}, 1, 'test function parse_email_groups() that called GET magic exacly once'); 1467 is(tied($input)->{store}, 0, 'test function parse_email_groups() that did not call SET magic'); 1468} 1469 1470######################### 1471 1472{ 1473 1474 my $undef = undef; 1475 my $str = 'str'; 1476 my $str_ref = \$str; 1477 my $address = Email::Address::XS->new(); 1478 my $address_ref = \$address; 1479 my $derived = Email::Address::XS::Derived->new(); 1480 my $not_derived = Email::Address::XS::NotDerived->new(); 1481 1482 ok(!Email::Address::XS->is_obj(undef), 'test method is_obj() on undef'); 1483 ok(!Email::Address::XS->is_obj('string'), 'test method is_obj() on string'); 1484 ok(!Email::Address::XS->is_obj($undef), 'test method is_obj() on undef variable'); 1485 ok(!Email::Address::XS->is_obj($str), 'test method is_obj() on string variable'); 1486 ok(!Email::Address::XS->is_obj($str_ref), 'test method is_obj() on string reference'); 1487 ok(Email::Address::XS->is_obj($address), 'test method is_obj() on Email::Address::XS object'); 1488 ok(!Email::Address::XS->is_obj($address_ref), 'test method is_obj() on reference of Email::Address::XS object'); 1489 ok(Email::Address::XS->is_obj($derived), 'test method is_obj() on Email::Address::XS derived object'); 1490 ok(!Email::Address::XS->is_obj($not_derived), 'test method is_obj() on Email::Address::XS not derived object'); 1491 1492} 1493 1494######################### 1495 1496package Email::Address::XS::Derived; 1497 1498use base 'Email::Address::XS'; 1499 1500sub user { 1501 my ($self, @args) = @_; 1502 $args[0] .= "_derived_suffix" if @args and defined $args[0]; 1503 return $self->SUPER::user(@args); 1504} 1505 1506package Email::Address::XS::NotDerived; 1507 1508sub new { 1509 return bless {}; 1510} 1511 1512sub user { 1513 return 'not_derived'; 1514} 1515 1516######################### 1517 1518package TieScalarCounter; 1519 1520sub TIESCALAR { 1521 my ($class, $value) = @_; 1522 return bless { fetch => 0, store => 0, value => $value }, $class; 1523} 1524 1525sub FETCH { 1526 my ($self) = @_; 1527 $self->{fetch}++; 1528 return $self->{value}; 1529} 1530 1531sub STORE { 1532 my ($self, $value) = @_; 1533 $self->{store}++; 1534 $self->{value} = $value; 1535} 1536