1## Domain Registry Interface, Misc. useful functions 2## 3## Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek <netdri@dotandco.com>. All rights reserved. 4## 5## This file is part of Net::DRI 6## 7## Net::DRI is free software; you can redistribute it and/or modify 8## it under the terms of the GNU General Public License as published by 9## the Free Software Foundation; either version 2 of the License, or 10## (at your option) any later version. 11## 12## See the LICENSE file that comes with this distribution for more details. 13# 14# 15# 16######################################################################################### 17 18package Net::DRI::Util; 19 20use strict; 21use warnings; 22 23use Time::HiRes (); 24use Encode (); 25use Net::DRI::Exception; 26 27our $VERSION=do { my @r=(q$Revision: 1.20 $=~/\d+/g); sprintf("%d".".%02d" x $#r, @r); }; 28 29=pod 30 31=head1 NAME 32 33Net::DRI::Util - Various useful functions for Net::DRI operations 34 35=head1 DESCRIPTION 36 37Please see the README file for details. 38 39=head1 SUPPORT 40 41For now, support questions should be sent to: 42 43E<lt>netdri@dotandco.comE<gt> 44 45Please also see the SUPPORT file in the distribution. 46 47=head1 SEE ALSO 48 49E<lt>http://www.dotandco.com/services/software/Net-DRI/E<gt> 50 51=head1 AUTHOR 52 53Patrick Mevzek, E<lt>netdri@dotandco.comE<gt> 54 55=head1 COPYRIGHT 56 57Copyright (c) 2005,2006,2007,2008,2009 Patrick Mevzek <netdri@dotandco.com>. 58All rights reserved. 59 60This program is free software; you can redistribute it and/or modify 61it under the terms of the GNU General Public License as published by 62the Free Software Foundation; either version 2 of the License, or 63(at your option) any later version. 64 65See the LICENSE file that comes with this distribution for more details. 66 67=cut 68 69 70#################################################################################################### 71 72our %CCA2=map { $_ => 1 } qw/AF AX AL DZ AS AD AO AI AQ AG AR AM AW AU AT AZ BS BH BD BB BY BE BZ BJ BM BT BO BA BW BV BR IO BN BG BF BI KH CM CA CV KY CF TD CL CN CX CC CO KM CG CD CK CR CI HR CU CY CZ DK DJ DM DO EC EG SV GQ ER EE ET FK FO FJ FI FR GF PF TF GA GM GE DE GH GI GR GL GD GP GU GT GG GN GW GY HT HM HN HK HU IS IN ID IR IQ IE IM IL IT JM JP JE JO KZ KE KI KP KR KW KG LA LV LB LS LR LY LI LT LU MO MK MG MW MY MV ML MT MH MQ MR MU YT MX FM MD MC MN MS MA MZ MM NA NR NP NL AN NC NZ NI NE NG NU NF MP NO OM PK PW PS PA PG PY PE PH PN PL PT PR QA RE RO RU RW SH KN LC PM VC WS SM ST SA SN CS SC SL SG SK SI SB SO ZA GS ES LK SD SR SJ SZ SE CH SY TW TJ TZ TH TL TG TK TO TT TN TR TM TC TV UG UA AE GB US UM UY UZ VU VA VE VN VG VI WF EH YE ZM ZW/; 73 74sub all_valid 75{ 76 foreach (@_) 77 { 78 return 0 unless (defined($_) && (ref($_) || length($_))); 79 } 80 return 1; 81} 82 83sub hash_merge 84{ 85 my ($rmaster,$rtoadd)=@_; 86 while(my ($k,$v)=each(%$rtoadd)) 87 { 88 $rmaster->{$k}={} unless exists($rmaster->{$k}); 89 while(my ($kk,$vv)=each(%$v)) 90 { 91 $rmaster->{$k}->{$kk}=[] unless exists($rmaster->{$k}->{$kk}); 92 my @t=@$vv; 93 push @{$rmaster->{$k}->{$kk}},\@t; 94 } 95 } 96} 97 98sub deepcopy 99{ 100 my $in=shift; 101 return $in unless defined $in; 102 my $ref=ref $in; 103 return $in unless $ref; 104 my $cname; 105 ($cname,$ref)=($1,$2) if ("$in"=~m/^(\S+)=([A-Z]+)\(0x/); 106 107 if ($ref eq 'SCALAR') 108 { 109 my $tmp=$$in; 110 return \$tmp; 111 } elsif ($ref eq 'HASH') 112 { 113 my $r={ map { $_ => (defined $in->{$_} && ref $in->{$_}) ? deepcopy($in->{$_}) : $in->{$_} } keys(%$in) }; 114 bless($r,$cname) if defined $cname; 115 return $r; 116 } elsif ($ref eq 'ARRAY') 117 { 118 return [ map { (defined $_ && ref $_)? deepcopy($_) : $_ } @$in ]; 119 } else 120 { 121 Net::DRI::Exception::usererr_invalid_parameters('Do not know how to deepcopy '.$in); 122 } 123} 124 125#################################################################################################### 126 127sub isint 128{ 129 my $in=shift; 130 return ($in=~m/^\d+$/)? 1 : 0; 131} 132 133sub check_equal 134{ 135 my ($input,$ra,$default)=@_; 136 return $default unless defined($input); 137 foreach my $a (ref($ra)? @$ra : ($ra)) 138 { 139 return $a if ($a=~m/^${input}$/); 140 } 141 return $default if $default; 142 return; 143} 144 145sub check_isa 146{ 147 my ($what,$isa)=@_; 148 Net::DRI::Exception::usererr_invalid_parameters((${what} || 'parameter').' must be a '.$isa.' object') unless ($what && UNIVERSAL::isa($what,$isa)); 149 return 1; 150} 151 152sub isa_contactset 153{ 154 my $cs=shift; 155 return (defined($cs) && UNIVERSAL::isa($cs, 'Net::DRI::Data::ContactSet') && !$cs->is_empty())? 1 : 0; 156} 157 158sub isa_contact 159{ 160 my ($c,$class)=@_; 161 $class='Net::DRI::Data::Contact' unless defined($class); 162 return (defined($c) && UNIVERSAL::isa($c,$class))? 1 : 0; ## no way to check if it is empty or not ? Contact->validate() is too strong as it may die, Contact->roid() maybe not ok always 163} 164 165sub isa_hosts 166{ 167 my ($h,$emptyok)=@_; 168 $emptyok||=0; 169 return (defined($h) && UNIVERSAL::isa($h, 'Net::DRI::Data::Hosts') && ($emptyok || !$h->is_empty()) )? 1 : 0; 170} 171 172sub isa_nsgroup 173{ 174 my $h=shift; 175 return (defined($h) && UNIVERSAL::isa($h, 'Net::DRI::Data::Hosts'))? 1 : 0; 176} 177 178sub isa_changes 179{ 180 my $c=shift; 181 return (defined($c) && UNIVERSAL::isa($c, 'Net::DRI::Data::Changes') && !$c->is_empty())? 1 : 0; 182} 183 184sub isa_statuslist 185{ 186 my $s=shift; 187 return (defined($s) && UNIVERSAL::isa($s,'Net::DRI::Data::StatusList') && !$s->is_empty())? 1 : 0; 188} 189 190sub has_key 191{ 192 my ($rh,$key)=@_; 193 return 0 unless (defined($key) && $key); 194 return 0 unless (defined($rh) && (ref($rh) eq 'HASH') && exists($rh->{$key}) && defined($rh->{$key})); 195 return 1; 196} 197 198sub has_contact 199{ 200 my $rh=shift; 201 return has_key($rh,'contact') && isa_contactset($rh->{contact}); 202} 203 204sub has_ns 205{ 206 my $rh=shift; 207 return has_key($rh,'ns') && isa_hosts($rh->{ns}); 208} 209 210sub has_duration 211{ 212 my $rh=shift; 213 return has_key($rh,'duration') && check_isa($rh->{'duration'},'DateTime::Duration'); ## check_isa throws an Exception if not 214} 215 216sub has_auth 217{ 218 my $rh=shift; 219 return (has_key($rh,'auth') && (ref($rh->{'auth'}) eq 'HASH'))? 1 : 0; 220} 221 222#################################################################################################### 223 224sub microtime 225{ 226 my ($t,$v)=Time::HiRes::gettimeofday(); 227 return $t.sprintf('%06d',$v); 228} 229 230sub fulltime 231{ 232 my ($t,$v)=Time::HiRes::gettimeofday(); 233 my @t=localtime($t); 234 return sprintf('%d-%02d-%02d %02d:%02d:%02d.%06d',1900+$t[5],1+$t[4],$t[3],$t[2],$t[1],$t[0],$v); 235} 236 237## From EPP, trID=token from 3 to 64 characters 238sub create_trid_1 239{ 240 my ($name)=@_; 241 my $mt=microtime(); ## length=16 242 return uc($name).'-'.$$.'-'.$mt; 243} 244 245#################################################################################################### 246 247sub is_hostname ## RFC952/1123 248{ 249 my ($name)=@_; 250 return 0 unless defined($name); 251 252 my @d=split(/\./,$name,-1); 253 foreach my $d (@d) 254 { 255 return 0 unless (defined($d) && ($d ne '')); 256 return 0 unless (length($d)<=63); 257 return 0 if (($d=~m/[^A-Za-z0-9\-]/) || ($d=~m/^-/) || ($d=~m/-$/)); 258 } 259 return 1; 260} 261 262sub is_ipv4 263{ 264 my ($ip,$checkpublic)=@_; 265 266 return 0 unless defined($ip); 267 my (@ip)=($ip=~m/^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/); 268 return 0 unless (@ip==4); 269 foreach my $s (@ip) 270 { 271 return 0 unless (($s >= 0) && ($s <= 255)); 272 } 273 274 return 1 unless (defined($checkpublic) && $checkpublic); 275 276 ## Check if this IP is public (see RFC3330) 277 return 0 if ($ip[0] == 0); ## 0.x.x.x [ RFC 1700 ] 278 return 0 if ($ip[0] == 10); ## 10.x.x.x [ RFC 1918 ] 279 return 0 if ($ip[0] == 127); ## 127.x.x.x [ RFC 1700 ] 280 return 0 if (($ip[0] == 169) && ($ip[1]==254)); ## 169.254.0.0/16 link local 281 return 0 if (($ip[0] == 172 ) && ($ip[1]>=16) && ($ip[1]<=31)); ## 172.16.x.x to 172.31.x.x [ RFC 1918 ] 282 return 0 if (($ip[0] == 192 ) && ($ip[1]==0) && ($ip[2]==2)); ## 192.0.2.0/24 TEST-NET 283 return 0 if (($ip[0] == 192 ) && ($ip[1]==168)); ## 192.168.x.x [ RFC 1918 ] 284 return 0 if (($ip[0] >= 224) && ($ip[0] < 240 )); ## 224.0.0.0/4 Class D [ RFC 3171] 285 return 0 if ($ip[0] >= 240); ## 240.0.0.0/4 Class E [ RFC 1700 ] 286 return 1; 287} 288 289## Inspired by Net::IP which unfortunately requires Perl 5.8 290sub is_ipv6 291{ 292 my ($ip,$checkpublic)=@_; 293 return 0 unless defined($ip); 294 295 my (@ip)=split(/:/,$ip); 296 return 0 unless ((@ip > 0) && (@ip <= 8)); 297 return 0 if (($ip=~m/^:[^:]/) || ($ip=~m/[^:]:$/)); 298 return 0 if ($ip =~ s/:(?=:)//g > 1); 299 300 ## We do not allow IPv4 in IPv6 301 return 0 if grep { ! /^[a-f\d]{0,4}$/i } @ip; 302 303 return 1 unless (defined($checkpublic) && $checkpublic); 304 305 ## Check if this IP is public 306 my ($ip1,$ip2)=split(/::/,$ip); 307 $ip1=join('',map { sprintf('%04s',$_) } split(/:/,$ip1 || '')); 308 $ip2=join('',map { sprintf('%04s',$_) } split(/:/,$ip2 || '')); 309 my $wip=$ip1.('0' x (32-length($ip1)-length($ip2))).$ip2; ## 32 chars 310 my $bip=unpack('B128',pack('H32',$wip)); ## 128-bit array 311 312 ## RFC 3513 �2.4 313 return 0 if ($bip=~m/^0{127}/); ## unspecified + loopback 314 return 0 if ($bip=~m/^1{7}/); ## multicast + link-local unicast + site-local unicast 315 ## everything else is global unicast, 316 ## but see �4 and http://www.iana.org/assignments/ipv6-address-space 317 return 0 if ($bip=~m/^000/); ## unassigned + reserved (first 6 lines) 318 return 1 if ($bip=~m/^001/); ## global unicast (2000::/3) 319 return 0; ## everything else is unassigned 320} 321 322#################################################################################################### 323 324sub compare_durations 325{ 326 my ($dtd1,$dtd2)=@_; 327 328 ## from DateTime::Duration module, internally are stored: months, days, minutes, seconds and nanoseconds 329 ## those are the keys of the hash ref given by the deltas method 330 my %d1=$dtd1->deltas(); 331 my %d2=$dtd2->deltas(); 332 333 ## Not perfect, but should be enough for us 334 return (($d1{months} <=> $d2{months}) || 335 ($d1{days} <=> $d2{days}) || 336 ($d1{minutes} <=> $d2{minutes}) || 337 ($d1{seconds} <=> $d2{seconds}) 338 ); 339} 340 341#################################################################################################### 342 343sub xml_is_normalizedstring 344{ 345 my ($what,$min,$max)=@_; 346 347 return 0 unless defined($what); 348 return 0 if ($what=~m/[\r\n\t]/); 349 my $l=length($what); 350 return 0 if (defined($min) && ($l < $min)); 351 return 0 if (defined($max) && ($l > $max)); 352 return 1; 353} 354 355sub xml_is_token 356{ 357 my ($what,$min,$max)=@_; 358 359 return 0 unless defined($what); 360 return 0 if ($what=~m/[\r\n\t]/); 361 return 0 if ($what=~m/^\s/); 362 return 0 if ($what=~m/\s$/); 363 return 0 if ($what=~m/\s\s/); 364 365 my $l=length($what); 366 return 0 if (defined($min) && ($l < $min)); 367 return 0 if (defined($max) && ($l > $max)); 368 return 1; 369} 370 371sub xml_is_ncname ## xml:id is of this type 372{ 373 my ($what)=@_; 374 return 0 unless defined($what) && $what; 375 return ($what=~m/^\p{ID_Start}\p{ID_Continue}*$/) 376} 377 378sub verify_ushort { my $in=shift; return (defined($in) && ($in=~m/^\d+$/) && ($in < 65536))? 1 : 0; } 379sub verify_ubyte { my $in=shift; return (defined($in) && ($in=~m/^\d+$/) && ($in < 256))? 1 : 0; } 380sub verify_hex { my $in=shift; return (defined($in) && ($in=~m/^[0-9A-F]+$/i))? 1 : 0; } 381sub verify_int 382{ 383 my ($in,$min,$max)=@_; 384 return 0 unless defined($in) && ($in=~m/^-?\d+$/); 385 return 0 if ($in < (defined($min)? $min : -2147483648)); 386 return 0 if ($in > (defined($max)? $max : 2147483647)); 387 return 1; 388} 389 390sub verify_base64 391{ 392 my ($in,$min,$max)=@_; 393 my $b04='[AQgw]'; 394 my $b16='[AEIMQUYcgkosw048]'; 395 my $b64='[A-Za-z0-9+/]'; 396 return 0 unless ($in=~m/^(?:(?:$b64 ?$b64 ?$b64 ?$b64 ?)*(?:(?:$b64 ?$b64 ?$b64 ?$b64)|(?:$b64 ?$b64 ?$b16 ?=)|(?:$b64 ?$b04 ?= ?=)))?$/); 397 return 0 if (defined($min) && (length($in) < $min)); 398 return 0 if (defined($max) && (length($in) > $max)); 399 return 1; 400} 401 402## Same in XML and in RFC3066 403sub xml_is_language 404{ 405 my $in=shift; 406 return 0 unless defined($in); 407 return 1 if ($in=~m/^[a-zA-Z]{1,8}(?:-[a-zA-Z0-9]{1,8})*$/); 408 return 0; 409} 410 411sub xml_is_boolean 412{ 413 my $in=shift; 414 return 0 unless defined($in); 415 return 1 if ($in=~m/^(?:1|0|true|false)$/); 416 return 0; 417} 418 419sub xml_parse_boolean 420{ 421 my $in=shift; 422 return {'true'=>1,1=>1,0=>0,'false'=>0}->{$in}; 423} 424 425sub xml_escape 426{ 427 my ($in)=@_; 428 $in=~s/&/&/g; 429 $in=~s/</</g; 430 $in=~s/>/>/g; 431 return $in; 432} 433 434sub xml_write 435{ 436 my $rd=shift; 437 my @t; 438 foreach my $d ((ref($rd->[0]))? @$rd : ($rd)) ## $d is a node=ref array 439 { 440 my @c; ## list of children nodes 441 my %attr; 442 foreach my $e (grep { defined } @$d) 443 { 444 if (ref($e) eq 'HASH') 445 { 446 while(my ($k,$v)=each(%$e)) { $attr{$k}=$v; } 447 } else 448 { 449 push @c,$e; 450 } 451 } 452 my $tag=shift(@c); 453 my $attr=keys(%attr)? ' '.join(' ',map { $_.'="'.$attr{$_}.'"' } sort(keys(%attr))) : ''; 454 if (!@c || (@c==1 && !ref($c[0]) && ($c[0] eq ''))) 455 { 456 push @t,'<'.$tag.$attr.'/>'; 457 } else 458 { 459 push @t,'<'.$tag.$attr.'>'; 460 push @t,(@c==1 && !ref($c[0]))? xml_escape($c[0]) : xml_write(\@c); 461 push @t,'</'.$tag.'>'; 462 } 463 } 464 return @t; 465} 466 467sub xml_indent 468{ 469 my $xml=shift; 470 chomp($xml); 471 my $r; 472 473 $xml=~s!(<)!\n$1!g; 474 $xml=~s!<(\S+)>(.+)\n</\1>!<$1>$2</$1>!g; 475 $xml=~s!<(\S+)((?:\s+\S+=['"][^'"]+['"])+)>(.+)\n</\1>!<$1$2>$3</$1>!g; 476 477 my $s=0; 478 foreach my $m (split(/\n/,$xml)) 479 { 480 next if $m=~m/^\s*$/; 481 $s-- if ($m=~m!^</\S+>$!); 482 483 $r.=' ' x $s; 484 $r.=$m."\n"; 485 486 $s++ if ($m=~m!^<[^>?]+[^/](?:\s+\S+=['"][^'"]+['"])*>$!); 487 $s-- if ($m=~m!^</\S+>$!); 488 } 489 490 ## As xml_indent is used during logging, we do a final quick check (spaces should not be relevant anyway) 491 ## This test should probably be dumped as some point in the future when we are confident enough. But we got hit in the past by some subtleties, so... 492 my $in=$xml; 493 $in=~s/\s+//g; 494 my $out=$r; 495 $out=~s/\s+//g; 496 if ($in ne $out) { Net::DRI::Exception::err_assert('xml_indent failed to do its job, please report !'); } 497 498 return $r; 499} 500 501sub xml_list_children 502{ 503 my $node=shift; 504 ## '*' catch all element nodes being direct children of given node 505 return map { [ $_->localname() || $_->nodeName(),$_ ] } grep { $_->nodeType() == 1 } $node->getChildrenByTagName('*'); 506} 507 508sub xml_traverse 509{ 510 my ($node,$ns,@nodes)=@_; 511 my $p=sprintf('*[namespace-uri()="%s" and local-name()="%s"]',$ns,shift(@nodes)); 512 $p.='/'.join('/',map { '*[local-name()="'.$_.'"]' } @nodes) if @nodes; 513 my $r=$node->findnodes($p); 514 return unless $r->size(); 515 return ($r->size()==1)? $r->get_node(1) : $r->get_nodelist(); 516} 517 518sub xml_child_content 519{ 520 my ($node,$ns,$what)=@_; 521 my $list=$node->getChildrenByTagNameNS($ns,$what); 522 return unless $list->size()==1; 523 my $n=$list->get_node(1); 524 return defined $n ? $n->textContent() : undef; 525} 526 527#################################################################################################### 528 529sub remcam 530{ 531 my $in=shift; 532 $in=~s/ID/_id/g; 533 $in=~s/([A-Z])/_$1/g; 534 return lc($in); 535} 536 537sub encode { my ($cs,$data)=@_; return Encode::encode($cs,ref $data? $data->as_string() : $data,1); } ## Will croak on malformed data (a case that should not happen) 538sub encode_utf8 { return encode('UTF-8',$_[0]); } 539sub encode_ascii { return encode('ascii',$_[0]); } 540sub decode { my ($cs,$data)=@_; return Encode::decode($cs,$data,1); } ## Will croak on malformed data (a case that should not happen) 541sub decode_utf8 { return decode('UTF-8',$_[0]); } 542sub decode_ascii { return decode('ascii',$_[0]); } 543sub decode_latin1{ return decode('iso-8859-1',$_[0]); } 544 545sub normalize_name 546{ 547 my ($type,$key)=@_; 548 $type=lc($type); 549 ## contact IDs may be case sensitive... 550 ## Will need to be redone differently with IDNs 551 $key=lc($key) if ($type eq 'domain' || $type eq 'nsgroup'); 552 $key=lc($key) if ($type eq 'host' && $key=~m/\./); ## last test part is done only to handle the pure mess created by Nominet .UK "EPP" implementation... 553 return ($type,$key); 554} 555 556#################################################################################################### 557 558## RFC2782 559## (Net::DNS rrsort for SRV records does not seem to implement the same algorithm as the one specificied in the RFC, 560## as it just does a comparison on priority then weight) 561sub dns_srv_order 562{ 563 my (@r,%r); 564 foreach my $ans (@_) 565 { 566 push @{$r{$ans->priority()}},$ans; 567 } 568 foreach my $pri (sort { $a <=> $b } keys(%r)) 569 { 570 my @o=@{$r{$pri}}; 571 if (@o > 1) 572 { 573 my $ts=0; 574 foreach (@o) { $ts+=$_->weight(); } 575 my $s=0; 576 @o=map { $s+=$_->weight(); [ $s, $_ ] } (grep { $_->weight() == 0 } @o, grep { $_->weight() > 0 } @o); 577 my $cs=0; 578 while(@o > 1) 579 { 580 my $r=int(rand($ts-$cs+1)); 581 foreach my $i (0..$#o) 582 { 583 next unless $o[$i]->[0] >= $r; 584 $cs+=$o[$i]->[0]; 585 foreach my $j (($i+1)..$#o) { $o[$j]->[0]-=$o[$i]->[0]; } 586 push @r,$o[$i]->[1]; 587 splice(@o,$i,1); 588 last; 589 } 590 } 591 } 592 push @r,$o[0]->[1]; 593 } 594 return map { [$_->target(),$_->port()] } @r; 595} 596 597 598#################################################################################################### 5991; 600