ÿØÿà JFIF    ÿÛ „ ( %!1!%*+...983,7(-.- servent.pm000064400000006626152342707210006605 0ustar00package Net::servent; use strict; use 5.006_001; our $VERSION = '1.01'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); @EXPORT = qw(getservbyname getservbyport getservent getserv); @EXPORT_OK = qw( $s_name @s_aliases $s_port $s_proto ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } use vars @EXPORT_OK; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } use Class::Struct qw(struct); struct 'Net::servent' => [ name => '$', aliases => '@', port => '$', proto => '$', ]; sub populate (@) { return unless @_; my $sob = new(); $s_name = $sob->[0] = $_[0]; @s_aliases = @{ $sob->[1] } = split ' ', $_[1]; $s_port = $sob->[2] = $_[2]; $s_proto = $sob->[3] = $_[3]; return $sob; } sub getservent ( ) { populate(CORE::getservent()) } sub getservbyname ($;$) { populate(CORE::getservbyname(shift,shift||'tcp')) } sub getservbyport ($;$) { populate(CORE::getservbyport(shift,shift||'tcp')) } sub getserv ($;$) { no strict 'refs'; return &{'getservby' . ($_[0]=~/^\d+$/ ? 'port' : 'name')}(@_); } 1; __END__ =head1 NAME Net::servent - by-name interface to Perl's built-in getserv*() functions =head1 SYNOPSIS use Net::servent; $s = getservbyname(shift || 'ftp') || die "no service"; printf "port for %s is %s, aliases are %s\n", $s->name, $s->port, "@{$s->aliases}"; use Net::servent qw(:FIELDS); getservbyname(shift || 'ftp') || die "no service"; print "port for $s_name is $s_port, aliases are @s_aliases\n"; =head1 DESCRIPTION This module's default exports override the core getservent(), getservbyname(), and getnetbyport() functions, replacing them with versions that return "Net::servent" objects. They take default second arguments of "tcp". This object has methods that return the similarly named structure field name from the C's servent structure from F; namely name, aliases, port, and proto. The aliases method returns an array reference, the rest scalars. You may also import all the structure fields directly into your namespace as regular variables using the :FIELDS import tag. (Note that this still overrides your core functions.) Access these fields as variables named with a preceding C. Thus, C<$serv_obj-Ename()> corresponds to $s_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $serv_obj-Ealiases()}> would be simply @s_aliases. The getserv() function is a simple front-end that forwards a numeric argument to getservbyport(), and the rest to getservbyname(). To access this functionality without the core overrides, pass the C an empty import list, and then access function functions with their full qualified names. On the other hand, the built-ins are still available via the C pseudo-package. =head1 EXAMPLES use Net::servent qw(:FIELDS); while (@ARGV) { my ($service, $proto) = ((split m!/!, shift), 'tcp'); my $valet = getserv($service, $proto); unless ($valet) { warn "$0: No service: $service/$proto\n" next; } printf "service $service/$proto is port %d\n", $valet->port; print "alias are @s_aliases\n" if @s_aliases; } =head1 NOTE While this class is currently implemented using the Class::Struct module to build a struct-like class, you shouldn't rely upon this. =head1 AUTHOR Tom Christiansen Ping.pm000064400000234135152342707210006012 0ustar00package Net::Ping; require 5.002; require Exporter; use strict; use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $def_timeout $def_proto $def_factor $def_family $max_datasize $pingstring $hires $source_verify $syn_forking); use Fcntl qw( F_GETFL F_SETFL O_NONBLOCK ); use Socket qw( SOCK_DGRAM SOCK_STREAM SOCK_RAW AF_INET PF_INET IPPROTO_TCP SOL_SOCKET SO_ERROR SO_BROADCAST IPPROTO_IP IP_TOS IP_TTL inet_ntoa inet_aton getnameinfo NI_NUMERICHOST sockaddr_in ); use POSIX qw( ENOTCONN ECONNREFUSED ECONNRESET EINPROGRESS EWOULDBLOCK EAGAIN WNOHANG ); use FileHandle; use Carp; use Time::HiRes; @ISA = qw(Exporter); @EXPORT = qw(pingecho); @EXPORT_OK = qw(wakeonlan); $VERSION = "2.55"; # Globals $def_timeout = 5; # Default timeout to wait for a reply $def_proto = "tcp"; # Default protocol to use for pinging $def_factor = 1.2; # Default exponential backoff rate. $def_family = AF_INET; # Default family. $max_datasize = 1024; # Maximum data bytes in a packet # The data we exchange with the server for the stream protocol $pingstring = "pingschwingping!\n"; $source_verify = 1; # Default is to verify source endpoint $syn_forking = 0; # Constants my $AF_INET6 = eval { Socket::AF_INET6() }; my $AF_UNSPEC = eval { Socket::AF_UNSPEC() }; my $AI_NUMERICHOST = eval { Socket::AI_NUMERICHOST() }; my $NI_NUMERICHOST = eval { Socket::NI_NUMERICHOST() }; my $IPPROTO_IPV6 = eval { Socket::IPPROTO_IPV6() }; #my $IPV6_HOPLIMIT = eval { Socket::IPV6_HOPLIMIT() }; # ping6 -h 0-255 my $qr_family = qr/^(?:(?:(:?ip)?v?(?:4|6))|${\AF_INET}|$AF_INET6)$/; my $qr_family4 = qr/^(?:(?:(:?ip)?v?4)|${\AF_INET})$/; if ($^O =~ /Win32/i) { # Hack to avoid this Win32 spewage: # Your vendor has not defined POSIX macro ECONNREFUSED my @pairs = (ECONNREFUSED => 10061, # "Unknown Error" Special Win32 Response? ENOTCONN => 10057, ECONNRESET => 10054, EINPROGRESS => 10036, EWOULDBLOCK => 10035, ); while (my $name = shift @pairs) { my $value = shift @pairs; # When defined, these all are non-zero unless (eval $name) { no strict 'refs'; *{$name} = defined prototype \&{$name} ? sub () {$value} : sub {$value}; } } # $syn_forking = 1; # XXX possibly useful in < Win2K ? }; # Description: The pingecho() subroutine is provided for backward # compatibility with the original Net::Ping. It accepts a host # name/IP and an optional timeout in seconds. Create a tcp ping # object and try pinging the host. The result of the ping is returned. sub pingecho { my ($host, # Name or IP number of host to ping $timeout # Optional timeout in seconds ) = @_; my ($p); # A ping object $p = Net::Ping->new("tcp", $timeout); $p->ping($host); # Going out of scope closes the connection } # Description: The new() method creates a new ping object. Optional # parameters may be specified for the protocol to use, the timeout in # seconds and the size in bytes of additional data which should be # included in the packet. # After the optional parameters are checked, the data is constructed # and a socket is opened if appropriate. The object is returned. sub new { my ($this, $proto, # Optional protocol to use for pinging $timeout, # Optional timeout in seconds $data_size, # Optional additional bytes of data $device, # Optional device to use $tos, # Optional ToS to set $ttl, # Optional TTL to set $family, # Optional address family (AF_INET) ) = @_; my $class = ref($this) || $this; my $self = {}; my ($cnt, # Count through data bytes $min_datasize # Minimum data bytes required ); bless($self, $class); if (ref $proto eq 'HASH') { # support named args for my $k (qw(proto timeout data_size device tos ttl family gateway host port bind retrans pingstring source_verify econnrefused dontfrag IPV6_USE_MIN_MTU IPV6_RECVPATHMTU IPV6_HOPLIMIT)) { if (exists $proto->{$k}) { $self->{$k} = $proto->{$k}; # some are still globals if ($k eq 'pingstring') { $pingstring = $proto->{$k} } if ($k eq 'source_verify') { $source_verify = $proto->{$k} } delete $proto->{$k}; } } if (%$proto) { croak("Invalid named argument: ",join(" ",keys (%$proto))); } $proto = $self->{'proto'}; } $proto = $def_proto unless $proto; # Determine the protocol croak('Protocol for ping must be "icmp", "icmpv6", "udp", "tcp", "syn", "stream" or "external"') unless $proto =~ m/^(icmp|icmpv6|udp|tcp|syn|stream|external)$/; $self->{proto} = $proto; $timeout = $def_timeout unless $timeout; # Determine the timeout croak("Default timeout for ping must be greater than 0 seconds") if $timeout <= 0; $self->{timeout} = $timeout; $self->{device} = $device; $self->{tos} = $tos; if ($self->{'host'}) { my $host = $self->{'host'}; my $ip = _resolv($host) or carp("could not resolve host $host"); $self->{host} = $ip; $self->{family} = $ip->{family}; } if ($self->{bind}) { my $addr = $self->{bind}; my $ip = _resolv($addr) or carp("could not resolve local addr $addr"); $self->{local_addr} = $ip; } else { $self->{local_addr} = undef; # Don't bind by default } if ($self->{proto} eq 'icmp') { croak('TTL must be from 0 to 255') if ($ttl && ($ttl < 0 || $ttl > 255)); $self->{ttl} = $ttl; } if ($family) { if ($family =~ $qr_family) { if ($family =~ $qr_family4) { $self->{family} = AF_INET; } else { $self->{family} = $AF_INET6; } } else { croak('Family must be "ipv4" or "ipv6"') } } else { $self->{family} = $def_family; } $min_datasize = ($proto eq "udp") ? 1 : 0; # Determine data size $data_size = $min_datasize unless defined($data_size) && $proto ne "tcp"; croak("Data for ping must be from $min_datasize to $max_datasize bytes") if ($data_size < $min_datasize) || ($data_size > $max_datasize); $data_size-- if $self->{proto} eq "udp"; # We provide the first byte $self->{data_size} = $data_size; $self->{data} = ""; # Construct data bytes for ($cnt = 0; $cnt < $self->{data_size}; $cnt++) { $self->{data} .= chr($cnt % 256); } # Default exponential backoff rate $self->{retrans} = $def_factor unless exists $self->{retrans}; # Default Connection refused behavior $self->{econnrefused} = undef unless exists $self->{econnrefused}; $self->{seq} = 0; # For counting packets if ($self->{proto} eq "udp") # Open a socket { $self->{proto_num} = eval { (getprotobyname('udp'))[2] } || croak("Can't udp protocol by name"); $self->{port_num} = $self->{port} || (getservbyname('echo', 'udp'))[2] || croak("Can't get udp echo port by name"); $self->{fh} = FileHandle->new(); socket($self->{fh}, PF_INET, SOCK_DGRAM, $self->{proto_num}) || croak("udp socket error - $!"); $self->_setopts(); } elsif ($self->{proto} eq "icmp") { croak("icmp ping requires root privilege") if !_isroot(); $self->{proto_num} = eval { (getprotobyname('icmp'))[2] } || croak("Can't get icmp protocol by name"); $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid $self->{fh} = FileHandle->new(); socket($self->{fh}, PF_INET, SOCK_RAW, $self->{proto_num}) || croak("icmp socket error - $!"); $self->_setopts(); if ($self->{'ttl'}) { setsockopt($self->{fh}, IPPROTO_IP, IP_TTL, pack("I*", $self->{'ttl'})) or croak "error configuring ttl to $self->{'ttl'} $!"; } } elsif ($self->{proto} eq "icmpv6") { croak("icmpv6 ping requires root privilege") if !_isroot(); croak("Wrong family $self->{family} for icmpv6 protocol") if $self->{family} and $self->{family} != $AF_INET6; $self->{family} = $AF_INET6; $self->{proto_num} = eval { (getprotobyname('ipv6-icmp'))[2] } || croak("Can't get ipv6-icmp protocol by name"); # 58 $self->{pid} = $$ & 0xffff; # Save lower 16 bits of pid $self->{fh} = FileHandle->new(); socket($self->{fh}, $AF_INET6, SOCK_RAW, $self->{proto_num}) || croak("icmp socket error - $!"); $self->_setopts(); if ($self->{'gateway'}) { my $g = $self->{gateway}; my $ip = _resolv($g) or croak("nonexistent gateway $g"); $self->{family} eq $AF_INET6 or croak("gateway requires the AF_INET6 family"); $ip->{family} eq $AF_INET6 or croak("gateway address needs to be IPv6"); my $IPV6_NEXTHOP = eval { Socket::IPV6_NEXTHOP() } || 48; # IPV6_3542NEXTHOP, or 21 setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_NEXTHOP, _pack_sockaddr_in($ip)) or croak "error configuring gateway to $g NEXTHOP $!"; } if (exists $self->{IPV6_USE_MIN_MTU}) { my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 42; setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, pack("I*", $self->{'IPV6_USE_MIN_MT'})) or croak "error configuring IPV6_USE_MIN_MT} $!"; } if (exists $self->{IPV6_RECVPATHMTU}) { my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, pack("I*", $self->{'RECVPATHMTU'})) or croak "error configuring IPV6_RECVPATHMTU $!"; } if ($self->{'tos'}) { my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; setsockopt($self->{fh}, $proto, IP_TOS, pack("I*", $self->{'tos'})) or croak "error configuring tos to $self->{'tos'} $!"; } if ($self->{'ttl'}) { my $proto = $self->{family} == AF_INET ? IPPROTO_IP : $IPPROTO_IPV6; setsockopt($self->{fh}, $proto, IP_TTL, pack("I*", $self->{'ttl'})) or croak "error configuring ttl to $self->{'ttl'} $!"; } } elsif ($self->{proto} eq "tcp" || $self->{proto} eq "stream") { $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || croak("Can't get tcp protocol by name"); $self->{port_num} = $self->{port} || (getservbyname('echo', 'tcp'))[2] || croak("Can't get tcp echo port by name"); $self->{fh} = FileHandle->new(); } elsif ($self->{proto} eq "syn") { $self->{proto_num} = eval { (getprotobyname('tcp'))[2] } || croak("Can't get tcp protocol by name"); $self->{port_num} = (getservbyname('echo', 'tcp'))[2] || croak("Can't get tcp echo port by name"); if ($syn_forking) { $self->{fork_rd} = FileHandle->new(); $self->{fork_wr} = FileHandle->new(); pipe($self->{fork_rd}, $self->{fork_wr}); $self->{fh} = FileHandle->new(); $self->{good} = {}; $self->{bad} = {}; } else { $self->{wbits} = ""; $self->{bad} = {}; } $self->{syn} = {}; $self->{stop_time} = 0; } return($self); } # Description: Set the local IP address from which pings will be sent. # For ICMP, UDP and TCP pings, just saves the address to be used when # the socket is opened. Returns non-zero if successful; croaks on error. sub bind { my ($self, $local_addr # Name or IP number of local interface ) = @_; my ($ip, # Hash of addr (string), addr_in (packed), family $h # resolved hash ); croak("Usage: \$p->bind(\$local_addr)") unless @_ == 2; croak("already bound") if defined($self->{local_addr}) && ($self->{proto} eq "udp" || $self->{proto} eq "icmp"); $ip = $self->_resolv($local_addr); carp("nonexistent local address $local_addr") unless defined($ip); $self->{local_addr} = $ip; if (($self->{proto} ne "udp") && ($self->{proto} ne "icmp") && ($self->{proto} ne "tcp") && ($self->{proto} ne "syn")) { croak("Unknown protocol \"$self->{proto}\" in bind()"); } return 1; } # Description: A select() wrapper that compensates for platform # peculiarities. sub mselect { if ($_[3] > 0 and $^O eq 'MSWin32') { # On windows, select() doesn't process the message loop, # but sleep() will, allowing alarm() to interrupt the latter. # So we chop up the timeout into smaller pieces and interleave # select() and sleep() calls. my $t = $_[3]; my $gran = 0.5; # polling granularity in seconds my @args = @_; while (1) { $gran = $t if $gran > $t; my $nfound = select($_[0], $_[1], $_[2], $gran); undef $nfound if $nfound == -1; $t -= $gran; return $nfound if $nfound or !defined($nfound) or $t <= 0; sleep(0); ($_[0], $_[1], $_[2]) = @args; } } else { my $nfound = select($_[0], $_[1], $_[2], $_[3]); undef $nfound if $nfound == -1; return $nfound; } } # Description: Allow UDP source endpoint comparison to be # skipped for those remote interfaces that do # not response from the same endpoint. sub source_verify { my $self = shift; $source_verify = 1 unless defined ($source_verify = ((defined $self) && (ref $self)) ? shift() : $self); } # Description: Set whether or not the connect # behavior should enforce remote service # availability as well as reachability. sub service_check { my $self = shift; $self->{econnrefused} = 1 unless defined ($self->{econnrefused} = shift()); } sub tcp_service_check { service_check(@_); } # Description: Set exponential backoff for retransmission. # Should be > 1 to retain exponential properties. # If set to 0, retransmissions are disabled. sub retrans { my $self = shift; $self->{retrans} = shift; } sub _IsAdminUser { return unless $^O eq 'MSWin32' or $^O eq "cygwin"; return unless eval { require Win32 }; return unless defined &Win32::IsAdminUser; return Win32::IsAdminUser(); } sub _isroot { if (($> and $^O ne 'VMS' and $^O ne 'cygwin') or (($^O eq 'MSWin32' or $^O eq 'cygwin') and !_IsAdminUser()) or ($^O eq 'VMS' and (`write sys\$output f\$privilege("SYSPRV")` =~ m/FALSE/))) { return 0; } else { return 1; } } # Description: Sets ipv6 reachability # REACHCONF was removed in RFC3542, ping6 -R supports it. requires root. sub IPV6_REACHCONF { my $self = shift; my $on = shift; if ($on) { my $reachconf = eval { Socket::IPV6_REACHCONF() }; if (!$reachconf) { carp "IPV6_REACHCONF not supported on this platform"; return 0; } if (!_isroot()) { carp "IPV6_REACHCONF requires root permissions"; return 0; } $self->{IPV6_REACHCONF} = 1; } else { return $self->{IPV6_REACHCONF}; } } # Description: set it on or off. sub IPV6_USE_MIN_MTU { my $self = shift; my $on = shift; if (defined $on) { my $IPV6_USE_MIN_MTU = eval { Socket::IPV6_USE_MIN_MTU() } || 43; #if (!$IPV6_USE_MIN_MTU) { # carp "IPV6_USE_MIN_MTU not supported on this platform"; # return 0; #} $self->{IPV6_USE_MIN_MTU} = $on ? 1 : 0; setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_USE_MIN_MTU, pack("I*", $self->{'IPV6_USE_MIN_MT'})) or croak "error configuring IPV6_USE_MIN_MT} $!"; } else { return $self->{IPV6_USE_MIN_MTU}; } } # Description: notify an according MTU sub IPV6_RECVPATHMTU { my $self = shift; my $on = shift; if ($on) { my $IPV6_RECVPATHMTU = eval { Socket::IPV6_RECVPATHMTU() } || 43; #if (!$RECVPATHMTU) { # carp "IPV6_RECVPATHMTU not supported on this platform"; # return 0; #} $self->{IPV6_RECVPATHMTU} = 1; setsockopt($self->{fh}, $IPPROTO_IPV6, $IPV6_RECVPATHMTU, pack("I*", $self->{'IPV6_RECVPATHMTU'})) or croak "error configuring IPV6_RECVPATHMTU} $!"; } else { return $self->{IPV6_RECVPATHMTU}; } } # Description: allows the module to use milliseconds as returned by # the Time::HiRes module $hires = 1; sub hires { my $self = shift; $hires = 1 unless defined ($hires = ((defined $self) && (ref $self)) ? shift() : $self); } sub time { return $hires ? Time::HiRes::time() : CORE::time(); } # Description: Sets or clears the O_NONBLOCK flag on a file handle. sub socket_blocking_mode { my ($self, $fh, # the file handle whose flags are to be modified $block) = @_; # if true then set the blocking # mode (clear O_NONBLOCK), otherwise # set the non-blocking mode (set O_NONBLOCK) my $flags; if ($^O eq 'MSWin32' || $^O eq 'VMS') { # FIONBIO enables non-blocking sockets on windows and vms. # FIONBIO is (0x80000000|(4<<16)|(ord('f')<<8)|126), as per winsock.h, ioctl.h my $f = 0x8004667e; my $v = pack("L", $block ? 0 : 1); ioctl($fh, $f, $v) or croak("ioctl failed: $!"); return; } if ($flags = fcntl($fh, F_GETFL, 0)) { $flags = $block ? ($flags & ~O_NONBLOCK) : ($flags | O_NONBLOCK); if (!fcntl($fh, F_SETFL, $flags)) { croak("fcntl F_SETFL: $!"); } } else { croak("fcntl F_GETFL: $!"); } } # Description: Ping a host name or IP number with an optional timeout. # First lookup the host, and return undef if it is not found. Otherwise # perform the specific ping method based on the protocol. Return the # result of the ping. sub ping { my ($self, $host, # Name or IP number of host to ping $timeout, # Seconds after which ping times out $family, # Address family ) = @_; my ($ip, # Hash of addr (string), addr_in (packed), family $ret, # The return value $ping_time, # When ping began ); $host = $self->{host} if !defined $host and $self->{host}; croak("Usage: \$p->ping([ \$host [, \$timeout [, \$family]]])") if @_ > 4 or !$host; $timeout = $self->{timeout} unless $timeout; croak("Timeout must be greater than 0 seconds") if $timeout <= 0; if ($family) { if ($family =~ $qr_family) { if ($family =~ $qr_family4) { $self->{family_local} = AF_INET; } else { $self->{family_local} = $AF_INET6; } } else { croak('Family must be "ipv4" or "ipv6"') } } else { $self->{family_local} = $self->{family}; } $ip = $self->_resolv($host); return () unless defined($ip); # Does host exist? # Dispatch to the appropriate routine. $ping_time = &time(); if ($self->{proto} eq "external") { $ret = $self->ping_external($ip, $timeout); } elsif ($self->{proto} eq "udp") { $ret = $self->ping_udp($ip, $timeout); } elsif ($self->{proto} eq "icmp") { $ret = $self->ping_icmp($ip, $timeout); } elsif ($self->{proto} eq "icmpv6") { $ret = $self->ping_icmpv6($ip, $timeout); } elsif ($self->{proto} eq "tcp") { $ret = $self->ping_tcp($ip, $timeout); } elsif ($self->{proto} eq "stream") { $ret = $self->ping_stream($ip, $timeout); } elsif ($self->{proto} eq "syn") { $ret = $self->ping_syn($host, $ip, $ping_time, $ping_time+$timeout); } else { croak("Unknown protocol \"$self->{proto}\" in ping()"); } return wantarray ? ($ret, &time() - $ping_time, $self->ntop($ip)) : $ret; } # Uses Net::Ping::External to do an external ping. sub ping_external { my ($self, $ip, # Hash of addr (string), addr_in (packed), family $timeout, # Seconds after which ping times out $family ) = @_; $ip = $self->{host} if !defined $ip and $self->{host}; $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; my @addr = exists $ip->{addr_in} ? ('ip' => $ip->{addr_in}) : ('host' => $ip->{host}); eval { require Net::Ping::External; } or croak('Protocol "external" not supported on your system: Net::Ping::External not found'); return Net::Ping::External::ping(@addr, timeout => $timeout, family => $family); } # h2ph "asm/socket.h" # require "asm/socket.ph"; use constant SO_BINDTODEVICE => 25; use constant ICMP_ECHOREPLY => 0; # ICMP packet types use constant ICMPv6_ECHOREPLY => 129; # ICMP packet types use constant ICMP_UNREACHABLE => 3; # ICMP packet types use constant ICMPv6_UNREACHABLE => 1; # ICMP packet types use constant ICMP_ECHO => 8; use constant ICMPv6_ECHO => 128; use constant ICMP_TIME_EXCEEDED => 11; # ICMP packet types use constant ICMP_PARAMETER_PROBLEM => 12; # ICMP packet types use constant ICMP_STRUCT => "C2 n3 A"; # Structure of a minimal ICMP packet use constant SUBCODE => 0; # No ICMP subcode for ECHO and ECHOREPLY use constant ICMP_FLAGS => 0; # No special flags for send or recv use constant ICMP_PORT => 0; # No port with ICMP use constant IP_MTU_DISCOVER => 10; # linux only sub ping_icmp { my ($self, $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; my ($saddr, # sockaddr_in with port and ip $checksum, # Checksum of ICMP packet $msg, # ICMP packet to send $len_msg, # Length of $msg $rbits, # Read bits, filehandles for reading $nfound, # Number of ready filehandles found $finish_time, # Time ping should be finished $done, # set to 1 when we are done $ret, # Return value $recv_msg, # Received message including IP header $from_saddr, # sockaddr_in of sender $from_port, # Port packet was sent from $from_ip, # Packed IP of sender $from_type, # ICMP type $from_subcode, # ICMP subcode $from_chk, # ICMP packet checksum $from_pid, # ICMP packet id $from_seq, # ICMP packet sequence $from_msg # ICMP message ); $ip = $self->{host} if !defined $ip and $self->{host}; $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; socket($self->{fh}, $ip->{family}, SOCK_RAW, $self->{proto_num}) || croak("icmp socket error - $!"); if (defined $self->{local_addr} && !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("icmp bind error - $!"); } $self->_setopts(); $self->{seq} = ($self->{seq} + 1) % 65536; # Increment sequence $checksum = 0; # No checksum for starters if ($ip->{family} == AF_INET) { $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, $checksum, $self->{pid}, $self->{seq}, $self->{data}); } else { # how to get SRC my $pseudo_header = pack('a16a16Nnn', $ip->{addr_in}, $ip->{addr_in}, 8+length($self->{data}), "\0", 0x003a); $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, $checksum, $self->{pid}, $self->{seq}, $self->{data}); $msg = $pseudo_header.$msg } $checksum = Net::Ping->checksum($msg); if ($ip->{family} == AF_INET) { $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMP_ECHO, SUBCODE, $checksum, $self->{pid}, $self->{seq}, $self->{data}); } else { $msg = pack(ICMP_STRUCT . $self->{data_size}, ICMPv6_ECHO, SUBCODE, $checksum, $self->{pid}, $self->{seq}, $self->{data}); } $len_msg = length($msg); $saddr = _pack_sockaddr_in(ICMP_PORT, $ip); $self->{from_ip} = undef; $self->{from_type} = undef; $self->{from_subcode} = undef; send($self->{fh}, $msg, ICMP_FLAGS, $saddr); # Send the message $rbits = ""; vec($rbits, $self->{fh}->fileno(), 1) = 1; $ret = 0; $done = 0; $finish_time = &time() + $timeout; # Must be done by this time while (!$done && $timeout > 0) # Keep trying if we have time { $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for packet $timeout = $finish_time - &time(); # Get remaining time if (!defined($nfound)) # Hmm, a strange error { $ret = undef; $done = 1; } elsif ($nfound) # Got a packet from somewhere { $recv_msg = ""; $from_pid = -1; $from_seq = -1; $from_saddr = recv($self->{fh}, $recv_msg, 1500, ICMP_FLAGS); ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); ($from_type, $from_subcode) = unpack("C2", substr($recv_msg, 20, 2)); if ($from_type == ICMP_ECHOREPLY) { ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) if length $recv_msg >= 28; } elsif ($from_type == ICMPv6_ECHOREPLY) { ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 24, 4)) if length $recv_msg >= 28; } else { ($from_pid, $from_seq) = unpack("n3", substr($recv_msg, 52, 4)) if length $recv_msg >= 56; } $self->{from_ip} = $from_ip; $self->{from_type} = $from_type; $self->{from_subcode} = $from_subcode; next if ($from_pid != $self->{pid}); next if ($from_seq != $self->{seq}); if (! $source_verify || ($self->ntop($from_ip) eq $self->ntop($ip))) { # Does the packet check out? if (($from_type == ICMP_ECHOREPLY) || ($from_type == ICMPv6_ECHOREPLY)) { $ret = 1; $done = 1; } elsif (($from_type == ICMP_UNREACHABLE) || ($from_type == ICMPv6_UNREACHABLE)) { $done = 1; } elsif ($from_type == ICMP_TIME_EXCEEDED) { $ret = 0; $done = 1; } } } else { # Oops, timed out $done = 1; } } return $ret; } sub ping_icmpv6 { shift->ping_icmp(@_); } sub icmp_result { my ($self) = @_; my $addr = $self->{from_ip} || ""; $addr = "\0\0\0\0" unless 4 == length $addr; return ($self->ntop($addr),($self->{from_type} || 0), ($self->{from_subcode} || 0)); } # Description: Do a checksum on the message. Basically sum all of # the short words and fold the high order bits into the low order bits. sub checksum { my ($class, $msg # The message to checksum ) = @_; my ($len_msg, # Length of the message $num_short, # The number of short words in the message $short, # One short word $chk # The checksum ); $len_msg = length($msg); $num_short = int($len_msg / 2); $chk = 0; foreach $short (unpack("n$num_short", $msg)) { $chk += $short; } # Add the odd byte in $chk += (unpack("C", substr($msg, $len_msg - 1, 1)) << 8) if $len_msg % 2; $chk = ($chk >> 16) + ($chk & 0xffff); # Fold high into low return(~(($chk >> 16) + $chk) & 0xffff); # Again and complement } # Description: Perform a tcp echo ping. Since a tcp connection is # host specific, we have to open and close each connection here. We # can't just leave a socket open. Because of the robust nature of # tcp, it will take a while before it gives up trying to establish a # connection. Therefore, we use select() on a non-blocking socket to # check against our timeout. No data bytes are actually # sent since the successful establishment of a connection is proof # enough of the reachability of the remote host. Also, tcp is # expensive and doesn't need our help to add to the overhead. sub ping_tcp { my ($self, $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; my ($ret # The return value ); $ip = $self->{host} if !defined $ip and $self->{host}; $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; $! = 0; $ret = $self -> tcp_connect( $ip, $timeout); if (!$self->{econnrefused} && $! == ECONNREFUSED) { $ret = 1; # "Connection refused" means reachable } $self->{fh}->close(); return $ret; } sub tcp_connect { my ($self, $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which connect times out ) = @_; my ($saddr); # Packed IP and Port $ip = $self->{host} if !defined $ip and $self->{host}; $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; $saddr = _pack_sockaddr_in($self->{port_num}, $ip); my $ret = 0; # Default to unreachable my $do_socket = sub { socket($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num}) || croak("tcp socket error - $!"); if (defined $self->{local_addr} && !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("tcp bind error - $!"); } $self->_setopts(); }; my $do_connect = sub { $self->{ip} = $ip->{addr_in}; # ECONNREFUSED is 10061 on MSWin32. If we pass it as child error through $?, # we'll get (10061 & 255) = 77, so we cannot check it in the parent process. return ($ret = connect($self->{fh}, $saddr) || ($! == ECONNREFUSED && !$self->{econnrefused})); }; my $do_connect_nb = sub { # Set O_NONBLOCK property on filehandle $self->socket_blocking_mode($self->{fh}, 0); # start the connection attempt if (!connect($self->{fh}, $saddr)) { if ($! == ECONNREFUSED) { $ret = 1 unless $self->{econnrefused}; } elsif ($! != EINPROGRESS && ($^O ne 'MSWin32' || $! != EWOULDBLOCK)) { # EINPROGRESS is the expected error code after a connect() # on a non-blocking socket. But if the kernel immediately # determined that this connect() will never work, # Simply respond with "unreachable" status. # (This can occur on some platforms with errno # EHOSTUNREACH or ENETUNREACH.) return 0; } else { # Got the expected EINPROGRESS. # Just wait for connection completion... my ($wbits, $wout, $wexc); $wout = $wexc = $wbits = ""; vec($wbits, $self->{fh}->fileno, 1) = 1; my $nfound = mselect(undef, ($wout = $wbits), ($^O eq 'MSWin32' ? ($wexc = $wbits) : undef), $timeout); warn("select: $!") unless defined $nfound; if ($nfound && vec($wout, $self->{fh}->fileno, 1)) { # the socket is ready for writing so the connection # attempt completed. test whether the connection # attempt was successful or not if (getpeername($self->{fh})) { # Connection established to remote host $ret = 1; } else { # TCP ACK will never come from this host # because there was an error connecting. # This should set $! to the correct error. my $char; sysread($self->{fh},$char,1); $! = ECONNREFUSED if ($! == EAGAIN && $^O =~ /cygwin/i); $ret = 1 if (!$self->{econnrefused} && $! == ECONNREFUSED); } } else { # the connection attempt timed out (or there were connect # errors on Windows) if ($^O =~ 'MSWin32') { # If the connect will fail on a non-blocking socket, # winsock reports ECONNREFUSED as an exception, and we # need to fetch the socket-level error code via getsockopt() # instead of using the thread-level error code that is in $!. if ($nfound && vec($wexc, $self->{fh}->fileno, 1)) { $! = unpack("i", getsockopt($self->{fh}, SOL_SOCKET, SO_ERROR)); } } } } } else { # Connection established to remote host $ret = 1; } # Unset O_NONBLOCK property on filehandle $self->socket_blocking_mode($self->{fh}, 1); $self->{ip} = $ip->{addr_in}; return $ret; }; if ($syn_forking) { # Buggy Winsock API doesn't allow nonblocking connect. # Hence, if our OS is Windows, we need to create a separate # process to do the blocking connect attempt. # XXX Above comments are not true at least for Win2K, where # nonblocking connect works. $| = 1; # Clear buffer prior to fork to prevent duplicate flushing. $self->{'tcp_chld'} = fork; if (!$self->{'tcp_chld'}) { if (!defined $self->{'tcp_chld'}) { # Fork did not work warn "Fork error: $!"; return 0; } &{ $do_socket }(); # Try a slow blocking connect() call # and report the status to the parent. if ( &{ $do_connect }() ) { $self->{fh}->close(); # No error exit 0; } else { # Pass the error status to the parent # Make sure that $! <= 255 exit($! <= 255 ? $! : 255); } } &{ $do_socket }(); my $patience = &time() + $timeout; my ($child, $child_errno); $? = 0; $child_errno = 0; # Wait up to the timeout # And clean off the zombie do { $child = waitpid($self->{'tcp_chld'}, &WNOHANG()); $child_errno = $? >> 8; select(undef, undef, undef, 0.1); } while &time() < $patience && $child != $self->{'tcp_chld'}; if ($child == $self->{'tcp_chld'}) { if ($self->{proto} eq "stream") { # We need the socket connected here, in parent # Should be safe to connect because the child finished # within the timeout &{ $do_connect }(); } # $ret cannot be set by the child process $ret = !$child_errno; } else { # Time must have run out. # Put that choking client out of its misery kill "KILL", $self->{'tcp_chld'}; # Clean off the zombie waitpid($self->{'tcp_chld'}, 0); $ret = 0; } delete $self->{'tcp_chld'}; $! = $child_errno; } else { # Otherwise don't waste the resources to fork &{ $do_socket }(); &{ $do_connect_nb }(); } return $ret; } sub DESTROY { my $self = shift; if ($self->{'proto'} eq 'tcp' && $self->{'tcp_chld'}) { # Put that choking client out of its misery kill "KILL", $self->{'tcp_chld'}; # Clean off the zombie waitpid($self->{'tcp_chld'}, 0); } } # This writes the given string to the socket and then reads it # back. It returns 1 on success, 0 on failure. sub tcp_echo { my ($self, $timeout, $pingstring) = @_; $timeout = $self->{timeout} if !defined $timeout and $self->{timeout}; $pingstring = $self->{pingstring} if !defined $pingstring and $self->{pingstring}; my $ret = undef; my $time = &time(); my $wrstr = $pingstring; my $rdstr = ""; eval <<'EOM'; do { my $rin = ""; vec($rin, $self->{fh}->fileno(), 1) = 1; my $rout = undef; if($wrstr) { $rout = ""; vec($rout, $self->{fh}->fileno(), 1) = 1; } if(mselect($rin, $rout, undef, ($time + $timeout) - &time())) { if($rout && vec($rout,$self->{fh}->fileno(),1)) { my $num = syswrite($self->{fh}, $wrstr, length $wrstr); if($num) { # If it was a partial write, update and try again. $wrstr = substr($wrstr,$num); } else { # There was an error. $ret = 0; } } if(vec($rin,$self->{fh}->fileno(),1)) { my $reply; if(sysread($self->{fh},$reply,length($pingstring)-length($rdstr))) { $rdstr .= $reply; $ret = 1 if $rdstr eq $pingstring; } else { # There was an error. $ret = 0; } } } } until &time() > ($time + $timeout) || defined($ret); EOM return $ret; } # Description: Perform a stream ping. If the tcp connection isn't # already open, it opens it. It then sends some data and waits for # a reply. It leaves the stream open on exit. sub ping_stream { my ($self, $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; # Open the stream if it's not already open if(!defined $self->{fh}->fileno()) { $self->tcp_connect($ip, $timeout) or return 0; } croak "tried to switch servers while stream pinging" if $self->{ip} ne $ip->{addr_in}; return $self->tcp_echo($timeout, $pingstring); } # Description: opens the stream. You would do this if you want to # separate the overhead of opening the stream from the first ping. sub open { my ($self, $host, # Host or IP address $timeout, # Seconds after which open times out $family ) = @_; my $ip; # Hash of addr (string), addr_in (packed), family $host = $self->{host} unless defined $host; if ($family) { if ($family =~ $qr_family) { if ($family =~ $qr_family4) { $self->{family_local} = AF_INET; } else { $self->{family_local} = $AF_INET6; } } else { croak('Family must be "ipv4" or "ipv6"') } } else { $self->{family_local} = $self->{family}; } $timeout = $self->{timeout} unless $timeout; $ip = $self->_resolv($host); if ($self->{proto} eq "stream") { if (defined($self->{fh}->fileno())) { croak("socket is already open"); } else { return () unless $ip; $self->tcp_connect($ip, $timeout); } } } sub _dontfrag { my $self = shift; # bsd solaris my $IP_DONTFRAG = eval { Socket::IP_DONTFRAG() }; if ($IP_DONTFRAG) { my $i = 1; setsockopt($self->{fh}, IPPROTO_IP, $IP_DONTFRAG, pack("I*", $i)) or croak "error configuring IP_DONTFRAG $!"; # Linux needs more: Path MTU Discovery as defined in RFC 1191 # For non SOCK_STREAM sockets it is the user's responsibility to packetize # the data in MTU sized chunks and to do the retransmits if necessary. # The kernel will reject packets that are bigger than the known path # MTU if this flag is set (with EMSGSIZE). if ($^O eq 'linux') { my $i = 2; # IP_PMTUDISC_DO setsockopt($self->{fh}, IPPROTO_IP, IP_MTU_DISCOVER, pack("I*", $i)) or croak "error configuring IP_MTU_DISCOVER $!"; } } } # SO_BINDTODEVICE + IP_TOS sub _setopts { my $self = shift; if ($self->{'device'}) { setsockopt($self->{fh}, SOL_SOCKET, SO_BINDTODEVICE, pack("Z*", $self->{'device'})) or croak "error binding to device $self->{'device'} $!"; } if ($self->{'tos'}) { # need to re-apply ToS (RT #6706) setsockopt($self->{fh}, IPPROTO_IP, IP_TOS, pack("I*", $self->{'tos'})) or croak "error applying tos to $self->{'tos'} $!"; } if ($self->{'dontfrag'}) { $self->_dontfrag; } } # Description: Perform a udp echo ping. Construct a message of # at least the one-byte sequence number and any additional data bytes. # Send the message out and wait for a message to come back. If we # get a message, make sure all of its parts match. If they do, we are # done. Otherwise go back and wait for the message until we run out # of time. Return the result of our efforts. use constant UDP_FLAGS => 0; # Nothing special on send or recv sub ping_udp { my ($self, $ip, # Hash of addr (string), addr_in (packed), family $timeout # Seconds after which ping times out ) = @_; my ($saddr, # sockaddr_in with port and ip $ret, # The return value $msg, # Message to be echoed $finish_time, # Time ping should be finished $flush, # Whether socket needs to be disconnected $connect, # Whether socket needs to be connected $done, # Set to 1 when we are done pinging $rbits, # Read bits, filehandles for reading $nfound, # Number of ready filehandles found $from_saddr, # sockaddr_in of sender $from_msg, # Characters echoed by $host $from_port, # Port message was echoed from $from_ip # Packed IP number of sender ); $saddr = _pack_sockaddr_in($self->{port_num}, $ip); $self->{seq} = ($self->{seq} + 1) % 256; # Increment sequence $msg = chr($self->{seq}) . $self->{data}; # Add data if any socket($self->{fh}, $ip->{family}, SOCK_DGRAM, $self->{proto_num}) || croak("udp socket error - $!"); if (defined $self->{local_addr} && !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("udp bind error - $!"); } $self->_setopts(); if ($self->{connected}) { if ($self->{connected} ne $saddr) { # Still connected to wrong destination. # Need to flush out the old one. $flush = 1; } } else { # Not connected yet. # Need to connect() before send() $connect = 1; } # Have to connect() and send() instead of sendto() # in order to pick up on the ECONNREFUSED setting # from recv() or double send() errno as utilized in # the concept by rdw @ perlmonks. See: # http://perlmonks.thepen.com/42898.html if ($flush) { # Need to socket() again to flush the descriptor # This will disconnect from the old saddr. socket($self->{fh}, $ip->{family}, SOCK_DGRAM, $self->{proto_num}); $self->_setopts(); } # Connect the socket if it isn't already connected # to the right destination. if ($flush || $connect) { connect($self->{fh}, $saddr); # Tie destination to socket $self->{connected} = $saddr; } send($self->{fh}, $msg, UDP_FLAGS); # Send it $rbits = ""; vec($rbits, $self->{fh}->fileno(), 1) = 1; $ret = 0; # Default to unreachable $done = 0; my $retrans = 0.01; my $factor = $self->{retrans}; $finish_time = &time() + $timeout; # Ping needs to be done by then while (!$done && $timeout > 0) { if ($factor > 1) { $timeout = $retrans if $timeout > $retrans; $retrans*= $factor; # Exponential backoff } $nfound = mselect((my $rout=$rbits), undef, undef, $timeout); # Wait for response my $why = $!; $timeout = $finish_time - &time(); # Get remaining time if (!defined($nfound)) # Hmm, a strange error { $ret = undef; $done = 1; } elsif ($nfound) # A packet is waiting { $from_msg = ""; $from_saddr = recv($self->{fh}, $from_msg, 1500, UDP_FLAGS); if (!$from_saddr) { # For example an unreachable host will make recv() fail. if (!$self->{econnrefused} && ($! == ECONNREFUSED || $! == ECONNRESET)) { # "Connection refused" means reachable # Good, continue $ret = 1; } $done = 1; } else { ($from_port, $from_ip) = _unpack_sockaddr_in($from_saddr, $ip->{family}); if (!$source_verify || (($from_ip eq $ip) && # Does the packet check out? ($from_port == $self->{port_num}) && ($from_msg eq $msg))) { $ret = 1; # It's a winner $done = 1; } } } elsif ($timeout <= 0) # Oops, timed out { $done = 1; } else { # Send another in case the last one dropped if (send($self->{fh}, $msg, UDP_FLAGS)) { # Another send worked? The previous udp packet # must have gotten lost or is still in transit. # Hopefully this new packet will arrive safely. } else { if (!$self->{econnrefused} && $! == ECONNREFUSED) { # "Connection refused" means reachable # Good, continue $ret = 1; } $done = 1; } } } return $ret; } # Description: Send a TCP SYN packet to host specified. sub ping_syn { my $self = shift; my $host = shift; my $ip = shift; my $start_time = shift; my $stop_time = shift; if ($syn_forking) { return $self->ping_syn_fork($host, $ip, $start_time, $stop_time); } my $fh = FileHandle->new(); my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); # Create TCP socket if (!socket ($fh, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { croak("tcp socket error - $!"); } if (defined $self->{local_addr} && !CORE::bind($fh, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("tcp bind error - $!"); } $self->_setopts(); # Set O_NONBLOCK property on filehandle $self->socket_blocking_mode($fh, 0); # Attempt the non-blocking connect # by just sending the TCP SYN packet if (connect($fh, $saddr)) { # Non-blocking, yet still connected? # Must have connected very quickly, # or else it wasn't very non-blocking. #warn "WARNING: Nonblocking connect connected anyway? ($^O)"; } else { # Error occurred connecting. if ($! == EINPROGRESS || ($^O eq 'MSWin32' && $! == EWOULDBLOCK)) { # The connection is just still in progress. # This is the expected condition. } else { # Just save the error and continue on. # The ack() can check the status later. $self->{bad}->{$host} = $!; } } my $entry = [ $host, $ip, $fh, $start_time, $stop_time ]; $self->{syn}->{$fh->fileno} = $entry; if ($self->{stop_time} < $stop_time) { $self->{stop_time} = $stop_time; } vec($self->{wbits}, $fh->fileno, 1) = 1; return 1; } sub ping_syn_fork { my ($self, $host, $ip, $start_time, $stop_time) = @_; # Buggy Winsock API doesn't allow nonblocking connect. # Hence, if our OS is Windows, we need to create a separate # process to do the blocking connect attempt. my $pid = fork(); if (defined $pid) { if ($pid) { # Parent process my $entry = [ $host, $ip, $pid, $start_time, $stop_time ]; $self->{syn}->{$pid} = $entry; if ($self->{stop_time} < $stop_time) { $self->{stop_time} = $stop_time; } } else { # Child process my $saddr = _pack_sockaddr_in($self->{port_num}, $ip); # Create TCP socket if (!socket ($self->{fh}, $ip->{family}, SOCK_STREAM, $self->{proto_num})) { croak("tcp socket error - $!"); } if (defined $self->{local_addr} && !CORE::bind($self->{fh}, _pack_sockaddr_in(0, $self->{local_addr}))) { croak("tcp bind error - $!"); } $self->_setopts(); $!=0; # Try to connect (could take a long time) connect($self->{fh}, $saddr); # Notify parent of connect error status my $err = $!+0; my $wrstr = "$$ $err"; # Force to 16 chars including \n $wrstr .= " "x(15 - length $wrstr). "\n"; syswrite($self->{fork_wr}, $wrstr, length $wrstr); exit; } } else { # fork() failed? die "fork: $!"; } return 1; } # Description: Wait for TCP ACK from host specified # from ping_syn above. If no host is specified, wait # for TCP ACK from any of the hosts in the SYN queue. sub ack { my $self = shift; if ($self->{proto} eq "syn") { if ($syn_forking) { my @answer = $self->ack_unfork(shift); return wantarray ? @answer : $answer[0]; } my $wbits = ""; my $stop_time = 0; if (my $host = shift or $self->{host}) { # Host passed as arg or as option to new $host = $self->{host} unless defined $host; if (exists $self->{bad}->{$host}) { if (!$self->{econnrefused} && $self->{bad}->{ $host } && (($! = ECONNREFUSED)>0) && $self->{bad}->{ $host } eq "$!") { # "Connection refused" means reachable # Good, continue } else { # ECONNREFUSED means no good return (); } } my $host_fd = undef; foreach my $fd (keys %{ $self->{syn} }) { my $entry = $self->{syn}->{$fd}; if ($entry->[0] eq $host) { $host_fd = $fd; $stop_time = $entry->[4] || croak("Corrupted SYN entry for [$host]"); last; } } croak("ack called on [$host] without calling ping first!") unless defined $host_fd; vec($wbits, $host_fd, 1) = 1; } else { # No $host passed so scan all hosts # Use the latest stop_time $stop_time = $self->{stop_time}; # Use all the bits $wbits = $self->{wbits}; } while ($wbits !~ /^\0*\z/) { my $timeout = $stop_time - &time(); # Force a minimum of 10 ms timeout. $timeout = 0.01 if $timeout <= 0.01; my $winner_fd = undef; my $wout = $wbits; my $fd = 0; # Do "bad" fds from $wbits first while ($wout !~ /^\0*\z/) { if (vec($wout, $fd, 1)) { # Wipe it from future scanning. vec($wout, $fd, 1) = 0; if (my $entry = $self->{syn}->{$fd}) { if ($self->{bad}->{ $entry->[0] }) { $winner_fd = $fd; last; } } } $fd++; } if (defined($winner_fd) or my $nfound = mselect(undef, ($wout=$wbits), undef, $timeout)) { if (defined $winner_fd) { $fd = $winner_fd; } else { # Done waiting for one of the ACKs $fd = 0; # Determine which one while ($wout !~ /^\0*\z/ && !vec($wout, $fd, 1)) { $fd++; } } if (my $entry = $self->{syn}->{$fd}) { # Wipe it from future scanning. delete $self->{syn}->{$fd}; vec($self->{wbits}, $fd, 1) = 0; vec($wbits, $fd, 1) = 0; if (!$self->{econnrefused} && $self->{bad}->{ $entry->[0] } && (($! = ECONNREFUSED)>0) && $self->{bad}->{ $entry->[0] } eq "$!") { # "Connection refused" means reachable # Good, continue } elsif (getpeername($entry->[2])) { # Connection established to remote host # Good, continue } else { # TCP ACK will never come from this host # because there was an error connecting. # This should set $! to the correct error. my $char; sysread($entry->[2],$char,1); # Store the excuse why the connection failed. $self->{bad}->{$entry->[0]} = $!; if (!$self->{econnrefused} && (($! == ECONNREFUSED) || ($! == EAGAIN && $^O =~ /cygwin/i))) { # "Connection refused" means reachable # Good, continue } else { # No good, try the next socket... next; } } # Everything passed okay, return the answer return wantarray ? ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])) : $entry->[0]; } else { warn "Corrupted SYN entry: unknown fd [$fd] ready!"; vec($wbits, $fd, 1) = 0; vec($self->{wbits}, $fd, 1) = 0; } } elsif (defined $nfound) { # Timed out waiting for ACK foreach my $fd (keys %{ $self->{syn} }) { if (vec($wbits, $fd, 1)) { my $entry = $self->{syn}->{$fd}; $self->{bad}->{$entry->[0]} = "Timed out"; vec($wbits, $fd, 1) = 0; vec($self->{wbits}, $fd, 1) = 0; delete $self->{syn}->{$fd}; } } } else { # Weird error occurred with select() warn("select: $!"); $self->{syn} = {}; $wbits = ""; } } } return (); } sub ack_unfork { my ($self,$host) = @_; my $stop_time = $self->{stop_time}; if ($host) { # Host passed as arg if (my $entry = $self->{good}->{$host}) { delete $self->{good}->{$host}; return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])); } } my $rbits = ""; my $timeout; if (keys %{ $self->{syn} }) { # Scan all hosts that are left vec($rbits, fileno($self->{fork_rd}), 1) = 1; $timeout = $stop_time - &time(); # Force a minimum of 10 ms timeout. $timeout = 0.01 if $timeout < 0.01; } else { # No hosts left to wait for $timeout = 0; } if ($timeout > 0) { my $nfound; while ( keys %{ $self->{syn} } and $nfound = mselect((my $rout=$rbits), undef, undef, $timeout)) { # Done waiting for one of the ACKs if (!sysread($self->{fork_rd}, $_, 16)) { # Socket closed, which means all children are done. return (); } my ($pid, $how) = split; if ($pid) { # Flush the zombie waitpid($pid, 0); if (my $entry = $self->{syn}->{$pid}) { # Connection attempt to remote host is done delete $self->{syn}->{$pid}; if (!$how || # If there was no error connecting (!$self->{econnrefused} && $how == ECONNREFUSED)) { # "Connection refused" means reachable if ($host && $entry->[0] ne $host) { # A good connection, but not the host we need. # Move it from the "syn" hash to the "good" hash. $self->{good}->{$entry->[0]} = $entry; # And wait for the next winner next; } return ($entry->[0], &time() - $entry->[3], $self->ntop($entry->[1])); } } else { # Should never happen die "Unknown ping from pid [$pid]"; } } else { die "Empty response from status socket?"; } } if (defined $nfound) { # Timed out waiting for ACK status } else { # Weird error occurred with select() warn("select: $!"); } } if (my @synners = keys %{ $self->{syn} }) { # Kill all the synners kill 9, @synners; foreach my $pid (@synners) { # Wait for the deaths to finish # Then flush off the zombie waitpid($pid, 0); } } $self->{syn} = {}; return (); } # Description: Tell why the ack() failed sub nack { my $self = shift; my $host = shift || croak('Usage> nack($failed_ack_host)'); return $self->{bad}->{$host} || undef; } # Description: Close the connection. sub close { my ($self) = @_; if ($self->{proto} eq "syn") { delete $self->{syn}; } elsif ($self->{proto} eq "tcp") { # The connection will already be closed } elsif ($self->{proto} eq "external") { # Nothing to close } else { $self->{fh}->close(); } } sub port_number { my $self = shift; if(@_) { $self->{port_num} = shift @_; $self->service_check(1); } return $self->{port_num}; } sub ntop { my($self, $ip) = @_; # Vista doesn't define a inet_ntop. It has InetNtop instead. # Not following ANSI... priceless. getnameinfo() is defined # for Windows 2000 and later, so that may be the choice. # Any port will work, even undef, but this will work for now. # Socket warns when undef is passed in, but it still works. my $port = getservbyname('echo', 'udp'); my $sockaddr = _pack_sockaddr_in($port, $ip); my ($error, $address) = getnameinfo($sockaddr, NI_NUMERICHOST); if($error) { croak $error; } return $address; } sub wakeonlan { my ($mac_addr, $host, $port) = @_; # use the discard service if $port not passed in if (! defined $host) { $host = '255.255.255.255' } if (! defined $port || $port !~ /^\d+$/ ) { $port = 9 } require IO::Socket::INET; my $sock = IO::Socket::INET->new(Proto=>'udp') || return undef; my $ip_addr = inet_aton($host); my $sock_addr = sockaddr_in($port, $ip_addr); $mac_addr =~ s/://g; my $packet = pack('C6H*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, $mac_addr x 16); setsockopt($sock, SOL_SOCKET, SO_BROADCAST, 1); send($sock, $packet, 0, $sock_addr); $sock->close; return 1; } ######################################################## # DNS hostname resolution # return: # $h->{name} = host - as passed in # $h->{host} = host - as passed in without :port # $h->{port} = OPTIONAL - if :port, then value of port # $h->{addr} = resolved numeric address # $h->{addr_in} = aton/pton result # $h->{family} = AF_INET/6 ############################ sub _resolv { my ($self, $name, ) = @_; my %h; $h{name} = $name; my $family = $self->{family}; if (defined($self->{family_local})) { $family = $self->{family_local} } # START - host:port my $cnt = 0; # Count ":" $cnt++ while ($name =~ m/:/g); # 0 = hostname or IPv4 address if ($cnt == 0) { $h{host} = $name # 1 = IPv4 address with port } elsif ($cnt == 1) { ($h{host}, $h{port}) = split /:/, $name # >=2 = IPv6 address } elsif ($cnt >= 2) { #IPv6 with port - [2001::1]:port if ($name =~ /^\[.*\]:\d{1,5}$/) { ($h{host}, $h{port}) = split /:([^:]+)$/, $name # split after last : # IPv6 without port } else { $h{host} = $name } } # Clean up host $h{host} =~ s/\[//g; $h{host} =~ s/\]//g; # Clean up port if (defined($h{port}) && (($h{port} !~ /^\d{1,5}$/) || ($h{port} < 1) || ($h{port} > 65535))) { croak("Invalid port `$h{port}' in `$name'"); return undef; } # END - host:port # address check # new way if ($Socket::VERSION >= 1.94) { my %hints = ( family => $AF_UNSPEC, protocol => IPPROTO_TCP, flags => $AI_NUMERICHOST ); # numeric address, return my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); if (defined($getaddr[0])) { $h{addr} = $h{host}; $h{family} = $getaddr[0]->{family}; if ($h{family} == AF_INET) { (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; } else { (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; } return \%h } # old way } else { # numeric address, return my $ret = gethostbyname($h{host}); if (defined($ret) && (_inet_ntoa($ret) eq $h{host})) { $h{addr} = $h{host}; $h{addr_in} = $ret; $h{family} = AF_INET; return \%h } } # resolve # new way if ($Socket::VERSION >= 1.94) { my %hints = ( family => $family, protocol => IPPROTO_TCP ); my ($err, @getaddr) = Socket::getaddrinfo($h{host}, undef, \%hints); if (defined($getaddr[0])) { my ($err, $address) = Socket::getnameinfo($getaddr[0]->{addr}, $NI_NUMERICHOST); if (defined($address)) { $h{addr} = $address; $h{addr} =~ s/\%(.)*$//; # remove %ifID if IPv6 $h{family} = $getaddr[0]->{family}; if ($h{family} == AF_INET) { (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in $getaddr[0]->{addr}; } else { (undef, $h{addr_in}, undef, undef) = Socket::unpack_sockaddr_in6 $getaddr[0]->{addr}; } return \%h; } else { carp("getnameinfo($getaddr[0]->{addr}) failed - $err"); return undef; } } else { warn(sprintf("getaddrinfo($h{host},,%s) failed - $err", $family == AF_INET ? "AF_INET" : "AF_INET6")); return undef; } # old way } else { if ($family == $AF_INET6) { croak("Socket >= 1.94 required for IPv6 - found Socket $Socket::VERSION"); return undef; } my @gethost = gethostbyname($h{host}); if (defined($gethost[4])) { $h{addr} = inet_ntoa($gethost[4]); $h{addr_in} = $gethost[4]; $h{family} = AF_INET; return \%h } else { carp("gethostbyname($h{host}) failed - $^E"); return undef; } } return undef; } sub _pack_sockaddr_in($$) { my ($port, $ip, ) = @_; my $addr = ref($ip) eq "HASH" ? $ip->{addr_in} : $ip; if (length($addr) <= 4 ) { return Socket::pack_sockaddr_in($port, $addr); } else { return Socket::pack_sockaddr_in6($port, $addr); } } sub _unpack_sockaddr_in($;$) { my ($addr, $family, ) = @_; my ($port, $host); if ($family == AF_INET || (!defined($family) and length($addr) <= 16 )) { ($port, $host) = Socket::unpack_sockaddr_in($addr); } else { ($port, $host) = Socket::unpack_sockaddr_in6($addr); } return $port, $host } sub _inet_ntoa { my ($addr ) = @_; my $ret; if ($Socket::VERSION >= 1.94) { my ($err, $address) = Socket::getnameinfo($addr, $NI_NUMERICHOST); if (defined($address)) { $ret = $address; } else { carp("getnameinfo($addr) failed - $err"); } } else { $ret = inet_ntoa($addr) } return $ret } 1; __END__ =head1 NAME Net::Ping - check a remote host for reachability =head1 SYNOPSIS use Net::Ping; $p = Net::Ping->new(); print "$host is alive.\n" if $p->ping($host); $p->close(); $p = Net::Ping->new("icmp"); $p->bind($my_addr); # Specify source interface of pings foreach $host (@host_array) { print "$host is "; print "NOT " unless $p->ping($host, 2); print "reachable.\n"; sleep(1); } $p->close(); $p = Net::Ping->new("tcp", 2); # Try connecting to the www port instead of the echo port $p->port_number(scalar(getservbyname("http", "tcp"))); while ($stop_time > time()) { print "$host not reachable ", scalar(localtime()), "\n" unless $p->ping($host); sleep(300); } undef($p); # Like tcp protocol, but with many hosts $p = Net::Ping->new("syn"); $p->port_number(getservbyname("http", "tcp")); foreach $host (@host_array) { $p->ping($host); } while (($host,$rtt,$ip) = $p->ack) { print "HOST: $host [$ip] ACKed in $rtt seconds.\n"; } # High precision syntax (requires Time::HiRes) $p = Net::Ping->new(); $p->hires(); ($ret, $duration, $ip) = $p->ping($host, 5.5); printf("$host [ip: $ip] is alive (packet return time: %.2f ms)\n", 1000 * $duration) if $ret; $p->close(); # For backward compatibility print "$host is alive.\n" if pingecho($host); =head1 DESCRIPTION This module contains methods to test the reachability of remote hosts on a network. A ping object is first created with optional parameters, a variable number of hosts may be pinged multiple times and then the connection is closed. You may choose one of six different protocols to use for the ping. The "tcp" protocol is the default. Note that a live remote host may still fail to be pingable by one or more of these protocols. For example, www.microsoft.com is generally alive but not "icmp" pingable. With the "tcp" protocol the ping() method attempts to establish a connection to the remote host's echo port. If the connection is successfully established, the remote host is considered reachable. No data is actually echoed. This protocol does not require any special privileges but has higher overhead than the "udp" and "icmp" protocols. Specifying the "udp" protocol causes the ping() method to send a udp packet to the remote host's echo port. If the echoed packet is received from the remote host and the received packet contains the same data as the packet that was sent, the remote host is considered reachable. This protocol does not require any special privileges. It should be borne in mind that, for a udp ping, a host will be reported as unreachable if it is not running the appropriate echo service. For Unix-like systems see L for more information. If the "icmp" protocol is specified, the ping() method sends an icmp echo message to the remote host, which is what the UNIX ping program does. If the echoed message is received from the remote host and the echoed information is correct, the remote host is considered reachable. Specifying the "icmp" protocol requires that the program be run as root or that the program be setuid to root. If the "external" protocol is specified, the ping() method attempts to use the C module to ping the remote host. C interfaces with your system's default C utility to perform the ping, and generally produces relatively accurate results. If C if not installed on your system, specifying the "external" protocol will result in an error. If the "syn" protocol is specified, the ping() method will only send a TCP SYN packet to the remote host then immediately return. If the syn packet was sent successfully, it will return a true value, otherwise it will return false. NOTE: Unlike the other protocols, the return value does NOT determine if the remote host is alive or not since the full TCP three-way handshake may not have completed yet. The remote host is only considered reachable if it receives a TCP ACK within the timeout specified. To begin waiting for the ACK packets, use the ack() method as explained below. Use the "syn" protocol instead the "tcp" protocol to determine reachability of multiple destinations simultaneously by sending parallel TCP SYN packets. It will not block while testing each remote host. demo/fping is provided in this distribution to demonstrate the "syn" protocol as an example. This protocol does not require any special privileges. =head2 Functions =over 4 =item Net::Ping->new([proto, timeout, bytes, device, tos, ttl, family, host, port, bind, gateway, retrans, pingstring, source_verify econnrefused dontfrag IPV6_USE_MIN_MTU IPV6_RECVPATHMTU]) Create a new ping object. All of the parameters are optional and can be passed as hash ref. All options besides the first 7 must be passed as hash ref. C specifies the protocol to use when doing a ping. The current choices are "tcp", "udp", "icmp", "icmpv6", "stream", "syn", or "external". The default is "tcp". If a C in seconds is provided, it is used when a timeout is not given to the ping() method (below). The timeout must be greater than 0 and the default, if not specified, is 5 seconds. If the number of data bytes (C) is given, that many data bytes are included in the ping packet sent to the remote host. The number of data bytes is ignored if the protocol is "tcp". The minimum (and default) number of data bytes is 1 if the protocol is "udp" and 0 otherwise. The maximum number of data bytes that can be specified is 1024. If C is given, this device is used to bind the source endpoint before sending the ping packet. I believe this only works with superuser privileges and with udp and icmp protocols at this time. If is given, this ToS is configured into the socket. For icmp, C can be specified to set the TTL of the outgoing packet. Valid C values for IPv4: 4, v4, ip4, ipv4, AF_INET (constant) Valid C values for IPv6: 6, v6, ip6, ipv6, AF_INET6 (constant) The C argument implicitly specifies the family if the family argument is not given. The C argument is only valid for a udp, tcp or stream ping, and will not do what you think it does. ping returns true when we get a "Connection refused"! The default is the echo port. The C argument specifies the local_addr to bind to. By specifying a bind argument you don't need the bind method. The C argument is only valid for IPv6, and requires a IPv6 address. The C argument the exponential backoff rate, default 1.2. It matches the $def_factor global. The C argument sets the IP_DONTFRAG bit, but note that IP_DONTFRAG is not yet defined by Socket, and not available on many systems. Then it is ignored. On linux it also sets IP_MTU_DISCOVER to IP_PMTUDISC_DO but need we don't chunk oversized packets. You need to set $data_size manually. =item $p->ping($host [, $timeout [, $family]]); Ping the remote host and wait for a response. $host can be either the hostname or the IP number of the remote host. The optional timeout must be greater than 0 seconds and defaults to whatever was specified when the ping object was created. Returns a success flag. If the hostname cannot be found or there is a problem with the IP number, the success flag returned will be undef. Otherwise, the success flag will be 1 if the host is reachable and 0 if it is not. For most practical purposes, undef and 0 and can be treated as the same case. In array context, the elapsed time as well as the string form of the ip the host resolved to are also returned. The elapsed time value will be a float, as returned by the Time::HiRes::time() function, if hires() has been previously called, otherwise it is returned as an integer. =item $p->source_verify( { 0 | 1 } ); Allows source endpoint verification to be enabled or disabled. This is useful for those remote destinations with multiples interfaces where the response may not originate from the same endpoint that the original destination endpoint was sent to. This only affects udp and icmp protocol pings. This is enabled by default. =item $p->service_check( { 0 | 1 } ); Set whether or not the connect behavior should enforce remote service availability as well as reachability. Normally, if the remote server reported ECONNREFUSED, it must have been reachable because of the status packet that it reported. With this option enabled, the full three-way tcp handshake must have been established successfully before it will claim it is reachable. NOTE: It still does nothing more than connect and disconnect. It does not speak any protocol (i.e., HTTP or FTP) to ensure the remote server is sane in any way. The remote server CPU could be grinding to a halt and unresponsive to any clients connecting, but if the kernel throws the ACK packet, it is considered alive anyway. To really determine if the server is responding well would be application specific and is beyond the scope of Net::Ping. For udp protocol, enabling this option demands that the remote server replies with the same udp data that it was sent as defined by the udp echo service. This affects the "udp", "tcp", and "syn" protocols. This is disabled by default. =item $p->tcp_service_check( { 0 | 1 } ); Deprecated method, but does the same as service_check() method. =item $p->hires( { 0 | 1 } ); With 1 causes this module to use Time::HiRes module, allowing milliseconds to be returned by subsequent calls to ping(). =item $p->time The current time, hires or not. =item $p->socket_blocking_mode( $fh, $mode ); Sets or clears the O_NONBLOCK flag on a file handle. =item $p->IPV6_USE_MIN_MTU With argument sets the option. Without returns the option value. =item $p->IPV6_RECVPATHMTU Notify an according IPv6 MTU. With argument sets the option. Without returns the option value. =item $p->IPV6_HOPLIMIT With argument sets the option. Without returns the option value. =item $p->IPV6_REACHCONF I Sets ipv6 reachability IPV6_REACHCONF was removed in RFC3542. ping6 -R supports it. IPV6_REACHCONF requires root/admin permissions. With argument sets the option. Without returns the option value. Not yet implemented. =item $p->bind($local_addr); Sets the source address from which pings will be sent. This must be the address of one of the interfaces on the local host. $local_addr may be specified as a hostname or as a text IP address such as "192.168.1.1". If the protocol is set to "tcp", this method may be called any number of times, and each call to the ping() method (below) will use the most recent $local_addr. If the protocol is "icmp" or "udp", then bind() must be called at most once per object, and (if it is called at all) must be called before the first call to ping() for that object. The bind() call can be omitted when specifying the C option to new(). =item $p->open($host); When you are using the "stream" protocol, this call pre-opens the tcp socket. It's only necessary to do this if you want to provide a different timeout when creating the connection, or remove the overhead of establishing the connection from the first ping. If you don't call C, the connection is automatically opened the first time C is called. This call simply does nothing if you are using any protocol other than stream. The $host argument can be omitted when specifying the C option to new(). =item $p->ack( [ $host ] ); When using the "syn" protocol, use this method to determine the reachability of the remote host. This method is meant to be called up to as many times as ping() was called. Each call returns the host (as passed to ping()) that came back with the TCP ACK. The order in which the hosts are returned may not necessarily be the same order in which they were SYN queued using the ping() method. If the timeout is reached before the TCP ACK is received, or if the remote host is not listening on the port attempted, then the TCP connection will not be established and ack() will return undef. In list context, the host, the ack time, and the dotted ip string will be returned instead of just the host. If the optional $host argument is specified, the return value will be pertaining to that host only. This call simply does nothing if you are using any protocol other than syn. When new() had a host option, this host will be used. Without host argument, all hosts are scanned. =item $p->nack( $failed_ack_host ); The reason that host $failed_ack_host did not receive a valid ACK. Useful to find out why when ack( $fail_ack_host ) returns a false value. =item $p->ack_unfork($host) The variant called by ack() with the syn protocol and $syn_forking enabled. =item $p->ping_icmp([$host, $timeout, $family]) The ping() method used with the icmp protocol. =item $p->ping_icmpv6([$host, $timeout, $family]) I The ping() method used with the icmpv6 protocol. =item $p->ping_stream([$host, $timeout, $family]) The ping() method used with the stream protocol. Perform a stream ping. If the tcp connection isn't already open, it opens it. It then sends some data and waits for a reply. It leaves the stream open on exit. =item $p->ping_syn([$host, $ip, $start_time, $stop_time]) The ping() method used with the syn protocol. Sends a TCP SYN packet to host specified. =item $p->ping_syn_fork([$host, $timeout, $family]) The ping() method used with the forking syn protocol. =item $p->ping_tcp([$host, $timeout, $family]) The ping() method used with the tcp protocol. =item $p->ping_udp([$host, $timeout, $family]) The ping() method used with the udp protocol. Perform a udp echo ping. Construct a message of at least the one-byte sequence number and any additional data bytes. Send the message out and wait for a message to come back. If we get a message, make sure all of its parts match. If they do, we are done. Otherwise go back and wait for the message until we run out of time. Return the result of our efforts. =item $p->ping_external([$host, $timeout, $family]) The ping() method used with the external protocol. Uses Net::Ping::External to do an external ping. =item $p->tcp_connect([$ip, $timeout]) Initiates a TCP connection, for a tcp ping. =item $p->tcp_echo([$ip, $timeout, $pingstring]) Performs a TCP echo. It writes the given string to the socket and then reads it back. It returns 1 on success, 0 on failure. =item $p->close(); Close the network connection for this ping object. The network connection is also closed by "undef $p". The network connection is automatically closed if the ping object goes out of scope (e.g. $p is local to a subroutine and you leave the subroutine). =item $p->port_number([$port_number]) When called with a port number, the port number used to ping is set to $port_number rather than using the echo port. It also has the effect of calling C<$p-Eservice_check(1)> causing a ping to return a successful response only if that specific port is accessible. This function returns the value of the port that C will connect to. =item $p->mselect A select() wrapper that compensates for platform peculiarities. =item $p->ntop Platform abstraction over inet_ntop() =item $p->checksum($msg) Do a checksum on the message. Basically sum all of the short words and fold the high order bits into the low order bits. =item $p->icmp_result Returns a list of addr, type, subcode. =item pingecho($host [, $timeout]); To provide backward compatibility with the previous version of Net::Ping, a pingecho() subroutine is available with the same functionality as before. pingecho() uses the tcp protocol. The return values and parameters are the same as described for the ping() method. This subroutine is obsolete and may be removed in a future version of Net::Ping. =item wakeonlan($mac, [$host, [$port]]) Emit the popular wake-on-lan magic udp packet to wake up a local device. See also L, but this has the mac address as 1st arg. $host should be the local gateway. Without it will broadcast. Default host: '255.255.255.255' Default port: 9 perl -MNet::Ping=wakeonlan -e'wakeonlan "e0:69:95:35:68:d2"' =back =head1 NOTES There will be less network overhead (and some efficiency in your program) if you specify either the udp or the icmp protocol. The tcp protocol will generate 2.5 times or more traffic for each ping than either udp or icmp. If many hosts are pinged frequently, you may wish to implement a small wait (e.g. 25ms or more) between each ping to avoid flooding your network with packets. The icmp and icmpv6 protocols requires that the program be run as root or that it be setuid to root. The other protocols do not require special privileges, but not all network devices implement tcp or udp echo. Local hosts should normally respond to pings within milliseconds. However, on a very congested network it may take up to 3 seconds or longer to receive an echo packet from the remote host. If the timeout is set too low under these conditions, it will appear that the remote host is not reachable (which is almost the truth). Reachability doesn't necessarily mean that the remote host is actually functioning beyond its ability to echo packets. tcp is slightly better at indicating the health of a system than icmp because it uses more of the networking stack to respond. Because of a lack of anything better, this module uses its own routines to pack and unpack ICMP packets. It would be better for a separate module to be written which understands all of the different kinds of ICMP packets. =head1 INSTALL The latest source tree is available via git: git clone https://github.com/rurban/net-ping.git Net-Ping cd Net-Ping The tarball can be created as follows: perl Makefile.PL ; make ; make dist The latest Net::Ping releases are included in cperl and perl5. =head1 BUGS For a list of known issues, visit: L To report a new bug, visit: L (stale) or call: perlbug resp.: cperlbug =head1 AUTHORS Current maintainers: perl11 (for cperl, with IPv6 support and more) p5p (for perl5) Previous maintainers: bbb@cpan.org (Rob Brown) Steve Peters External protocol: colinm@cpan.org (Colin McMillen) Stream protocol: bronson@trestle.com (Scott Bronson) Wake-on-lan: 1999-2003 Clinton Wong Original pingecho(): karrer@bernina.ethz.ch (Andreas Karrer) pmarquess@bfsec.bt.co.uk (Paul Marquess) Original Net::Ping author: mose@ns.ccsn.edu (Russell Mosemann) =head1 COPYRIGHT Copyright (c) 2016, cPanel Inc. All rights reserved. Copyright (c) 2012, Steve Peters. All rights reserved. Copyright (c) 2002-2003, Rob Brown. All rights reserved. Copyright (c) 2001, Colin McMillen. All rights reserved. This program is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =cut protoent.pm000064400000005735152342707210006771 0ustar00package Net::protoent; use strict; use 5.006_001; our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); @EXPORT = qw(getprotobyname getprotobynumber getprotoent getproto); @EXPORT_OK = qw( $p_name @p_aliases $p_proto ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } use vars @EXPORT_OK; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } use Class::Struct qw(struct); struct 'Net::protoent' => [ name => '$', aliases => '@', proto => '$', ]; sub populate (@) { return unless @_; my $pob = new(); $p_name = $pob->[0] = $_[0]; @p_aliases = @{ $pob->[1] } = split ' ', $_[1]; $p_proto = $pob->[2] = $_[2]; return $pob; } sub getprotoent ( ) { populate(CORE::getprotoent()) } sub getprotobyname ($) { populate(CORE::getprotobyname(shift)) } sub getprotobynumber ($) { populate(CORE::getprotobynumber(shift)) } sub getproto ($;$) { no strict 'refs'; return &{'getprotoby' . ($_[0]=~/^\d+$/ ? 'number' : 'name')}(@_); } 1; __END__ =head1 NAME Net::protoent - by-name interface to Perl's built-in getproto*() functions =head1 SYNOPSIS use Net::protoent; $p = getprotobyname(shift || 'tcp') || die "no proto"; printf "proto for %s is %d, aliases are %s\n", $p->name, $p->proto, "@{$p->aliases}"; use Net::protoent qw(:FIELDS); getprotobyname(shift || 'tcp') || die "no proto"; print "proto for $p_name is $p_proto, aliases are @p_aliases\n"; =head1 DESCRIPTION This module's default exports override the core getprotoent(), getprotobyname(), and getnetbyport() functions, replacing them with versions that return "Net::protoent" objects. They take default second arguments of "tcp". This object has methods that return the similarly named structure field name from the C's protoent structure from F; namely name, aliases, and proto. The aliases method returns an array reference, the rest scalars. You may also import all the structure fields directly into your namespace as regular variables using the :FIELDS import tag. (Note that this still overrides your core functions.) Access these fields as variables named with a preceding C. Thus, C<$proto_obj-Ename()> corresponds to $p_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $proto_obj-Ealiases() }> would be simply @p_aliases. The getproto() function is a simple front-end that forwards a numeric argument to getprotobyport(), and the rest to getprotobyname(). To access this functionality without the core overrides, pass the C an empty import list, and then access function functions with their full qualified names. On the other hand, the built-ins are still available via the C pseudo-package. =head1 NOTE While this class is currently implemented using the Class::Struct module to build a struct-like class, you shouldn't rely upon this. =head1 AUTHOR Tom Christiansen netent.pm000064400000010601152342707210006400 0ustar00package Net::netent; use strict; use 5.006_001; our $VERSION = '1.00'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); @EXPORT = qw(getnetbyname getnetbyaddr getnet); @EXPORT_OK = qw( $n_name @n_aliases $n_addrtype $n_net ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } use vars @EXPORT_OK; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } use Class::Struct qw(struct); struct 'Net::netent' => [ name => '$', aliases => '@', addrtype => '$', net => '$', ]; sub populate (@) { return unless @_; my $nob = new(); $n_name = $nob->[0] = $_[0]; @n_aliases = @{ $nob->[1] } = split ' ', $_[1]; $n_addrtype = $nob->[2] = $_[2]; $n_net = $nob->[3] = $_[3]; return $nob; } sub getnetbyname ($) { populate(CORE::getnetbyname(shift)) } sub getnetbyaddr ($;$) { my ($net, $addrtype); $net = shift; require Socket if @_; $addrtype = @_ ? shift : Socket::AF_INET(); populate(CORE::getnetbyaddr($net, $addrtype)) } sub getnet($) { if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { require Socket; &getnetbyaddr(Socket::inet_aton(shift)); } else { &getnetbyname; } } 1; __END__ =head1 NAME Net::netent - by-name interface to Perl's built-in getnet*() functions =head1 SYNOPSIS use Net::netent qw(:FIELDS); getnetbyname("loopback") or die "bad net"; printf "%s is %08X\n", $n_name, $n_net; use Net::netent; $n = getnetbyname("loopback") or die "bad net"; { # there's gotta be a better way, eh? @bytes = unpack("C4", pack("N", $n->net)); shift @bytes while @bytes && $bytes[0] == 0; } printf "%s is %08X [%d.%d.%d.%d]\n", $n->name, $n->net, @bytes; =head1 DESCRIPTION This module's default exports override the core getnetbyname() and getnetbyaddr() functions, replacing them with versions that return "Net::netent" objects. This object has methods that return the similarly named structure field name from the C's netent structure from F; namely name, aliases, addrtype, and net. The aliases method returns an array reference, the rest scalars. You may also import all the structure fields directly into your namespace as regular variables using the :FIELDS import tag. (Note that this still overrides your core functions.) Access these fields as variables named with a preceding C. Thus, C<$net_obj-Ename()> corresponds to $n_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $net_obj-Ealiases() }> would be simply @n_aliases. The getnet() function is a simple front-end that forwards a numeric argument to getnetbyaddr(), and the rest to getnetbyname(). To access this functionality without the core overrides, pass the C an empty import list, and then access function functions with their full qualified names. On the other hand, the built-ins are still available via the C pseudo-package. =head1 EXAMPLES The getnet() functions do this in the Perl core: sv_setiv(sv, (I32)nent->n_net); The gethost() functions do this in the Perl core: sv_setpvn(sv, hent->h_addr, len); That means that the address comes back in binary for the host functions, and as a regular perl integer for the net ones. This seems a bug, but here's how to deal with it: use strict; use Socket; use Net::netent; @ARGV = ('loopback') unless @ARGV; my($n, $net); for $net ( @ARGV ) { unless ($n = getnetbyname($net)) { warn "$0: no such net: $net\n"; next; } printf "\n%s is %s%s\n", $net, lc($n->name) eq lc($net) ? "" : "*really* ", $n->name; print "\taliases are ", join(", ", @{$n->aliases}), "\n" if @{$n->aliases}; # this is stupid; first, why is this not in binary? # second, why am i going through these convolutions # to make it looks right { my @a = unpack("C4", pack("N", $n->net)); shift @a while @a && $a[0] == 0; printf "\taddr is %s [%d.%d.%d.%d]\n", $n->net, @a; } if ($n = getnetbyaddr($n->net)) { if (lc($n->name) ne lc($net)) { printf "\tThat addr reverses to net %s!\n", $n->name; $net = $n->name; redo; } } } =head1 NOTE While this class is currently implemented using the Class::Struct module to build a struct-like class, you shouldn't rely upon this. =head1 AUTHOR Tom Christiansen hostent.pm000064400000007661152342707210006603 0ustar00package Net::hostent; use strict; use 5.006_001; our $VERSION = '1.01'; our(@EXPORT, @EXPORT_OK, %EXPORT_TAGS); BEGIN { use Exporter (); @EXPORT = qw(gethostbyname gethostbyaddr gethost); @EXPORT_OK = qw( $h_name @h_aliases $h_addrtype $h_length @h_addr_list $h_addr ); %EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] ); } use vars @EXPORT_OK; # Class::Struct forbids use of @ISA sub import { goto &Exporter::import } use Class::Struct qw(struct); struct 'Net::hostent' => [ name => '$', aliases => '@', addrtype => '$', 'length' => '$', addr_list => '@', ]; sub addr { shift->addr_list->[0] } sub populate (@) { return unless @_; my $hob = new(); $h_name = $hob->[0] = $_[0]; @h_aliases = @{ $hob->[1] } = split ' ', $_[1]; $h_addrtype = $hob->[2] = $_[2]; $h_length = $hob->[3] = $_[3]; $h_addr = $_[4]; @h_addr_list = @{ $hob->[4] } = @_[ (4 .. $#_) ]; return $hob; } sub gethostbyname ($) { populate(CORE::gethostbyname(shift)) } sub gethostbyaddr ($;$) { my ($addr, $addrtype); $addr = shift; require Socket unless @_; $addrtype = @_ ? shift : Socket::AF_INET(); populate(CORE::gethostbyaddr($addr, $addrtype)) } sub gethost($) { if ($_[0] =~ /^\d+(?:\.\d+(?:\.\d+(?:\.\d+)?)?)?$/) { require Socket; &gethostbyaddr(Socket::inet_aton(shift)); } else { &gethostbyname; } } 1; __END__ =head1 NAME Net::hostent - by-name interface to Perl's built-in gethost*() functions =head1 SYNOPSIS use Net::hostent; =head1 DESCRIPTION This module's default exports override the core gethostbyname() and gethostbyaddr() functions, replacing them with versions that return "Net::hostent" objects. This object has methods that return the similarly named structure field name from the C's hostent structure from F; namely name, aliases, addrtype, length, and addr_list. The aliases and addr_list methods return array reference, the rest scalars. The addr method is equivalent to the zeroth element in the addr_list array reference. You may also import all the structure fields directly into your namespace as regular variables using the :FIELDS import tag. (Note that this still overrides your core functions.) Access these fields as variables named with a preceding C. Thus, C<$host_obj-Ename()> corresponds to $h_name if you import the fields. Array references are available as regular array variables, so for example C<@{ $host_obj-Ealiases() }> would be simply @h_aliases. The gethost() function is a simple front-end that forwards a numeric argument to gethostbyaddr() by way of Socket::inet_aton, and the rest to gethostbyname(). To access this functionality without the core overrides, pass the C an empty import list, and then access function functions with their full qualified names. On the other hand, the built-ins are still available via the C pseudo-package. =head1 EXAMPLES use Net::hostent; use Socket; @ARGV = ('netscape.com') unless @ARGV; for $host ( @ARGV ) { unless ($h = gethost($host)) { warn "$0: no such host: $host\n"; next; } printf "\n%s is %s%s\n", $host, lc($h->name) eq lc($host) ? "" : "*really* ", $h->name; print "\taliases are ", join(", ", @{$h->aliases}), "\n" if @{$h->aliases}; if ( @{$h->addr_list} > 1 ) { my $i; for $addr ( @{$h->addr_list} ) { printf "\taddr #%d is [%s]\n", $i++, inet_ntoa($addr); } } else { printf "\taddress is [%s]\n", inet_ntoa($h->addr); } if ($h = gethostbyaddr($h->addr)) { if (lc($h->name) ne lc($host)) { printf "\tThat addr reverses to host %s!\n", $h->name; $host = $h->name; redo; } } } =head1 NOTE While this class is currently implemented using the Class::Struct module to build a struct-like class, you shouldn't rely upon this. =head1 AUTHOR Tom Christiansen SSLeay.pm000064400000163424152344764300006264 0ustar00# Net::SSLeay.pm - Perl module for using Eric Young's implementation of SSL # # Copyright (c) 1996-2003 Sampo Kellomäki # Copyright (c) 2005-2010 Florian Ragwitz # Copyright (c) 2005-2018 Mike McCauley # Copyright (c) 2018- Chris Novakovic # Copyright (c) 2018- Tuure Vartiainen # Copyright (c) 2018- Heikki Vatiainen # # All rights reserved. # # This module is released under the terms of the Artistic License 2.0. For # details, see the LICENSE file distributed with Net-SSLeay's source code. package Net::SSLeay; use 5.8.1; use strict; use Carp; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $CRLF); use Socket; use Errno; require Exporter; use AutoLoader; # 0=no warns, 1=only errors, 2=ciphers, 3=progress, 4=dump data $Net::SSLeay::trace = 0; # Do not change here, use # $Net::SSLeay::trace = [1-4] in caller # 2 = insist on v2 SSL protocol # 3 = insist on v3 SSL # 10 = insist on TLSv1 # 11 = insist on TLSv1.1 # 12 = insist on TLSv1.2 # 13 = insist on TLSv1.3 # 0 or undef = guess (v23) # $Net::SSLeay::ssl_version = 0; # don't change here, use # Net::SSLeay::version=[2,3,0] in caller #define to enable the "cat /proc/$$/stat" stuff $Net::SSLeay::linux_debug = 0; # Number of seconds to sleep after sending message and before half # closing connection. Useful with antiquated broken servers. $Net::SSLeay::slowly = 0; # RANDOM NUMBER INITIALIZATION # # Edit to your taste. Using /dev/random would be more secure, but may # block if randomness is not available, thus the default is # /dev/urandom. $how_random determines how many bits of randomness to take # from the device. You should take enough (read SSLeay/doc/rand), but # beware that randomness is limited resource so you should not waste # it either or you may end up with randomness depletion (situation where # /dev/random would block and /dev/urandom starts to return predictable # numbers). # # N.B. /dev/urandom does not exist on all systems, such as Solaris 2.6. In that # case you should get a third party package that emulates /dev/urandom # (e.g. via named pipe) or supply a random number file. Some such # packages are documented in Caveat section of the POD documentation. $Net::SSLeay::random_device = '/dev/urandom'; $Net::SSLeay::how_random = 512; $VERSION = '1.88'; # Also update $Net::SSLeay::Handle::VERSION @ISA = qw(Exporter); #BEWARE: # 3-columns part of @EXPORT_OK related to constants is the output of command: # perl helper_script/regen_openssl_constants.pl -gen-pod # if you add/remove any constant you need to update it manually @EXPORT_OK = qw( ASN1_STRFLGS_ESC_CTRL NID_netscape R_UNKNOWN_REMOTE_ERROR_TYPE ASN1_STRFLGS_ESC_MSB NID_netscape_base_url R_UNKNOWN_STATE ASN1_STRFLGS_ESC_QUOTE NID_netscape_ca_policy_url R_X509_LIB ASN1_STRFLGS_RFC2253 NID_netscape_ca_revocation_url SENT_SHUTDOWN CB_ACCEPT_EXIT NID_netscape_cert_extension SESSION_ASN1_VERSION CB_ACCEPT_LOOP NID_netscape_cert_sequence SESS_CACHE_BOTH CB_ALERT NID_netscape_cert_type SESS_CACHE_CLIENT CB_CONNECT_EXIT NID_netscape_comment SESS_CACHE_NO_AUTO_CLEAR CB_CONNECT_LOOP NID_netscape_data_type SESS_CACHE_NO_INTERNAL CB_EXIT NID_netscape_renewal_url SESS_CACHE_NO_INTERNAL_LOOKUP CB_HANDSHAKE_DONE NID_netscape_revocation_url SESS_CACHE_NO_INTERNAL_STORE CB_HANDSHAKE_START NID_netscape_ssl_server_name SESS_CACHE_OFF CB_LOOP NID_ns_sgc SESS_CACHE_SERVER CB_READ NID_organizationName SSL3_VERSION CB_READ_ALERT NID_organizationalUnitName SSLEAY_BUILT_ON CB_WRITE NID_pbeWithMD2AndDES_CBC SSLEAY_CFLAGS CB_WRITE_ALERT NID_pbeWithMD2AndRC2_CBC SSLEAY_DIR ERROR_NONE NID_pbeWithMD5AndCast5_CBC SSLEAY_PLATFORM ERROR_SSL NID_pbeWithMD5AndDES_CBC SSLEAY_VERSION ERROR_SYSCALL NID_pbeWithMD5AndRC2_CBC ST_ACCEPT ERROR_WANT_ACCEPT NID_pbeWithSHA1AndDES_CBC ST_BEFORE ERROR_WANT_CONNECT NID_pbeWithSHA1AndRC2_CBC ST_CONNECT ERROR_WANT_READ NID_pbe_WithSHA1And128BitRC2_CBC ST_INIT ERROR_WANT_WRITE NID_pbe_WithSHA1And128BitRC4 ST_OK ERROR_WANT_X509_LOOKUP NID_pbe_WithSHA1And2_Key_TripleDES_CBC ST_READ_BODY ERROR_ZERO_RETURN NID_pbe_WithSHA1And3_Key_TripleDES_CBC ST_READ_HEADER EVP_PKS_DSA NID_pbe_WithSHA1And40BitRC2_CBC TLS1_1_VERSION EVP_PKS_EC NID_pbe_WithSHA1And40BitRC4 TLS1_2_VERSION EVP_PKS_RSA NID_pbes2 TLS1_3_VERSION EVP_PKT_ENC NID_pbmac1 TLS1_VERSION EVP_PKT_EXCH NID_pkcs TLSEXT_STATUSTYPE_ocsp EVP_PKT_EXP NID_pkcs3 VERIFY_CLIENT_ONCE EVP_PKT_SIGN NID_pkcs7 VERIFY_FAIL_IF_NO_PEER_CERT EVP_PK_DH NID_pkcs7_data VERIFY_NONE EVP_PK_DSA NID_pkcs7_digest VERIFY_PEER EVP_PK_EC NID_pkcs7_encrypted VERIFY_POST_HANDSHAKE EVP_PK_RSA NID_pkcs7_enveloped V_OCSP_CERTSTATUS_GOOD FILETYPE_ASN1 NID_pkcs7_signed V_OCSP_CERTSTATUS_REVOKED FILETYPE_PEM NID_pkcs7_signedAndEnveloped V_OCSP_CERTSTATUS_UNKNOWN F_CLIENT_CERTIFICATE NID_pkcs8ShroudedKeyBag WRITING F_CLIENT_HELLO NID_pkcs9 X509_CHECK_FLAG_ALWAYS_CHECK_SUBJECT F_CLIENT_MASTER_KEY NID_pkcs9_challengePassword X509_CHECK_FLAG_MULTI_LABEL_WILDCARDS F_D2I_SSL_SESSION NID_pkcs9_contentType X509_CHECK_FLAG_NEVER_CHECK_SUBJECT F_GET_CLIENT_FINISHED NID_pkcs9_countersignature X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS F_GET_CLIENT_HELLO NID_pkcs9_emailAddress X509_CHECK_FLAG_NO_WILDCARDS F_GET_CLIENT_MASTER_KEY NID_pkcs9_extCertAttributes X509_CHECK_FLAG_SINGLE_LABEL_SUBDOMAINS F_GET_SERVER_FINISHED NID_pkcs9_messageDigest X509_FILETYPE_ASN1 F_GET_SERVER_HELLO NID_pkcs9_signingTime X509_FILETYPE_DEFAULT F_GET_SERVER_VERIFY NID_pkcs9_unstructuredAddress X509_FILETYPE_PEM F_I2D_SSL_SESSION NID_pkcs9_unstructuredName X509_LOOKUP F_READ_N NID_private_key_usage_period X509_PURPOSE_ANY F_REQUEST_CERTIFICATE NID_rc2_40_cbc X509_PURPOSE_CRL_SIGN F_SERVER_HELLO NID_rc2_64_cbc X509_PURPOSE_NS_SSL_SERVER F_SSL_CERT_NEW NID_rc2_cbc X509_PURPOSE_OCSP_HELPER F_SSL_GET_NEW_SESSION NID_rc2_cfb64 X509_PURPOSE_SMIME_ENCRYPT F_SSL_NEW NID_rc2_ecb X509_PURPOSE_SMIME_SIGN F_SSL_READ NID_rc2_ofb64 X509_PURPOSE_SSL_CLIENT F_SSL_RSA_PRIVATE_DECRYPT NID_rc4 X509_PURPOSE_SSL_SERVER F_SSL_RSA_PUBLIC_ENCRYPT NID_rc4_40 X509_PURPOSE_TIMESTAMP_SIGN F_SSL_SESSION_NEW NID_rc5_cbc X509_TRUST_COMPAT F_SSL_SESSION_PRINT_FP NID_rc5_cfb64 X509_TRUST_EMAIL F_SSL_SET_FD NID_rc5_ecb X509_TRUST_OBJECT_SIGN F_SSL_SET_RFD NID_rc5_ofb64 X509_TRUST_OCSP_REQUEST F_SSL_SET_WFD NID_ripemd160 X509_TRUST_OCSP_SIGN F_SSL_USE_CERTIFICATE NID_ripemd160WithRSA X509_TRUST_SSL_CLIENT F_SSL_USE_CERTIFICATE_ASN1 NID_rle_compression X509_TRUST_SSL_SERVER F_SSL_USE_CERTIFICATE_FILE NID_rsa X509_TRUST_TSA F_SSL_USE_PRIVATEKEY NID_rsaEncryption X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH F_SSL_USE_PRIVATEKEY_ASN1 NID_rsadsi X509_V_ERR_AKID_SKID_MISMATCH F_SSL_USE_PRIVATEKEY_FILE NID_safeContentsBag X509_V_ERR_APPLICATION_VERIFICATION F_SSL_USE_RSAPRIVATEKEY NID_sdsiCertificate X509_V_ERR_CA_KEY_TOO_SMALL F_SSL_USE_RSAPRIVATEKEY_ASN1 NID_secretBag X509_V_ERR_CA_MD_TOO_WEAK F_SSL_USE_RSAPRIVATEKEY_FILE NID_serialNumber X509_V_ERR_CERT_CHAIN_TOO_LONG F_WRITE_PENDING NID_server_auth X509_V_ERR_CERT_HAS_EXPIRED GEN_DIRNAME NID_sha X509_V_ERR_CERT_NOT_YET_VALID GEN_DNS NID_sha1 X509_V_ERR_CERT_REJECTED GEN_EDIPARTY NID_sha1WithRSA X509_V_ERR_CERT_REVOKED GEN_EMAIL NID_sha1WithRSAEncryption X509_V_ERR_CERT_SIGNATURE_FAILURE GEN_IPADD NID_shaWithRSAEncryption X509_V_ERR_CERT_UNTRUSTED GEN_OTHERNAME NID_stateOrProvinceName X509_V_ERR_CRL_HAS_EXPIRED GEN_RID NID_subject_alt_name X509_V_ERR_CRL_NOT_YET_VALID GEN_URI NID_subject_key_identifier X509_V_ERR_CRL_PATH_VALIDATION_ERROR GEN_X400 NID_surname X509_V_ERR_CRL_SIGNATURE_FAILURE LIBRESSL_VERSION_NUMBER NID_sxnet X509_V_ERR_DANE_NO_MATCH MBSTRING_ASC NID_time_stamp X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT MBSTRING_BMP NID_title X509_V_ERR_DIFFERENT_CRL_SCOPE MBSTRING_FLAG NID_undef X509_V_ERR_EE_KEY_TOO_SMALL MBSTRING_UNIV NID_uniqueIdentifier X509_V_ERR_EMAIL_MISMATCH MBSTRING_UTF8 NID_x509Certificate X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD MIN_RSA_MODULUS_LENGTH_IN_BYTES NID_x509Crl X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD MODE_ACCEPT_MOVING_WRITE_BUFFER NID_zlib_compression X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD MODE_AUTO_RETRY NOTHING X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD MODE_ENABLE_PARTIAL_WRITE OCSP_RESPONSE_STATUS_INTERNALERROR X509_V_ERR_EXCLUDED_VIOLATION MODE_RELEASE_BUFFERS OCSP_RESPONSE_STATUS_MALFORMEDREQUEST X509_V_ERR_HOSTNAME_MISMATCH NID_OCSP_sign OCSP_RESPONSE_STATUS_SIGREQUIRED X509_V_ERR_INVALID_CA NID_SMIMECapabilities OCSP_RESPONSE_STATUS_SUCCESSFUL X509_V_ERR_INVALID_CALL NID_X500 OCSP_RESPONSE_STATUS_TRYLATER X509_V_ERR_INVALID_EXTENSION NID_X509 OCSP_RESPONSE_STATUS_UNAUTHORIZED X509_V_ERR_INVALID_NON_CA NID_ad_OCSP OPENSSL_BUILT_ON X509_V_ERR_INVALID_POLICY_EXTENSION NID_ad_ca_issuers OPENSSL_CFLAGS X509_V_ERR_INVALID_PURPOSE NID_algorithm OPENSSL_DIR X509_V_ERR_IP_ADDRESS_MISMATCH NID_authority_key_identifier OPENSSL_ENGINES_DIR X509_V_ERR_KEYUSAGE_NO_CERTSIGN NID_basic_constraints OPENSSL_PLATFORM X509_V_ERR_KEYUSAGE_NO_CRL_SIGN NID_bf_cbc OPENSSL_VERSION X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE NID_bf_cfb64 OPENSSL_VERSION_NUMBER X509_V_ERR_NO_EXPLICIT_POLICY NID_bf_ecb OP_ALL X509_V_ERR_NO_VALID_SCTS NID_bf_ofb64 OP_ALLOW_NO_DHE_KEX X509_V_ERR_OCSP_CERT_UNKNOWN NID_cast5_cbc OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION X509_V_ERR_OCSP_VERIFY_FAILED NID_cast5_cfb64 OP_CIPHER_SERVER_PREFERENCE X509_V_ERR_OCSP_VERIFY_NEEDED NID_cast5_ecb OP_CISCO_ANYCONNECT X509_V_ERR_OUT_OF_MEM NID_cast5_ofb64 OP_COOKIE_EXCHANGE X509_V_ERR_PATH_LENGTH_EXCEEDED NID_certBag OP_CRYPTOPRO_TLSEXT_BUG X509_V_ERR_PATH_LOOP NID_certificate_policies OP_DONT_INSERT_EMPTY_FRAGMENTS X509_V_ERR_PERMITTED_VIOLATION NID_client_auth OP_ENABLE_MIDDLEBOX_COMPAT X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED NID_code_sign OP_EPHEMERAL_RSA X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED NID_commonName OP_LEGACY_SERVER_CONNECT X509_V_ERR_PROXY_SUBJECT_NAME_VIOLATION NID_countryName OP_MICROSOFT_BIG_SSLV3_BUFFER X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN NID_crlBag OP_MICROSOFT_SESS_ID_BUG X509_V_ERR_STORE_LOOKUP NID_crl_distribution_points OP_MSIE_SSLV2_RSA_PADDING X509_V_ERR_SUBJECT_ISSUER_MISMATCH NID_crl_number OP_NETSCAPE_CA_DN_BUG X509_V_ERR_SUBTREE_MINMAX NID_crl_reason OP_NETSCAPE_CHALLENGE_BUG X509_V_ERR_SUITE_B_CANNOT_SIGN_P_384_WITH_P_256 NID_delta_crl OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG X509_V_ERR_SUITE_B_INVALID_ALGORITHM NID_des_cbc OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG X509_V_ERR_SUITE_B_INVALID_CURVE NID_des_cfb64 OP_NON_EXPORT_FIRST X509_V_ERR_SUITE_B_INVALID_SIGNATURE_ALGORITHM NID_des_ecb OP_NO_ANTI_REPLAY X509_V_ERR_SUITE_B_INVALID_VERSION NID_des_ede OP_NO_CLIENT_RENEGOTIATION X509_V_ERR_SUITE_B_LOS_NOT_ALLOWED NID_des_ede3 OP_NO_COMPRESSION X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY NID_des_ede3_cbc OP_NO_ENCRYPT_THEN_MAC X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE NID_des_ede3_cfb64 OP_NO_QUERY_MTU X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE NID_des_ede3_ofb64 OP_NO_RENEGOTIATION X509_V_ERR_UNABLE_TO_GET_CRL NID_des_ede_cbc OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER NID_des_ede_cfb64 OP_NO_SSL_MASK X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT NID_des_ede_ofb64 OP_NO_SSLv2 X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY NID_des_ofb64 OP_NO_SSLv3 X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE NID_description OP_NO_TICKET X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION NID_desx_cbc OP_NO_TLSv1 X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION NID_dhKeyAgreement OP_NO_TLSv1_1 X509_V_ERR_UNNESTED_RESOURCE NID_dnQualifier OP_NO_TLSv1_2 X509_V_ERR_UNSPECIFIED NID_dsa OP_NO_TLSv1_3 X509_V_ERR_UNSUPPORTED_CONSTRAINT_SYNTAX NID_dsaWithSHA OP_PKCS1_CHECK_1 X509_V_ERR_UNSUPPORTED_CONSTRAINT_TYPE NID_dsaWithSHA1 OP_PKCS1_CHECK_2 X509_V_ERR_UNSUPPORTED_EXTENSION_FEATURE NID_dsaWithSHA1_2 OP_PRIORITIZE_CHACHA X509_V_ERR_UNSUPPORTED_NAME_SYNTAX NID_dsa_2 OP_SAFARI_ECDHE_ECDSA_BUG X509_V_FLAG_ALLOW_PROXY_CERTS NID_email_protect OP_SINGLE_DH_USE X509_V_FLAG_CB_ISSUER_CHECK NID_ext_key_usage OP_SINGLE_ECDH_USE X509_V_FLAG_CHECK_SS_SIGNATURE NID_ext_req OP_SSLEAY_080_CLIENT_DH_BUG X509_V_FLAG_CRL_CHECK NID_friendlyName OP_SSLREF2_REUSE_CERT_TYPE_BUG X509_V_FLAG_CRL_CHECK_ALL NID_givenName OP_TLSEXT_PADDING X509_V_FLAG_EXPLICIT_POLICY NID_hmacWithSHA1 OP_TLS_BLOCK_PADDING_BUG X509_V_FLAG_EXTENDED_CRL_SUPPORT NID_id_ad OP_TLS_D5_BUG X509_V_FLAG_IGNORE_CRITICAL NID_id_ce OP_TLS_ROLLBACK_BUG X509_V_FLAG_INHIBIT_ANY NID_id_kp READING X509_V_FLAG_INHIBIT_MAP NID_id_pbkdf2 RECEIVED_SHUTDOWN X509_V_FLAG_NOTIFY_POLICY NID_id_pe RSA_3 X509_V_FLAG_NO_ALT_CHAINS NID_id_pkix RSA_F4 X509_V_FLAG_NO_CHECK_TIME NID_id_qt_cps R_BAD_AUTHENTICATION_TYPE X509_V_FLAG_PARTIAL_CHAIN NID_id_qt_unotice R_BAD_CHECKSUM X509_V_FLAG_POLICY_CHECK NID_idea_cbc R_BAD_MAC_DECODE X509_V_FLAG_POLICY_MASK NID_idea_cfb64 R_BAD_RESPONSE_ARGUMENT X509_V_FLAG_SUITEB_128_LOS NID_idea_ecb R_BAD_SSL_FILETYPE X509_V_FLAG_SUITEB_128_LOS_ONLY NID_idea_ofb64 R_BAD_SSL_SESSION_ID_LENGTH X509_V_FLAG_SUITEB_192_LOS NID_info_access R_BAD_STATE X509_V_FLAG_TRUSTED_FIRST NID_initials R_BAD_WRITE_RETRY X509_V_FLAG_USE_CHECK_TIME NID_invalidity_date R_CHALLENGE_IS_DIFFERENT X509_V_FLAG_USE_DELTAS NID_issuer_alt_name R_CIPHER_TABLE_SRC_ERROR X509_V_FLAG_X509_STRICT NID_keyBag R_INVALID_CHALLENGE_LENGTH X509_V_OK NID_key_usage R_NO_CERTIFICATE_SET XN_FLAG_COMPAT NID_localKeyID R_NO_CERTIFICATE_SPECIFIED XN_FLAG_DN_REV NID_localityName R_NO_CIPHER_LIST XN_FLAG_DUMP_UNKNOWN_FIELDS NID_md2 R_NO_CIPHER_MATCH XN_FLAG_FN_ALIGN NID_md2WithRSAEncryption R_NO_PRIVATEKEY XN_FLAG_FN_LN NID_md5 R_NO_PUBLICKEY XN_FLAG_FN_MASK NID_md5WithRSA R_NULL_SSL_CTX XN_FLAG_FN_NONE NID_md5WithRSAEncryption R_PEER_DID_NOT_RETURN_A_CERTIFICATE XN_FLAG_FN_OID NID_md5_sha1 R_PEER_ERROR XN_FLAG_FN_SN NID_mdc2 R_PEER_ERROR_CERTIFICATE XN_FLAG_MULTILINE NID_mdc2WithRSA R_PEER_ERROR_NO_CIPHER XN_FLAG_ONELINE NID_ms_code_com R_PEER_ERROR_UNSUPPORTED_CERTIFICATE_TYPE XN_FLAG_RFC2253 NID_ms_code_ind R_PUBLIC_KEY_ENCRYPT_ERROR XN_FLAG_SEP_COMMA_PLUS NID_ms_ctl_sign R_PUBLIC_KEY_IS_NOT_RSA XN_FLAG_SEP_CPLUS_SPC NID_ms_efs R_READ_WRONG_PACKET_TYPE XN_FLAG_SEP_MASK NID_ms_ext_req R_SHORT_READ XN_FLAG_SEP_MULTILINE NID_ms_sgc R_SSL_SESSION_ID_IS_DIFFERENT XN_FLAG_SEP_SPLUS_SPC NID_name R_UNABLE_TO_EXTRACT_PUBLIC_KEY XN_FLAG_SPC_EQ BIO_eof BIO_f_ssl BIO_free BIO_new BIO_new_file BIO_pending BIO_read BIO_s_mem BIO_wpending BIO_write CTX_free CTX_get_cert_store CTX_new CTX_use_RSAPrivateKey_file CTX_use_certificate_file CTX_v23_new CTX_v2_new CTX_v3_new ERR_error_string ERR_get_error ERR_load_RAND_strings ERR_load_SSL_strings PEM_read_bio_X509_CRL RSA_free RSA_generate_key SESSION SESSION_free SESSION_get_master_key SESSION_new SESSION_print X509_NAME_get_text_by_NID X509_NAME_oneline X509_STORE_CTX_set_flags X509_STORE_add_cert X509_STORE_add_crl X509_check_email X509_check_host X509_check_ip X509_check_ip_asc X509_free X509_get_issuer_name X509_get_subject_name X509_load_cert_crl_file X509_load_cert_file X509_load_crl_file accept add_session clear clear_error connect copy_session_id d2i_SSL_SESSION die_if_ssl_error die_now do_https dump_peer_certificate err flush_sessions free get_cipher get_cipher_list get_client_random get_fd get_http get_http4 get_https get_https3 get_https4 get_httpx get_httpx4 get_peer_certificate get_peer_cert_chain get_rbio get_read_ahead get_server_random get_shared_ciphers get_time get_timeout get_wbio i2d_SSL_SESSION load_error_strings make_form make_headers new peek pending post_http post_http4 post_https post_https3 post_https4 post_httpx post_httpx4 print_errs read remove_session rstate_string rstate_string_long set_bio set_cert_and_key set_cipher_list set_fd set_read_ahead set_rfd set_server_cert_and_key set_session set_time set_timeout set_verify set_wfd ssl_read_CRLF ssl_read_all ssl_read_until ssl_write_CRLF ssl_write_all sslcat state_string state_string_long tcp_read_CRLF tcp_read_all tcp_read_until tcp_write_CRLF tcp_write_all tcpcat tcpxcat use_PrivateKey use_PrivateKey_ASN1 use_PrivateKey_file use_RSAPrivateKey use_RSAPrivateKey_ASN1 use_RSAPrivateKey_file use_certificate use_certificate_ASN1 use_certificate_file write d2i_OCSP_RESPONSE i2d_OCSP_RESPONSE OCSP_RESPONSE_free d2i_OCSP_REQUEST i2d_OCSP_REQUEST OCSP_REQUEST_free OCSP_cert2ids OCSP_ids2req OCSP_response_status OCSP_response_status_str OCSP_response_verify OCSP_response_results OCSP_RESPONSE_STATUS_INTERNALERROR OCSP_RESPONSE_STATUS_MALFORMEDREQUEST OCSP_RESPONSE_STATUS_SIGREQUIRED OCSP_RESPONSE_STATUS_SUCCESSFUL OCSP_RESPONSE_STATUS_TRYLATER OCSP_RESPONSE_STATUS_UNAUTHORIZED TLSEXT_STATUSTYPE_ocsp V_OCSP_CERTSTATUS_GOOD V_OCSP_CERTSTATUS_REVOKED V_OCSP_CERTSTATUS_UNKNOWN ); sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. If a constant is not found then control is passed # to the AUTOLOAD in AutoLoader. my $constname; ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname); if ($! != 0) { if ($! =~ /((Invalid)|(not valid))/i || $!{EINVAL}) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { croak "Your vendor has not defined SSLeay macro $constname"; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } eval { require XSLoader; XSLoader::load('Net::SSLeay', $VERSION); 1; } or do { require DynaLoader; push @ISA, 'DynaLoader'; bootstrap Net::SSLeay $VERSION; }; # Preloaded methods go here. $CRLF = "\x0d\x0a"; # because \r\n is not fully portable ### Print SSLeay error stack sub print_errs { my ($msg) = @_; my ($count, $err, $errs, $e) = (0,0,''); while ($err = ERR_get_error()) { $count ++; $e = "$msg $$: $count - " . ERR_error_string($err) . "\n"; $errs .= $e; warn $e if $Net::SSLeay::trace; } return $errs; } # Death is conditional to SSLeay errors existing, i.e. this function checks # for errors and only dies in affirmative. # usage: Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)"); sub die_if_ssl_error { my ($msg) = @_; die "$$: $msg\n" if print_errs($msg); } # Unconditional death. Used to print SSLeay errors before dying. # usage: Net::SSLeay::connect($ssl) or die_now("Failed SSL connect ($!)"); sub die_now { my ($msg) = @_; print_errs($msg); die "$$: $msg\n"; } # Perl 5.6.* unicode support causes that length() no longer reliably # reflects the byte length of a string. This eval is to fix that. # Thanks to Sean Burke for the snippet. BEGIN{ eval 'use bytes; sub blength ($) { defined $_[0] ? length $_[0] : 0 }'; $@ and eval ' sub blength ($) { defined $_[0] ? length $_[0] : 0 }' ; } # Autoload methods go after __END__, and are processed by the autosplit program. 1; __END__ ### Some methods that are macros in C sub want_nothing { want(shift) == 1 } sub want_read { want(shift) == 2 } sub want_write { want(shift) == 3 } sub want_X509_lookup { want(shift) == 4 } ### ### Open TCP stream to given host and port, looking up the details ### from system databases or DNS. ### sub open_tcp_connection { my ($dest_serv, $port) = @_; my ($errs); $port = getservbyname($port, 'tcp') unless $port =~ /^\d+$/; my $dest_serv_ip = gethostbyname($dest_serv); unless (defined($dest_serv_ip)) { $errs = "$0 $$: open_tcp_connection: destination host not found:" . " `$dest_serv' (port $port) ($!)\n"; warn $errs if $trace; return wantarray ? (0, $errs) : 0; } my $sin = sockaddr_in($port, $dest_serv_ip); warn "Opening connection to $dest_serv:$port (" . inet_ntoa($dest_serv_ip) . ")" if $trace>2; my $proto = &Socket::IPPROTO_TCP; # getprotobyname('tcp') not available on android if (socket (SSLCAT_S, &PF_INET(), &SOCK_STREAM(), $proto)) { warn "next connect" if $trace>3; if (CORE::connect (SSLCAT_S, $sin)) { my $old_out = select (SSLCAT_S); $| = 1; select ($old_out); warn "connected to $dest_serv, $port" if $trace>3; return wantarray ? (1, undef) : 1; # Success } } $errs = "$0 $$: open_tcp_connection: failed `$dest_serv', $port ($!)\n"; warn $errs if $trace; close SSLCAT_S; return wantarray ? (0, $errs) : 0; # Fail } ### Open connection via standard web proxy, if one was defined ### using set_proxy(). sub open_proxy_tcp_connection { my ($dest_serv, $port) = @_; return open_tcp_connection($dest_serv, $port) if !$proxyhost; warn "Connect via proxy: $proxyhost:$proxyport" if $trace>2; my ($ret, $errs) = open_tcp_connection($proxyhost, $proxyport); return wantarray ? (0, $errs) : 0 if !$ret; # Connection fail warn "Asking proxy to connect to $dest_serv:$port" if $trace>2; #print SSLCAT_S "CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF"; #my $line = ; # *** bug? Mixing stdio with syscall read? ($ret, $errs) = tcp_write_all("CONNECT $dest_serv:$port HTTP/1.0$proxyauth$CRLF$CRLF"); return wantarray ? (0,$errs) : 0 if $errs; ($line, $errs) = tcp_read_until($CRLF . $CRLF, 1024); warn "Proxy response: $line" if $trace>2; return wantarray ? (0,$errs) : 0 if $errs; return wantarray ? (1,'') : 1; # Success } ### ### read and write helpers that block ### sub debug_read { my ($replyr, $gotr) = @_; my $vm = $trace>2 && $linux_debug ? (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; warn " got " . blength($$gotr) . ':' . blength($$replyr) . " bytes (VM=$vm).\n" if $trace == 3; warn " got `$$gotr' (" . blength($$gotr) . ':' . blength($$replyr) . " bytes, VM=$vm)\n" if $trace>3; } sub ssl_read_all { my ($ssl,$how_much) = @_; $how_much = 2000000000 unless $how_much; my ($got, $rv, $errs); my $reply = ''; while ($how_much > 0) { ($got, $rv) = Net::SSLeay::read($ssl, ($how_much > 32768) ? 32768 : $how_much ); if (! defined $got) { my $err = Net::SSLeay::get_error($ssl, $rv); if ($err != Net::SSLeay::ERROR_WANT_READ() and $err != Net::SSLeay::ERROR_WANT_WRITE()) { $errs = print_errs('SSL_read'); last; } next; } $how_much -= blength($got); debug_read(\$reply, \$got) if $trace>1; last if $got eq ''; # EOF $reply .= $got; } return wantarray ? ($reply, $errs) : $reply; } sub tcp_read_all { my ($how_much) = @_; $how_much = 2000000000 unless $how_much; my ($n, $got, $errs); my $reply = ''; my $bsize = 0x10000; while ($how_much > 0) { $n = sysread(SSLCAT_S,$got, (($bsize < $how_much) ? $bsize : $how_much)); warn "Read error: $! ($n,$how_much)" unless defined $n; last if !$n; # EOF $how_much -= $n; debug_read(\$reply, \$got) if $trace>1; $reply .= $got; } return wantarray ? ($reply, $errs) : $reply; } sub ssl_write_all { my $ssl = $_[0]; my ($data_ref, $errs); if (ref $_[1]) { $data_ref = $_[1]; } else { $data_ref = \$_[1]; } my ($wrote, $written, $to_write) = (0,0, blength($$data_ref)); my $vm = $trace>2 && $linux_debug ? (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; warn " write_all VM at entry=$vm\n" if $trace>2; while ($to_write) { #sleep 1; # *** DEBUG warn "partial `$$data_ref'\n" if $trace>3; $wrote = write_partial($ssl, $written, $to_write, $$data_ref); if (defined $wrote && ($wrote > 0)) { # write_partial can return -1 $written += $wrote; $to_write -= $wrote; } else { if (defined $wrote) { # check error conditions via SSL_get_error per man page if ( my $sslerr = get_error($ssl, $wrote) ) { my $errstr = ERR_error_string($sslerr); my $errname = ''; SWITCH: { $sslerr == constant("ERROR_NONE") && do { # according to map page SSL_get_error(3ssl): # The TLS/SSL I/O operation completed. # This result code is returned if and only if ret > 0 # so if we received it here complain... warn "ERROR_NONE unexpected with invalid return value!" if $trace; $errname = "SSL_ERROR_NONE"; }; $sslerr == constant("ERROR_WANT_READ") && do { # operation did not complete, call again later, so do not # set errname and empty err_que since this is a known # error that is expected but, we should continue to try # writing the rest of our data with same io call and params. warn "ERROR_WANT_READ (TLS/SSL Handshake, will continue)\n" if $trace; print_errs('SSL_write(want read)'); last SWITCH; }; $sslerr == constant("ERROR_WANT_WRITE") && do { # operation did not complete, call again later, so do not # set errname and empty err_que since this is a known # error that is expected but, we should continue to try # writing the rest of our data with same io call and params. warn "ERROR_WANT_WRITE (TLS/SSL Handshake, will continue)\n" if $trace; print_errs('SSL_write(want write)'); last SWITCH; }; $sslerr == constant("ERROR_ZERO_RETURN") && do { # valid protocol closure from other side, no longer able to # write, since there is no longer a session... warn "ERROR_ZERO_RETURN($wrote): TLS/SSLv3 Closure alert\n" if $trace; $errname = "SSL_ERROR_ZERO_RETURN"; last SWITCH; }; $sslerr == constant("ERROR_SSL") && do { # library/protocol error warn "ERROR_SSL($wrote): Library/Protocol error occured\n" if $trace; $errname = "SSL_ERROR_SSL"; last SWITCH; }; $sslerr == constant("ERROR_WANT_CONNECT") && do { # according to man page, should never happen on call to # SSL_write, so complain, but handle as known error type warn "ERROR_WANT_CONNECT: Unexpected error for SSL_write\n" if $trace; $errname = "SSL_ERROR_WANT_CONNECT"; last SWITCH; }; $sslerr == constant("ERROR_WANT_ACCEPT") && do { # according to man page, should never happen on call to # SSL_write, so complain, but handle as known error type warn "ERROR_WANT_ACCEPT: Unexpected error for SSL_write\n" if $trace; $errname = "SSL_ERROR_WANT_ACCEPT"; last SWITCH; }; $sslerr == constant("ERROR_WANT_X509_LOOKUP") && do { # operation did not complete: waiting on call back, # call again later, so do not set errname and empty err_que # since this is a known error that is expected but, we should # continue to try writing the rest of our data with same io # call parameter. warn "ERROR_WANT_X509_LOOKUP: (Cert Callback asked for in ". "SSL_write will contine)\n" if $trace; print_errs('SSL_write(want x509'); last SWITCH; }; $sslerr == constant("ERROR_SYSCALL") && do { # some IO error occured. According to man page: # Check retval, ERR, fallback to errno if ($wrote==0) { # EOF warn "ERROR_SYSCALL($wrote): EOF violates protocol.\n" if $trace; $errname = "SSL_ERROR_SYSCALL(EOF)"; } else { # -1 underlying BIO error reported. # check error que for details, don't set errname since we # are directly appending to errs my $chkerrs = print_errs('SSL_write (syscall)'); if ($chkerrs) { warn "ERROR_SYSCALL($wrote): Have errors\n" if $trace; $errs .= "ssl_write_all $$: 1 - ERROR_SYSCALL($wrote,". "$sslerr,$errstr,$!)\n$chkerrs"; } else { # que was empty, use errno warn "ERROR_SYSCALL($wrote): errno($!)\n" if $trace; $errs .= "ssl_write_all $$: 1 - ERROR_SYSCALL($wrote,". "$sslerr) : $!\n"; } } last SWITCH; }; warn "Unhandled val $sslerr from SSL_get_error(SSL,$wrote)\n" if $trace; $errname = "SSL_ERROR_?($sslerr)"; } # end of SWITCH block if ($errname) { # if we had an errname set add the error $errs .= "ssl_write_all $$: 1 - $errname($wrote,$sslerr,". "$errstr,$!)\n"; } } # endif on have SSL_get_error val } # endif on $wrote defined } # endelse on $wrote > 0 $vm = $trace>2 && $linux_debug ? (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2; # append remaining errors in que and report if errs exist $errs .= print_errs('SSL_write'); return (wantarray ? (undef, $errs) : undef) if $errs; } return wantarray ? ($written, $errs) : $written; } sub tcp_write_all { my ($data_ref, $errs); if (ref $_[0]) { $data_ref = $_[0]; } else { $data_ref = \$_[0]; } my ($wrote, $written, $to_write) = (0,0, blength($$data_ref)); my $vm = $trace>2 && $linux_debug ? (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; warn " write_all VM at entry=$vm to_write=$to_write\n" if $trace>2; while ($to_write) { warn "partial `$$data_ref'\n" if $trace>3; $wrote = syswrite(SSLCAT_S, $$data_ref, $to_write, $written); if (defined $wrote && ($wrote > 0)) { # write_partial can return -1 $written += $wrote; $to_write -= $wrote; } elsif (!defined($wrote)) { warn "tcp_write_all: $!"; return (wantarray ? (undef, "$!") : undef); } $vm = $trace>2 && $linux_debug ? (split ' ', `cat /proc/$$/stat`)[22] : 'vm_unknown'; warn " written so far $wrote:$written bytes (VM=$vm)\n" if $trace>2; } return wantarray ? ($written, '') : $written; } ### from patch by Clinton Wong # ssl_read_until($ssl [, $delimit [, $max_length]]) # if $delimit missing, use $/ if it exists, otherwise use \n # read until delimiter reached, up to $max_length chars if defined sub ssl_read_until ($;$$) { my ($ssl,$delim, $max_length) = @_; # guess the delim string if missing if ( ! defined $delim ) { if ( defined $/ && length $/ ) { $delim = $/ } else { $delim = "\n" } # Note: \n,$/ value depends on the platform } my $len_delim = length $delim; my ($got); my $reply = ''; # If we have OpenSSL 0.9.6a or later, we can use SSL_peek to # speed things up. # N.B. 0.9.6a has security problems, so the support for # anything earlier than 0.9.6e will be dropped soon. if (&Net::SSLeay::OPENSSL_VERSION_NUMBER >= 0x0090601f) { $max_length = 2000000000 unless (defined $max_length); my ($pending, $peek_length, $found, $done); while (blength($reply) < $max_length and !$done) { #Block if necessary until we get some data $got = Net::SSLeay::peek($ssl,1); last if print_errs('SSL_peek'); $pending = Net::SSLeay::pending($ssl) + blength($reply); $peek_length = ($pending > $max_length) ? $max_length : $pending; $peek_length -= blength($reply); $got = Net::SSLeay::peek($ssl, $peek_length); last if print_errs('SSL_peek'); $peek_length = blength($got); #$found = index($got, $delim); # Old and broken # the delimiter may be split across two gets, so we prepend # a little from the last get onto this one before we check # for a match my $match; if(blength($reply) >= blength($delim) - 1) { #if what we've read so far is greater or equal #in length of what we need to prepatch $match = substr $reply, blength($reply) - blength($delim) + 1; } else { $match = $reply; } $match .= $got; $found = index($match, $delim); if ($found > -1) { #$got = Net::SSLeay::ssl_read_all($ssl, $found+$len_delim); #read up to the end of the delimiter $got = Net::SSLeay::ssl_read_all($ssl, $found + $len_delim - ((blength($match)) - (blength($got)))); $done = 1; } else { $got = Net::SSLeay::ssl_read_all($ssl, $peek_length); $done = 1 if ($peek_length == $max_length - blength($reply)); } last if print_errs('SSL_read'); debug_read(\$reply, \$got) if $trace>1; last if $got eq ''; $reply .= $got; } } else { while (!defined $max_length || length $reply < $max_length) { $got = Net::SSLeay::ssl_read_all($ssl,1); # one by one last if print_errs('SSL_read'); debug_read(\$reply, \$got) if $trace>1; last if $got eq ''; $reply .= $got; last if $len_delim && substr($reply, blength($reply)-$len_delim) eq $delim; } } return $reply; } sub tcp_read_until { my ($delim, $max_length) = @_; # guess the delim string if missing if ( ! defined $delim ) { if ( defined $/ && length $/ ) { $delim = $/ } else { $delim = "\n" } # Note: \n,$/ value depends on the platform } my $len_delim = length $delim; my ($n,$got); my $reply = ''; while (!defined $max_length || length $reply < $max_length) { $n = sysread(SSLCAT_S, $got, 1); # one by one warn "tcp_read_until: $!" if !defined $n; debug_read(\$reply, \$got) if $trace>1; last if !$n; # EOF $reply .= $got; last if $len_delim && substr($reply, blength($reply)-$len_delim) eq $delim; } return $reply; } # ssl_read_CRLF($ssl [, $max_length]) sub ssl_read_CRLF ($;$) { ssl_read_until($_[0], $CRLF, $_[1]) } sub tcp_read_CRLF { tcp_read_until($CRLF, $_[0]) } # ssl_write_CRLF($ssl, $message) writes $message and appends CRLF sub ssl_write_CRLF ($$) { # the next line uses less memory but might use more network packets return ssl_write_all($_[0], $_[1]) + ssl_write_all($_[0], $CRLF); # the next few lines do the same thing at the expense of memory, with # the chance that it will use less packets, since CRLF is in the original # message and won't be sent separately. #my $data_ref; #if (ref $_[1]) { $data_ref = $_[1] } # else { $data_ref = \$_[1] } #my $message = $$data_ref . $CRLF; #return ssl_write_all($_[0], \$message); } sub tcp_write_CRLF { # the next line uses less memory but might use more network packets return tcp_write_all($_[0]) + tcp_write_all($CRLF); # the next few lines do the same thing at the expense of memory, with # the chance that it will use less packets, since CRLF is in the original # message and won't be sent separately. #my $data_ref; #if (ref $_[1]) { $data_ref = $_[1] } # else { $data_ref = \$_[1] } #my $message = $$data_ref . $CRLF; #return tcp_write_all($_[0], \$message); } ### Quickly print out with whom we're talking sub dump_peer_certificate ($) { my ($ssl) = @_; my $cert = get_peer_certificate($ssl); return if print_errs('get_peer_certificate'); print "no cert defined\n" if !defined($cert); # Cipher=NONE with empty cert fix if (!defined($cert) || ($cert == 0)) { warn "cert = `$cert'\n" if $trace; return "Subject Name: undefined\nIssuer Name: undefined\n"; } else { my $x = 'Subject Name: ' . X509_NAME_oneline(X509_get_subject_name($cert)) . "\n" . 'Issuer Name: ' . X509_NAME_oneline(X509_get_issuer_name($cert)) . "\n"; Net::SSLeay::X509_free($cert); return $x; } } ### Arrange some randomness for eay PRNG sub randomize (;$$$) { my ($rn_seed_file, $seed, $egd_path) = @_; my $rnsf = defined($rn_seed_file) && -r $rn_seed_file; $egd_path = ''; $egd_path = $ENV{'EGD_PATH'} if $ENV{'EGD_PATH'}; RAND_seed(rand() + $$); # Stir it with time and pid unless ($rnsf || -r $Net::SSLeay::random_device || $seed || -S $egd_path) { my $poll_retval = Net::SSLeay::RAND_poll(); warn "Random number generator not seeded!!!" if $trace && !$poll_retval; } RAND_load_file($rn_seed_file, -s _) if $rnsf; RAND_seed($seed) if $seed; RAND_seed($ENV{RND_SEED}) if $ENV{RND_SEED}; RAND_load_file($Net::SSLeay::random_device, $Net::SSLeay::how_random/8) if -r $Net::SSLeay::random_device; } sub new_x_ctx { if ($ssl_version == 2) { unless (exists &Net::SSLeay::CTX_v2_new) { warn "ssl_version has been set to 2, but this version of OpenSSL has been compiled without SSLv2 support"; return undef; } $ctx = CTX_v2_new(); } elsif ($ssl_version == 3) { $ctx = CTX_v3_new(); } elsif ($ssl_version == 10) { $ctx = CTX_tlsv1_new(); } elsif ($ssl_version == 11) { unless (exists &Net::SSLeay::CTX_tlsv1_1_new) { warn "ssl_version has been set to 11, but this version of OpenSSL has been compiled without TLSv1.1 support"; return undef; } $ctx = CTX_tlsv1_1_new; } elsif ($ssl_version == 12) { unless (exists &Net::SSLeay::CTX_tlsv1_2_new) { warn "ssl_version has been set to 12, but this version of OpenSSL has been compiled without TLSv1.2 support"; return undef; } $ctx = CTX_tlsv1_2_new; } elsif ($ssl_version == 13) { unless (eval { Net::SSLeay::TLS1_3_VERSION(); } ) { warn "ssl_version has been set to 13, but this version of OpenSSL has been compiled without TLSv1.3 support"; return undef; } $ctx = CTX_new(); unless(Net::SSLeay::CTX_set_min_proto_version($ctx, Net::SSLeay::TLS1_3_VERSION())) { warn "CTX_set_min_proto failed for TLSv1.3"; return undef; } unless(Net::SSLeay::CTX_set_max_proto_version($ctx, Net::SSLeay::TLS1_3_VERSION())) { warn "CTX_set_max_proto failed for TLSv1.3"; return undef; } } else { $ctx = CTX_new(); } return $ctx; } ### ### Standard initialisation. Initialise the ssl library in the usual way ### at most once. Override this if you need differnet initialisation ### SSLeay_add_ssl_algorithms is also protected against multiple runs in SSLeay.xs ### and is also mutex protected in threading perls ### my $library_initialised; sub initialize { if (!$library_initialised) { load_error_strings(); # Some bloat, but I'm after ease of use SSLeay_add_ssl_algorithms(); # and debuggability. randomize(); $library_initialised++; } } ### ### Basic request - response primitive (don't use for https) ### sub sslcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert) my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_; my ($ctx, $ssl, $got, $errs, $written); ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); return (wantarray ? (undef, $errs) : undef) unless $got; ### Do SSL negotiation stuff warn "Creating SSL $ssl_version context...\n" if $trace>2; initialize(); # Will init at most once $ctx = new_x_ctx(); goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx; CTX_set_options($ctx, &OP_ALL); goto cleanup2 if $errs = print_errs('CTX_set_options'); warn "Cert `$crt_path' given without key" if $crt_path && !$key_path; set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path; warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2; $ssl = new($ctx); goto cleanup if $errs = print_errs('SSL_new') or !$ssl; warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2; set_fd($ssl, fileno(SSLCAT_S)); goto cleanup if $errs = print_errs('set_fd'); warn "Entering SSL negotiation phase...\n" if $trace>2; if ($trace>2) { my $i = 0; my $p = ''; my $cipher_list = 'Cipher list: '; $p=Net::SSLeay::get_cipher_list($ssl,$i); $cipher_list .= $p if $p; do { $i++; $cipher_list .= ', ' . $p if $p; $p=Net::SSLeay::get_cipher_list($ssl,$i); } while $p; $cipher_list .= '\n'; warn $cipher_list; } $got = Net::SSLeay::connect($ssl); warn "SSLeay connect returned $got\n" if $trace>2; goto cleanup if $errs = print_errs('SSL_connect'); my $server_cert = get_peer_certificate($ssl); print_errs('get_peer_certificate'); if ($trace>1) { warn "Cipher `" . get_cipher($ssl) . "'\n"; print_errs('get_ciper'); warn dump_peer_certificate($ssl); } ### Connected. Exchange some data (doing repeated tries if necessary). warn "sslcat $$: sending " . blength($out_message) . " bytes...\n" if $trace==3; warn "sslcat $$: sending `$out_message' (" . blength($out_message) . " bytes)...\n" if $trace>3; ($written, $errs) = ssl_write_all($ssl, $out_message); goto cleanup unless $written; sleep $slowly if $slowly; # Closing too soon can abort broken servers CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server warn "waiting for reply...\n" if $trace>2; ($got, $errs) = ssl_read_all($ssl); warn "Got " . blength($got) . " bytes.\n" if $trace==3; warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; cleanup: free ($ssl); $errs .= print_errs('SSL_free'); cleanup2: CTX_free ($ctx); $errs .= print_errs('CTX_free'); close SSLCAT_S; return wantarray ? ($got, $errs, $server_cert) : $got; } sub tcpcat { # address, port, message, $crt, $key --> reply / (reply,errs,cert) my ($dest_serv, $port, $out_message) = @_; my ($got, $errs, $written); ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); return (wantarray ? (undef, $errs) : undef) unless $got; ### Connected. Exchange some data (doing repeated tries if necessary). warn "tcpcat $$: sending " . blength($out_message) . " bytes...\n" if $trace==3; warn "tcpcat $$: sending `$out_message' (" . blength($out_message) . " bytes)...\n" if $trace>3; ($written, $errs) = tcp_write_all($out_message); goto cleanup unless $written; sleep $slowly if $slowly; # Closing too soon can abort broken servers CORE::shutdown SSLCAT_S, 1; # Half close --> No more output, send EOF to server warn "waiting for reply...\n" if $trace>2; ($got, $errs) = tcp_read_all(); warn "Got " . blength($got) . " bytes.\n" if $trace==3; warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; cleanup: close SSLCAT_S; return wantarray ? ($got, $errs) : $got; } sub tcpxcat { my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_; if ($usessl) { return sslcat($site, $port, $req, $crt_path, $key_path); } else { return tcpcat($site, $port, $req); } } ### ### Basic request - response primitive, this is different from sslcat ### because this does not shutdown the connection. ### sub https_cat { # address, port, message --> returns reply / (reply,errs,cert) my ($dest_serv, $port, $out_message, $crt_path, $key_path) = @_; my ($ctx, $ssl, $got, $errs, $written); ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); return (wantarray ? (undef, $errs) : undef) unless $got; ### Do SSL negotiation stuff warn "Creating SSL $ssl_version context...\n" if $trace>2; initialize(); $ctx = new_x_ctx(); goto cleanup2 if $errs = print_errs('CTX_new') or !$ctx; CTX_set_options($ctx, &OP_ALL); goto cleanup2 if $errs = print_errs('CTX_set_options'); warn "Cert `$crt_path' given without key" if $crt_path && !$key_path; set_cert_and_key($ctx, $crt_path, $key_path) if $crt_path; warn "Creating SSL connection (context was '$ctx')...\n" if $trace>2; $ssl = new($ctx); goto cleanup if $errs = print_errs('SSL_new') or !$ssl; warn "Setting fd (ctx $ctx, con $ssl)...\n" if $trace>2; set_fd($ssl, fileno(SSLCAT_S)); goto cleanup if $errs = print_errs('set_fd'); warn "Entering SSL negotiation phase...\n" if $trace>2; if ($trace>2) { my $i = 0; my $p = ''; my $cipher_list = 'Cipher list: '; $p=Net::SSLeay::get_cipher_list($ssl,$i); $cipher_list .= $p if $p; do { $i++; $cipher_list .= ', ' . $p if $p; $p=Net::SSLeay::get_cipher_list($ssl,$i); } while $p; $cipher_list .= '\n'; warn $cipher_list; } $got = Net::SSLeay::connect($ssl); warn "SSLeay connect failed" if $trace>2 && $got==0; goto cleanup if $errs = print_errs('SSL_connect'); my $server_cert = get_peer_certificate($ssl); print_errs('get_peer_certificate'); if ($trace>1) { warn "Cipher `" . get_cipher($ssl) . "'\n"; print_errs('get_ciper'); warn dump_peer_certificate($ssl); } ### Connected. Exchange some data (doing repeated tries if necessary). warn "https_cat $$: sending " . blength($out_message) . " bytes...\n" if $trace==3; warn "https_cat $$: sending `$out_message' (" . blength($out_message) . " bytes)...\n" if $trace>3; ($written, $errs) = ssl_write_all($ssl, $out_message); goto cleanup unless $written; warn "waiting for reply...\n" if $trace>2; ($got, $errs) = ssl_read_all($ssl); warn "Got " . blength($got) . " bytes.\n" if $trace==3; warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; cleanup: free ($ssl); $errs .= print_errs('SSL_free'); cleanup2: CTX_free ($ctx); $errs .= print_errs('CTX_free'); close SSLCAT_S; return wantarray ? ($got, $errs, $server_cert) : $got; } sub http_cat { # address, port, message --> returns reply / (reply,errs,cert) my ($dest_serv, $port, $out_message) = @_; my ($got, $errs, $written); ($got, $errs) = open_proxy_tcp_connection($dest_serv, $port); return (wantarray ? (undef, $errs) : undef) unless $got; ### Connected. Exchange some data (doing repeated tries if necessary). warn "http_cat $$: sending " . blength($out_message) . " bytes...\n" if $trace==3; warn "http_cat $$: sending `$out_message' (" . blength($out_message) . " bytes)...\n" if $trace>3; ($written, $errs) = tcp_write_all($out_message); goto cleanup unless $written; warn "waiting for reply...\n" if $trace>2; ($got, $errs) = tcp_read_all(); warn "Got " . blength($got) . " bytes.\n" if $trace==3; warn "Got `$got' (" . blength($got) . " bytes)\n" if $trace>3; cleanup: close SSLCAT_S; return wantarray ? ($got, $errs) : $got; } sub httpx_cat { my ($usessl, $site, $port, $req, $crt_path, $key_path) = @_; warn "httpx_cat: usessl=$usessl ($site:$port)" if $trace; if ($usessl) { return https_cat($site, $port, $req, $crt_path, $key_path); } else { return http_cat($site, $port, $req); } } ### ### Easy set up of private key and certificate ### sub set_cert_and_key ($$$) { my ($ctx, $cert_path, $key_path) = @_; my $errs = ''; # Following will ask password unless private key is not encrypted CTX_use_PrivateKey_file( $ctx, $key_path, &FILETYPE_PEM ) == 1 or $errs .= print_errs("private key `$key_path' ($!)"); CTX_use_certificate_file ($ctx, $cert_path, &FILETYPE_PEM) == 1 or $errs .= print_errs("certificate `$cert_path' ($!)"); return wantarray ? (undef, $errs) : ($errs eq ''); } ### Old deprecated API sub set_server_cert_and_key ($$$) { &set_cert_and_key } ### Set up to use web proxy sub set_proxy ($$;**) { ($proxyhost, $proxyport, $proxyuser, $proxypass) = @_; require MIME::Base64 if $proxyuser; $proxyauth = $proxyuser ? $CRLF . 'Proxy-authorization: Basic ' . MIME::Base64::encode("$proxyuser:$proxypass", '') : ''; } ### ### Easy https manipulation routines ### sub make_form { my (@fields) = @_; my $form; while (@fields) { my ($name, $data) = (shift(@fields), shift(@fields)); $data =~ s/([^\w\-.\@\$ ])/sprintf("%%%2.2x",ord($1))/gse; $data =~ tr[ ][+]; $form .= "$name=$data&"; } chop $form; return $form; } sub make_headers { my (@headers) = @_; my $headers; while (@headers) { my $header = shift(@headers); my $value = shift(@headers); $header =~ s/:$//; $value =~ s/\x0d?\x0a$//; # because we add it soon, see below $headers .= "$header: $value$CRLF"; } return $headers; } sub do_httpx3 { my ($method, $usessl, $site, $port, $path, $headers, $content, $mime_type, $crt_path, $key_path) = @_; my ($response, $page, $h,$v); my $len = blength($content); if ($len) { $mime_type = "application/x-www-form-urlencoded" unless $mime_type; $content = "Content-Type: $mime_type$CRLF" . "Content-Length: $len$CRLF$CRLF$content"; } else { $content = "$CRLF$CRLF"; } my $req = "$method $path HTTP/1.0$CRLF"; unless (defined $headers && $headers =~ /^Host:/m) { $req .= "Host: $site"; unless (($port == 80 && !$usessl) || ($port == 443 && $usessl)) { $req .= ":$port"; } $req .= $CRLF; } $req .= (defined $headers ? $headers : '') . "Accept: */*$CRLF$content"; warn "do_httpx3($method,$usessl,$site:$port)" if $trace; my ($http, $errs, $server_cert) = httpx_cat($usessl, $site, $port, $req, $crt_path, $key_path); return (undef, "HTTP/1.0 900 NET OR SSL ERROR$CRLF$CRLF$errs") if $errs; $http = '' if !defined $http; ($headers, $page) = split /\s?\n\s?\n/, $http, 2; warn "headers >$headers< page >>$page<< http >>>$http<<<" if $trace>1; ($response, $headers) = split /\s?\n/, $headers, 2; return ($page, $response, $headers, $server_cert); } sub do_https3 { splice(@_,1,0) = 1; do_httpx3; } # Legacy undocumented ### do_https2() is a legacy version in the sense that it is unable ### to return all instances of duplicate headers. sub do_httpx2 { my ($page, $response, $headers, $server_cert) = &do_httpx3; X509_free($server_cert) if defined $server_cert; return ($page, $response, defined $headers ? map( { ($h,$v)=/^(\S+)\:\s*(.*)$/; (uc($h),$v); } split(/\s?\n/, $headers) ) : () ); } sub do_https2 { splice(@_,1,0) = 1; do_httpx2; } # Legacy undocumented ### Returns headers as a hash where multiple instances of same header ### are handled correctly. sub do_httpx4 { my ($page, $response, $headers, $server_cert) = &do_httpx3; my %hr = (); for my $hh (split /\s?\n/, $headers) { my ($h,$v) = ($hh =~ /^(\S+)\:\s*(.*)$/); push @{$hr{uc($h)}}, $v; } return ($page, $response, \%hr, $server_cert); } sub do_https4 { splice(@_,1,0) = 1; do_httpx4; } # Legacy undocumented # https sub get_https { do_httpx2(GET => 1, @_) } sub post_https { do_httpx2(POST => 1, @_) } sub put_https { do_httpx2(PUT => 1, @_) } sub head_https { do_httpx2(HEAD => 1, @_) } sub get_https3 { do_httpx3(GET => 1, @_) } sub post_https3 { do_httpx3(POST => 1, @_) } sub put_https3 { do_httpx3(PUT => 1, @_) } sub head_https3 { do_httpx3(HEAD => 1, @_) } sub get_https4 { do_httpx4(GET => 1, @_) } sub post_https4 { do_httpx4(POST => 1, @_) } sub put_https4 { do_httpx4(PUT => 1, @_) } sub head_https4 { do_httpx4(HEAD => 1, @_) } # http sub get_http { do_httpx2(GET => 0, @_) } sub post_http { do_httpx2(POST => 0, @_) } sub put_http { do_httpx2(PUT => 0, @_) } sub head_http { do_httpx2(HEAD => 0, @_) } sub get_http3 { do_httpx3(GET => 0, @_) } sub post_http3 { do_httpx3(POST => 0, @_) } sub put_http3 { do_httpx3(PUT => 0, @_) } sub head_http3 { do_httpx3(HEAD => 0, @_) } sub get_http4 { do_httpx4(GET => 0, @_) } sub post_http4 { do_httpx4(POST => 0, @_) } sub put_http4 { do_httpx4(PUT => 0, @_) } sub head_http4 { do_httpx4(HEAD => 0, @_) } # Either https or http sub get_httpx { do_httpx2(GET => @_) } sub post_httpx { do_httpx2(POST => @_) } sub put_httpx { do_httpx2(PUT => @_) } sub head_httpx { do_httpx2(HEAD => @_) } sub get_httpx3 { do_httpx3(GET => @_) } sub post_httpx3 { do_httpx3(POST => @_) } sub put_httpx3 { do_httpx3(PUT => @_) } sub head_httpx3 { do_httpx3(HEAD => @_) } sub get_httpx4 { do_httpx4(GET => @_) } sub post_httpx4 { do_httpx4(POST => @_) } sub put_httpx4 { do_httpx4(PUT => @_) } sub head_httpx4 { do_httpx4(HEAD => @_) } ### Legacy, don't use # ($page, $respone_or_err, %headers) = do_https(...); sub do_https { my ($site, $port, $path, $method, $headers, $content, $mime_type, $crt_path, $key_path) = @_; do_https2($method, $site, $port, $path, $headers, $content, $mime_type, $crt_path, $key_path); } 1; __END__ SSLeay/Handle.pm000064400000025377152344764300007463 0ustar00package Net::SSLeay::Handle; use 5.8.1; use strict; use Socket; use Net::SSLeay; require Exporter; =encoding utf-8 =head1 NAME Net::SSLeay::Handle - Perl module that lets SSL (HTTPS) sockets be handled as standard file handles. =head1 SYNOPSIS use Net::SSLeay::Handle qw/shutdown/; my ($host, $port) = ("localhost", 443); tie(*SSL, "Net::SSLeay::Handle", $host, $port); print SSL "GET / HTTP/1.0\r\n"; shutdown(\*SSL, 1); print while (); close SSL; =head1 DESCRIPTION Net::SSLeay::Handle allows you to request and receive HTTPS web pages using "old-fashion" file handles as in: print SSL "GET / HTTP/1.0\r\n"; and print while (); If you export the shutdown routine, then the only extra code that you need to add to your program is the tie function as in: my $socket; if ($scheme eq "https") { tie(*S2, "Net::SSLeay::Handle", $host, $port); $socket = \*S2; else { $socket = Net::SSLeay::Handle->make_socket($host, $port); } print $socket $request_headers; ... =cut use vars qw(@ISA @EXPORT_OK $VERSION); @ISA = qw(Exporter); @EXPORT_OK = qw(shutdown); $VERSION = '1.88'; my $Initialized; #-- only _initialize() once my $Debug = 0; #-- pretty hokey #== Tie Handle Methods ======================================================== # # see perldoc perltie for details. # #============================================================================== sub TIEHANDLE { my ($class, $socket, $port) = @_; $Debug > 10 and print "TIEHANDLE(@{[join ', ', @_]})\n"; ref $socket eq "GLOB" or $socket = $class->make_socket($socket, $port); $class->_initialize(); my $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!"); my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!"); my $fileno = fileno($socket); Net::SSLeay::set_fd($ssl, $fileno); # Must use fileno my $resp = Net::SSLeay::connect($ssl); $Debug and print "Cipher '" . Net::SSLeay::get_cipher($ssl) . "'\n"; my $self = bless { ssl => $ssl, ctx => $ctx, socket => $socket, fileno => $fileno, }, $class; return $self; } sub PRINT { my $self = shift; my $ssl = _get_ssl($self); my $resp = 0; for my $msg (@_) { defined $msg or last; $resp = Net::SSLeay::write($ssl, $msg) or last; } return $resp; } sub READLINE { my $self = shift; my $ssl = _get_ssl($self); if (wantarray) { my @lines; while (my $line = Net::SSLeay::ssl_read_until($ssl)) { push @lines, $line; } return @lines; } else { my $line = Net::SSLeay::ssl_read_until($ssl); return $line ? $line : undef; } } sub READ { my ($self, $buf, $len, $offset) = \ (@_); my $ssl = _get_ssl($$self); defined($$offset) or return length($$buf = Net::SSLeay::ssl_read_all($ssl, $$len)); defined(my $read = Net::SSLeay::ssl_read_all($ssl, $$len)) or return undef; my $buf_len = length($$buf); $$offset > $buf_len and $$buf .= chr(0) x ($$offset - $buf_len); substr($$buf, $$offset) = $read; return length($read); } sub WRITE { my $self = shift; my ($buf, $len, $offset) = @_; $offset = 0 unless defined $offset; # Return number of characters written. my $ssl = $self->_get_ssl(); return $len if Net::SSLeay::write($ssl, substr($buf, $offset, $len)); return undef; } sub CLOSE { my $self = shift; my $fileno = $self->{fileno}; $Debug > 10 and print "close($fileno)\n"; Net::SSLeay::free ($self->{ssl}); Net::SSLeay::CTX_free ($self->{ctx}); close $self->{socket}; } sub FILENO { $_[0]->{fileno} } =head1 FUNCTIONS =over =item shutdown shutdown(\*SOCKET, $mode) Calls to the main shutdown() don't work with tied sockets created with this module. This shutdown should be able to distinquish between tied and untied sockets and do the right thing. =cut sub shutdown { my ($obj, @params) = @_; my $socket = UNIVERSAL::isa($obj, 'Net::SSLeay::Handle') ? $obj->{socket} : $obj; return shutdown($socket, @params); } =item debug my $debug = Net::SSLeay::Handle->debug() Net::SSLeay::Handle->debug(1) Get/set debugging mode. Always returns the debug value before the function call. if an additional argument is given the debug option will be set to this value. =cut sub debug { my ($class, $debug) = @_; my $old_debug = $Debug; @_ >1 and $Debug = $debug || 0; return $old_debug; } #=== Internal Methods ========================================================= =item make_socket my $sock = Net::SSLeay::Handle->make_socket($host, $port); Creates a socket that is connected to $post using $port. It uses $Net::SSLeay::proxyhost and proxyport if set and authentificates itself against this proxy depending on $Net::SSLeay::proxyauth. It also turns autoflush on for the created socket. =cut sub make_socket { my ($class, $host, $port) = @_; $Debug > 10 and print "_make_socket(@{[join ', ', @_]})\n"; $host ||= 'localhost'; $port ||= 443; my $phost = $Net::SSLeay::proxyhost; my $pport = $Net::SSLeay::proxyhost ? $Net::SSLeay::proxyport : $port; my $dest_ip = gethostbyname($phost || $host); my $host_params = sockaddr_in($pport, $dest_ip); socket(my $socket, &PF_INET(), &SOCK_STREAM(), 0) or die "socket: $!"; connect($socket, $host_params) or die "connect: $!"; my $old_select = select($socket); $| = 1; select($old_select); $phost and do { my $auth = $Net::SSLeay::proxyauth; my $CRLF = $Net::SSLeay::CRLF; print $socket "CONNECT $host:$port HTTP/1.0$auth$CRLF$CRLF"; my $line = <$socket>; }; return $socket; } =back =cut sub _initialize { $Initialized++ and return; Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); } sub __dummy { my $host = $Net::SSLeay::proxyhost; my $port = $Net::SSLeay::proxyport; my $auth = $Net::SSLeay::proxyauth; } #--- _get_self($socket) ------------------------------------------------------- # Returns a hash containing attributes for $socket (= \*SOMETHING) based # on fileno($socket). Will return undef if $socket was not created here. #------------------------------------------------------------------------------ sub _get_self { return $_[0]; } #--- _get_ssl($socket) -------------------------------------------------------- # Returns a the "ssl" attribute for $socket (= \*SOMETHING) based # on fileno($socket). Will cause a warning and return undef if $socket was not # created here. #------------------------------------------------------------------------------ sub _get_ssl { return $_[0]->{ssl}; } 1; __END__ =head2 USING EXISTING SOCKETS One of the motivations for writing this module was to avoid duplicating socket creation code (which is mostly error handling). The calls to tie() above where it is passed a $host and $port is provided for convenience testing. If you already have a socket connected to the right host and port, S1, then you can do something like: my $socket \*S1; if ($scheme eq "https") { tie(*S2, "Net::SSLeay::Handle", $socket); $socket = \*S2; } my $last_sel = select($socket); $| = 1; select($last_sel); print $socket $request_headers; ... Note: As far as I know you must be careful with the globs in the tie() function. The first parameter must be a glob (*SOMETHING) and the last parameter must be a reference to a glob (\*SOMETHING_ELSE) or a scaler that was assigned to a reference to a glob (as in the example above) Also, the two globs must be different. When I tried to use the same glob, I got a core dump. =head2 EXPORT None by default. You can export the shutdown() function. It is suggested that you do export shutdown() or use the fully qualified Net::SSLeay::Handle::shutdown() function to shutdown SSL sockets. It should be smart enough to distinguish between SSL and non-SSL sockets and do the right thing. =head1 EXAMPLES use Net::SSLeay::Handle qw/shutdown/; my ($host, $port) = ("localhost", 443); tie(*SSL, "Net::SSLeay::Handle", $host, $port); print SSL "GET / HTTP/1.0\r\n"; shutdown(\*SSL, 1); print while (); close SSL; =head1 TODO Better error handling. Callback routine? =head1 CAVEATS Tying to a file handle is a little tricky (for me at least). The first parameter to tie() must be a glob (*SOMETHING) and the last parameter must be a reference to a glob (\*SOMETHING_ELSE) or a scaler that was assigned to a reference to a glob ($s = \*SOMETHING_ELSE). Also, the two globs must be different. When I tried to use the same glob, I got a core dump. I was able to associate attributes to globs created by this module (like *SSL above) by making a hash of hashes keyed by the file head1. =head1 CHANGES Please see Net-SSLeay-Handle-0.50/Changes file. =head1 BUGS If you encounter a problem with this module that you believe is a bug, please report it in one of the following ways: =over =item * L under the Net-SSLeay GitHub project at L; =item * L using the CPAN RT bug tracker's web interface at L; =item * send an email to the CPAN RT bug tracker at L. =back Please make sure your bug report includes the following information: =over =item * the code you are trying to run; =item * your operating system name and version; =item * the output of C; =item * the version of OpenSSL or LibreSSL you are using. =back =head1 AUTHOR Originally written by Jim Bowlin. Maintained by Sampo Kellomäki between July 2001 and August 2003. Maintained by Florian Ragwitz between November 2005 and January 2010. Maintained by Mike McCauley between November 2005 and June 2018. Maintained by Chris Novakovic, Tuure Vartiainen and Heikki Vatiainen since June 2018. =head1 COPYRIGHT Copyright (c) 2001 Jim Bowlin Copyright (c) 2001-2003 Sampo Kellomäki Copyright (c) 2005-2010 Florian Ragwitz Copyright (c) 2005-2018 Mike McCauley Copyright (c) 2018- Chris Novakovic Copyright (c) 2018- Tuure Vartiainen Copyright (c) 2018- Heikki Vatiainen All rights reserved. =head1 LICENSE This module is released under the terms of the Artistic License 2.0. For details, see the C file distributed with Net-SSLeay's source code. =head1 SEE ALSO Net::SSLeay, perl(1), http://openssl.org/ =cut SSLeay.pod000064400001275724152344764300006442 0ustar00=encoding utf-8 =head1 NAME Net::SSLeay - Perl extension for using OpenSSL =head1 SYNOPSIS use Net::SSLeay qw(get_https post_https sslcat make_headers make_form); ($page) = get_https('www.bacus.pt', 443, '/'); # Case 1 ($page, $response, %reply_headers) = get_https('www.bacus.pt', 443, '/', # Case 2 make_headers(User-Agent => 'Cryptozilla/5.0b1', Referer => 'https://www.bacus.pt' )); ($page, $result, %headers) = # Case 2b = get_https('www.bacus.pt', 443, '/protected.html', make_headers(Authorization => 'Basic ' . MIME::Base64::encode("$user:$pass",'')) ); ($page, $response, %reply_headers) = post_https('www.bacus.pt', 443, '/foo.cgi', '', # Case 3 make_form(OK => '1', name => 'Sampo' )); $reply = sslcat($host, $port, $request); # Case 4 ($reply, $err, $server_cert) = sslcat($host, $port, $request); # Case 5 $Net::SSLeay::trace = 2; # 0=no debugging, 1=ciphers, 2=trace, 3=dump data Net::SSLeay::initialize(); # Initialize ssl library once =head1 DESCRIPTION L module contains perl bindings to openssl (L) library. B L cannot be built with pre-0.9.3 openssl. It is strongly recommended to use at least 0.9.7 (as older versions are not tested during development). Some low level API functions may be available with certain openssl versions. It is compatible with OpenSSL 1.0 and 1.1. Some functions are not available under OpenSSL 1.1. L module basically comprise of: =over =item * High level functions for accessing web servers (by using HTTP/HTTPS) =item * Low level API (mostly mapped 1:1 to openssl's C functions) =item * Convenience functions (related to low level API but with more perl friendly interface) =back There is also a related module called L included in this distribution that you might want to use instead. It has its own pod documentation. =head2 High level functions for accessing web servers This module offers some high level convenience functions for accessing web pages on SSL servers (for symmetry, the same API is offered for accessing http servers, too), an C function for writing your own clients, and finally access to the SSL api of the SSLeay/OpenSSL package so you can write servers or clients for more complicated applications. For high level functions it is most convenient to import them into your main namespace as indicated in the synopsis. =head3 Basic set of functions =over =item * get_https =item * post_https =item * put_https =item * head_https =item * do_https =item * sslcat =item * https_cat =item * make_form =item * make_headers =back B demonstrates the typical invocation of get_https() to fetch an HTML page from secure server. The first argument provides the hostname or IP in dotted decimal notation of the remote server to contact. The second argument is the TCP port at the remote end (your own port is picked arbitrarily from high numbered ports as usual for TCP). The third argument is the URL of the page without the host name part. If in doubt consult the HTTP specifications at L. B demonstrates full fledged use of C. As can be seen, C parses the response and response headers and returns them as a list, which can be captured in a hash for later reference. Also a fourth argument to C is used to insert some additional headers in the request. C is a function that will convert a list or hash to such headers. By default C supplies C (to make virtual hosting easy) and C (reportedly needed by IIS) headers. B demonstrates how to get a password protected page. Refer to the HTTP protocol specifications for further details (e.g. RFC-2617). B invokes C to submit a HTML/CGI form to a secure server. The first four arguments are equal to C (note that the empty string (C<''>) is passed as header argument). The fifth argument is the contents of the form formatted according to CGI specification. Do not post UTF-8 data as content: use utf8::downgrade first. In this case the helper function C is used to do the formatting, but you could pass any string. C automatically adds C and C headers to the request. B shows the fundamental C function (inspired in spirit by the C utility :-). It's your swiss army knife that allows you to easily contact servers, send some data, and then get the response. You are responsible for formatting the data and parsing the response - C is just a transport. B is a full invocation of C which allows the return of errors as well as the server (peer) certificate. The C<$trace> global variable can be used to control the verbosity of the high level functions. Level 0 guarantees silence, level 1 (the default) only emits error messages. =head3 Alternate versions of high-level API =over =item * get_https3 =item * post_https3 =item * put_https3 =item * get_https4 =item * post_https4 =item * put_https4 =back The above mentioned functions actually return the response headers as a list, which only gets converted to hash upon assignment (this assignment looses information if the same header occurs twice, as may be the case with cookies). There are also other variants of the functions that return unprocessed headers and that return a reference to a hash. ($page, $response, @headers) = get_https('www.bacus.pt', 443, '/'); for ($i = 0; $i < $#headers; $i+=2) { print "$headers[$i] = " . $headers[$i+1] . "\n"; } ($page, $response, $headers, $server_cert) = get_https3('www.bacus.pt', 443, '/'); print "$headers\n"; ($page, $response, $headers_ref) = get_https4('www.bacus.pt', 443, '/'); for $k (sort keys %{$headers_ref}) { for $v (@{$$headers_ref{$k}}) { print "$k = $v\n"; } } All of the above code fragments accomplish the same thing: display all values of all headers. The API functions ending in "3" return the headers simply as a scalar string and it is up to the application to split them up. The functions ending in "4" return a reference to a hash of arrays (see L and L if you are not familiar with complex perl data structures). To access a single value of such a header hash you would do something like print $$headers_ref{COOKIE}[0]; Variants 3 and 4 also allow you to discover the server certificate in case you would like to store or display it, e.g. ($p, $resp, $hdrs, $server_cert) = get_https3('www.bacus.pt', 443, '/'); if (!defined($server_cert) || ($server_cert == 0)) { warn "Subject Name: undefined, Issuer Name: undefined"; } else { warn 'Subject Name: ' . Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name($server_cert)) . 'Issuer Name: ' . Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name($server_cert)); } Beware that this method only allows after the fact verification of the certificate: by the time C has returned the https request has already been sent to the server, whether you decide to trust it or not. To do the verification correctly you must either employ the OpenSSL certificate verification framework or use the lower level API to first connect and verify the certificate and only then send the http data. See the implementation of C for guidance on how to do this. =head3 Using client certificates Secure web communications are encrypted using symmetric crypto keys exchanged using encryption based on the certificate of the server. Therefore in all SSL connections the server must have a certificate. This serves both to authenticate the server to the clients and to perform the key exchange. Sometimes it is necessary to authenticate the client as well. Two options are available: HTTP basic authentication and a client side certificate. The basic authentication over HTTPS is actually quite safe because HTTPS guarantees that the password will not travel in the clear. Never-the-less, problems like easily guessable passwords remain. The client certificate method involves authentication of the client at the SSL level using a certificate. For this to work, both the client and the server have certificates (which typically are different) and private keys. The API functions outlined above accept additional arguments that allow one to supply the client side certificate and key files. The format of these files is the same as used for server certificates and the caveat about encrypting private keys applies. ($page, $result, %headers) = # 2c = get_https('www.bacus.pt', 443, '/protected.html', make_headers(Authorization => 'Basic ' . MIME::Base64::encode("$user:$pass",'')), '', $mime_type6, $path_to_crt7, $path_to_key8); ($page, $response, %reply_headers) = post_https('www.bacus.pt', 443, '/foo.cgi', # 3b make_headers('Authorization' => 'Basic ' . MIME::Base64::encode("$user:$pass",'')), make_form(OK => '1', name => 'Sampo'), $mime_type6, $path_to_crt7, $path_to_key8); B demonstrates getting a password protected page that also requires a client certificate, i.e. it is possible to use both authentication methods simultaneously. B is a full blown POST to a secure server that requires both password authentication and a client certificate, just like in case 2c. Note: The client will not send a certificate unless the server requests one. This is typically achieved by setting the verify mode to C on the server: Net::SSLeay::set_verify(ssl, Net::SSLeay::VERIFY_PEER, 0); See C for a full description. =head3 Working through a web proxy =over =item * set_proxy =back C can use a web proxy to make its connections. You need to first set the proxy host and port using C and then just use the normal API functions, e.g: Net::SSLeay::set_proxy('gateway.myorg.com', 8080); ($page) = get_https('www.bacus.pt', 443, '/'); If your proxy requires authentication, you can supply a username and password as well Net::SSLeay::set_proxy('gateway.myorg.com', 8080, 'joe', 'salainen'); ($page, $result, %headers) = = get_https('www.bacus.pt', 443, '/protected.html', make_headers(Authorization => 'Basic ' . MIME::Base64::encode("susie:pass",'')) ); This example demonstrates the case where we authenticate to the proxy as C<"joe"> and to the final web server as C<"susie">. Proxy authentication requires the C module to work. =head3 HTTP (without S) API =over =item * get_http =item * post_http =item * tcpcat =item * get_httpx =item * post_httpx =item * tcpxcat =back Over the years it has become clear that it would be convenient to use the light-weight flavour API of C for normal HTTP as well (see C for the heavy-weight object-oriented approach). In fact it would be nice to be able to flip https on and off on the fly. Thus regular HTTP support was evolved. use Net::SSLeay qw(get_http post_http tcpcat get_httpx post_httpx tcpxcat make_headers make_form); ($page, $result, %headers) = get_http('www.bacus.pt', 443, '/protected.html', make_headers(Authorization => 'Basic ' . MIME::Base64::encode("$user:$pass",'')) ); ($page, $response, %reply_headers) = post_http('www.bacus.pt', 443, '/foo.cgi', '', make_form(OK => '1', name => 'Sampo' )); ($reply, $err) = tcpcat($host, $port, $request); ($page, $result, %headers) = get_httpx($usessl, 'www.bacus.pt', 443, '/protected.html', make_headers(Authorization => 'Basic ' . MIME::Base64::encode("$user:$pass",'')) ); ($page, $response, %reply_headers) = post_httpx($usessl, 'www.bacus.pt', 443, '/foo.cgi', '', make_form(OK => '1', name => 'Sampo' )); ($reply, $err, $server_cert) = tcpxcat($usessl, $host, $port, $request); As can be seen, the C<"x"> family of APIs takes as the first argument a flag which indicates whether SSL is used or not. =head2 Certificate verification and Certificate Revocation Lists (CRLs) OpenSSL supports the ability to verify peer certificates. It can also optionally check the peer certificate against a Certificate Revocation List (CRL) from the certificates issuer. A CRL is a file, created by the certificate issuer that lists all the certificates that it previously signed, but which it now revokes. CRLs are in PEM format. You can enable C checking like this: &Net::SSLeay::X509_STORE_set_flags (&Net::SSLeay::CTX_get_cert_store($ssl), &Net::SSLeay::X509_V_FLAG_CRL_CHECK); After setting this flag, if OpenSSL checks a peer's certificate, then it will attempt to find a CRL for the issuer. It does this by looking for a specially named file in the search directory specified by CTX_load_verify_locations. CRL files are named with the hash of the issuer's subject name, followed by C<.r0>, C<.r1> etc. For example C, C. It will read all the .r files for the issuer, and then check for a revocation of the peer certificate in all of them. (You can also force it to look in a specific named CRL file., see below). You can find out the hash of the issuer subject name in a CRL with openssl crl -in crl.pem -hash -noout If the peer certificate does not pass the revocation list, or if no CRL is found, then the handshaking fails with an error. You can also force OpenSSL to look for CRLs in one or more arbitrarily named files. my $bio = Net::SSLeay::BIO_new_file($crlfilename, 'r'); my $crl = Net::SSLeay::PEM_read_bio_X509_CRL($bio); if ($crl) { Net::SSLeay::X509_STORE_add_crl( Net::SSLeay::CTX_get_cert_store($ssl, $crl) ); } else { error reading CRL.... } Usually the URLs where you can download the CRLs is contained in the certificate itself and you can extract them with my @url = Net::SSLeay::P_X509_get_crl_distribution_points($cert) But there is no automatic downloading of the CRLs and often these CRLs are too huge to just download them to verify a single certificate. Also, these CRLs are often in DER format which you need to convert to PEM before you can use it: openssl crl -in crl.der -inform der -out crl.pem So as an alternative for faster and timely revocation checks you better use the Online Status Revocation Protocol (OCSP). =head2 Certificate verification and Online Status Revocation Protocol (OCSP) While checking for revoked certificates is possible and fast with Certificate Revocation Lists, you need to download the complete and often huge list before you can verify a single certificate. A faster way is to ask the CA to check the revocation of just a single or a few certificates using OCSP. Basically you generate for each certificate an OCSP_CERTID based on the certificate itself and its issuer, put the ids togetether into an OCSP_REQUEST and send the request to the URL given in the certificate. As a result you get back an OCSP_RESPONSE and need to check the status of the response, check that it is valid (e.g. signed by the CA) and finally extract the information about each OCSP_CERTID to find out if the certificate is still valid or got revoked. With Net::SSLeay this can be done like this: # get id(s) for given certs, like from get_peer_certificate # or get_peer_cert_chain. This will croak if # - one tries to make an OCSP_CERTID for a self-signed certificate # - the issuer of the certificate cannot be found in the SSL objects # store, nor in the current certificate chain my $cert = Net::SSLeay::get_peer_certificate($ssl); my $id = eval { Net::SSLeay::OCSP_cert2ids($ssl,$cert) }; die "failed to make OCSP_CERTID: $@" if $@; # create OCSP_REQUEST from id(s) # Multiple can be put into the same request, if the same OCSP responder # is responsible for them. my $req = Net::SSLeay::OCSP_ids2req($id); # determine URI of OCSP responder my $uri = Net::SSLeay::P_X509_get_ocsp_uri($cert); # Send stringified OCSP_REQUEST with POST to $uri. # We can ignore certificate verification for https, because the OCSP # response itself is signed. my $ua = HTTP::Tiny->new(verify_SSL => 0); my $res = $ua->request( 'POST',$uri, { headers => { 'Content-type' => 'application/ocsp-request' }, content => Net::SSLeay::i2d_OCSP_REQUEST($req) }); my $content = $res && $res->{success} && $res->{content} or die "query failed"; # Extract OCSP_RESPONSE. # this will croak if the string is not an OCSP_RESPONSE my $resp = eval { Net::SSLeay::d2i_OCSP_RESPONSE($content) }; # Check status of response. my $status = Net::SSLeay::OCSP_response_status($resp); if ($status != Net::SSLeay::OCSP_RESPONSE_STATUS_SUCCESSFUL()) die "OCSP response failed: ". Net::SSLeay::OCSP_response_status_str($status); } # Verify signature of response and if nonce matches request. # This will croak if there is a nonce in the response, but it does not match # the request. It will return false if the signature could not be verified, # in which case details can be retrieved with Net::SSLeay::ERR_get_error. # It will not complain if the response does not contain a nonce, which is # usually the case with pre-signed responses. if ( ! eval { Net::SSLeay::OCSP_response_verify($ssl,$resp,$req) }) { die "OCSP response verification failed"; } # Extract information from OCSP_RESPONSE for each of the ids. # If called in scalar context it will return the time (as time_t), when the # next update is due (minimum of all successful responses inside $resp). It # will croak on the following problems: # - response is expired or not yet valid # - no response for given OCSP_CERTID # - certificate status is not good (e.g. revoked or unknown) if ( my $nextupd = eval { Net::SSLeay::OCSP_response_results($resp,$id) }) { warn "certificate is valid, next update in ". ($nextupd-time())." seconds\n"; } else { die "certificate is not valid: $@"; } # But in array context it will return detailed information about each given # OCSP_CERTID instead croaking on errors: # if no @ids are given it will return information about all single responses # in the OCSP_RESPONSE my @results = Net::SSLeay::OCSP_response_results($resp,@ids); for my $r (@results) { print Dumper($r); # @results are in the same order as the @ids and contain: # $r->[0] - OCSP_CERTID # $r->[1] - undef if no error (certificate good) OR error message as string # $r->[2] - hash with details: # thisUpdate - time_t of this single response # nextUpdate - time_t when update is expected # statusType - integer: # V_OCSP_CERTSTATUS_GOOD(0) # V_OCSP_CERTSTATUS_REVOKED(1) # V_OCSP_CERTSTATUS_UNKNOWN(2) # revocationTime - time_t (only if revoked) # revocationReason - integer (only if revoked) # revocationReason_str - reason as string (only if revoked) } To further speed up certificate revocation checking one can use a TLS extension to instruct the server to staple the OCSP response: # set TLS extension before doing SSL_connect Net::SSLeay::set_tlsext_status_type($ssl, Net::SSLeay::TLSEXT_STATUSTYPE_ocsp()); # setup callback to verify OCSP response my $cert_valid = undef; Net::SSLeay::CTX_set_tlsext_status_cb($context,sub { my ($ssl,$resp) = @_; if (!$resp) { # Lots of servers don't return an OCSP response. # In this case we must check the OCSP status outside the SSL # handshake. warn "server did not return stapled OCSP response\n"; return 1; } # verify status my $status = Net::SSLeay::OCSP_response_status($resp); if ($status != Net::SSLeay::OCSP_RESPONSE_STATUS_SUCCESSFUL()) { warn "OCSP response failure: $status\n"; return 1; } # verify signature - we have no OCSP_REQUEST here to check nonce if (!eval { Net::SSLeay::OCSP_response_verify($ssl,$resp) }) { warn "OCSP response verify failed\n"; return 1; } # check if the certificate is valid # we should check here against the peer_certificate my $cert = Net::SSLeay::get_peer_certificate(); my $certid = eval { Net::SSLeay::OCSP_cert2ids($ssl,$cert) } or do { warn "cannot get certid from cert: $@"; $cert_valid = -1; return 1; }; if ( $nextupd = eval { Net::SSLeay::OCSP_response_results($resp,$certid) }) { warn "certificate not revoked\n"; $cert_valid = 1; } else { warn "certificate not valid: $@"; $cert_valid = 0; } }); # do SSL handshake here .... # check if certificate revocation was checked already if ( ! defined $cert_valid) { # check revocation outside of SSL handshake by asking OCSP responder ... } elsif ( ! $cert_valid ) { die "certificate not valid - closing SSL connection"; } elsif ( $cert_valid<0 ) { die "cannot verify certificate revocation - self-signed ?"; } else { # everything fine ... } =head2 Using Net::SSLeay in multi-threaded applications B Net::SSLeay module implements all necessary stuff to be ready for multi-threaded environment - it requires openssl-0.9.7 or newer. The implementation fully follows thread safety related requirements of openssl library(see L). If you are about to use Net::SSLeay (or any other module based on Net::SSLeay) in multi-threaded perl application it is recommended to follow this best-practice: =head3 Initialization Load and initialize Net::SSLeay module in the main thread: use threads; use Net::SSLeay; Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); sub do_master_job { #... call whatever from Net::SSLeay } sub do_worker_job { #... call whatever from Net::SSLeay } #start threads my $master = threads->new(\&do_master_job, 'param1', 'param2'); my @workers = threads->new(\&do_worker_job, 'arg1', 'arg2') for (1..10); #waiting for all threads to finish $_->join() for (threads->list); NOTE: Openssl's C function (which is also aliased as C, C and C) is not re-entrant and multiple calls can cause a crash in threaded application. Net::SSLeay implements flags preventing repeated calls to this function, therefore even multiple initialization via Net::SSLeay::SSLeay_add_ssl_algorithms() should work without trouble. =head3 Using callbacks Do not use callbacks across threads (the module blocks cross-thread callback operations and throws a warning). Always do the callback setup, callback use and callback destruction within the same thread. =head3 Using openssl elements All openssl elements (X509, SSL_CTX, ...) can be directly passed between threads. use threads; use Net::SSLeay; Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); sub do_job { my $context = shift; Net::SSLeay::CTX_set_default_passwd_cb($context, sub { "secret" }); #... } my $c = Net::SSLeay::CTX_new(); threads->create(\&do_job, $c); Or: use threads; use Net::SSLeay; my $context; #does not need to be 'shared' Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); sub do_job { Net::SSLeay::CTX_set_default_passwd_cb($context, sub { "secret" }); #... } $context = Net::SSLeay::CTX_new(); threads->create(\&do_job); =head3 Using other perl modules based on Net::SSLeay It should be fine to use any other module based on L (like L) in multi-threaded applications. It is generally recommended to do any global initialization of such a module in the main thread before calling C<< threads->new(..) >> or C<< threads->create(..) >> but it might differ module by module. To be safe you can load and init Net::SSLeay explicitly in the main thread: use Net::SSLeay; use Other::SSLeay::Based::Module; Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); Or even safer: use Net::SSLeay; use Other::SSLeay::Based::Module; BEGIN { Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); } =head3 Combining Net::SSLeay with other modules linked with openssl B There are many other (XS) modules linked directly to openssl library (like L). As it is expected that also "another" module will call C at some point we have again a trouble with multiple openssl initialization by Net::SSLeay and "another" module. As you can expect Net::SSLeay is not able to avoid multiple initialization of openssl library called by "another" module, thus you have to handle this on your own (in some cases it might not be possible at all to avoid this). =head3 Threading with get_https and friends The convenience functions get_https, post_https etc all initialize the SSL library by calling Net::SSLeay::initialize which does the conventional library initialization: Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); Net::SSLeay::initialize initializes the SSL library at most once. You can override the Net::SSLeay::initialize function if you desire some other type of initialization behaviour by get_https and friends. You can call Net::SSLeay::initialize from your own code if you desire this conventional library initialization. =head2 Convenience routines To be used with Low level API Net::SSLeay::randomize($rn_seed_file,$additional_seed); Net::SSLeay::set_cert_and_key($ctx, $cert_path, $key_path); $cert = Net::SSLeay::dump_peer_certificate($ssl); Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure"; $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure"; $got = Net::SSLeay::ssl_read_CRLF($ssl [, $max_length]); $got = Net::SSLeay::ssl_read_until($ssl [, $delimit [, $max_length]]); Net::SSLeay::ssl_write_CRLF($ssl, $message); =over =item * randomize seeds the openssl PRNG with C (see the top of C for how to change or configure this) and optionally with user provided data. It is very important to properly seed your random numbers, so do not forget to call this. The high level API functions automatically call C so it is not needed with them. See also caveats. =item * set_cert_and_key takes two file names as arguments and sets the certificate and private key to those. This can be used to set either server certificates or client certificates. =item * dump_peer_certificate allows you to get a plaintext description of the certificate the peer (usually the server) presented to us. =item * ssl_read_all see ssl_write_all (below) =item * ssl_write_all C and C provide true blocking semantics for these operations (see limitation, below, for explanation). These are much preferred to the low level API equivalents (which implement BSD blocking semantics). The message argument to C can be a reference. This is helpful to avoid unnecessary copying when writing something big, e.g: $data = 'A' x 1000000000; Net::SSLeay::ssl_write_all($ssl, \$data) or die "ssl write failed"; =item * ssl_read_CRLF uses C to read in a line terminated with a carriage return followed by a linefeed (CRLF). The CRLF is included in the returned scalar. =item * ssl_read_until uses C to read from the SSL input stream until it encounters a programmer specified delimiter. If the delimiter is undefined, C<$/> is used. If C<$/> is undefined, C<\n> is used. One can optionally set a maximum length of bytes to read from the SSL input stream. =item * ssl_write_CRLF writes C<$message> and appends CRLF to the SSL output stream. =back =head2 Initialization In order to use the low level API you should start your programs with the following incantation: use Net::SSLeay qw(die_now die_if_ssl_error); Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); # Important! Net::SSLeay::ENGINE_load_builtin_engines(); # If you want built-in engines Net::SSLeay::ENGINE_register_all_complete(); # If you want built-in engines Net::SSLeay::randomize(); =head2 Error handling functions I can not emphasize the need to check for error enough. Use these functions even in the most simple programs, they will reduce debugging time greatly. Do not ask questions on the mailing list without having first sprinkled these in your code. =over =item * die_now =item * die_if_ssl_error C and C are used to conveniently print the SSLeay error stack when something goes wrong: Net::SSLeay::connect($ssl) or die_now("Failed SSL connect ($!)"); Net::SSLeay::write($ssl, "foo") or die_if_ssl_error("SSL write ($!)"); =item * print_errs You can also use C to dump the error stack without exiting the program. As can be seen, your code becomes much more readable if you import the error reporting functions into your main name space. =back =head2 Sockets Perl uses file handles for all I/O. While SSLeay has a quite flexible BIO mechanism and perl has an evolved PerlIO mechanism, this module still sticks to using file descriptors. Thus to attach SSLeay to a socket you should use C to extract the underlying file descriptor: Net::SSLeay::set_fd($ssl, fileno(S)); # Must use fileno You should also set C<$|> to 1 to eliminate STDIO buffering so you do not get confused if you use perl I/O functions to manipulate your socket handle. If you need to C on the socket, go right ahead, but be warned that OpenSSL does some internal buffering so SSL_read does not always return data even if the socket selected for reading (just keep on selecting and trying to read). C is no different from the C language OpenSSL in this respect. =head2 Callbacks You can establish a per-context verify callback function something like this: sub verify { my ($ok, $x509_store_ctx) = @_; print "Verifying certificate...\n"; ... return $ok; } It is used like this: Net::SSLeay::set_verify ($ssl, Net::SSLeay::VERIFY_PEER, \&verify); Per-context callbacks for decrypting private keys are implemented. Net::SSLeay::CTX_set_default_passwd_cb($ctx, sub { "top-secret" }); Net::SSLeay::CTX_use_PrivateKey_file($ctx, "key.pem", Net::SSLeay::FILETYPE_PEM) or die "Error reading private key"; Net::SSLeay::CTX_set_default_passwd_cb($ctx, undef); If Hello Extensions are supported by your OpenSSL, a session secret callback can be set up to be called when a session secret is set by openssl. Establish it like this: Net::SSLeay::set_session_secret_cb($ssl, \&session_secret_cb, $somedata); It will be called like this: sub session_secret_cb { my ($secret, \@cipherlist, \$preferredcipher, $somedata) = @_; } No other callbacks are implemented. You do not need to use any callback for simple (i.e. normal) cases where the SSLeay built-in verify mechanism satisfies your needs. It is required to reset these callbacks to undef immediately after use to prevent memory leaks, thread safety problems and crashes on exit that can occur if different threads set different callbacks. If you want to use callback stuff, see examples/callback.pl! It's the only one I am able to make work reliably. =head2 Low level API In addition to the high level functions outlined above, this module contains straight-forward access to CRYPTO and SSL parts of OpenSSL C API. See the C<*.h> headers from OpenSSL C distribution for a list of low level SSLeay functions to call (check SSLeay.xs to see if some function has been implemented). The module strips the initial C<"SSL_"> off of the SSLeay names. Generally you should use C in its place. Note that some functions are prefixed with C<"P_"> - these are very close to the original API however contain some kind of a wrapper making its interface more perl friendly. For example: In C: #include err = SSL_set_verify (ssl, SSL_VERIFY_CLIENT_ONCE, &your_call_back_here); In Perl: use Net::SSLeay; $err = Net::SSLeay::set_verify ($ssl, Net::SSLeay::VERIFY_CLIENT_ONCE, \&your_call_back_here); If the function does not start with C you should use the full function name, e.g.: $err = Net::SSLeay::ERR_get_error; The following new functions behave in perlish way: $got = Net::SSLeay::read($ssl); # Performs SSL_read, but returns $got # resized according to data received. # Returns undef on failure. Net::SSLeay::write($ssl, $foo) || die; # Performs SSL_write, but automatically # figures out the size of $foo =head3 Low level API: Version related functions =over =item * SSLeay B not available in Net-SSLeay-1.42 and before Gives version number (numeric) of underlaying openssl library. my $ver_number = Net::SSLeay::SSLeay(); # returns: the number identifying the openssl release # # 0x00903100 => openssl-0.9.3 # 0x00904100 => openssl-0.9.4 # 0x00905100 => openssl-0.9.5 # 0x0090600f => openssl-0.9.6 # 0x0090601f => openssl-0.9.6a # 0x0090602f => openssl-0.9.6b # ... # 0x009060df => openssl-0.9.6m # 0x0090700f => openssl-0.9.7 # 0x0090701f => openssl-0.9.7a # 0x0090702f => openssl-0.9.7b # ... # 0x009070df => openssl-0.9.7m # 0x0090800f => openssl-0.9.8 # 0x0090801f => openssl-0.9.8a # 0x0090802f => openssl-0.9.8b # ... # 0x0090814f => openssl-0.9.8t # 0x1000000f => openssl-1.0.0 # 0x1000004f => openssl-1.0.0d # 0x1000007f => openssl-1.0.0g You can use it like this: if (Net::SSLeay::SSLeay() < 0x0090800f) { die "you need openssl-0.9.8 or higher"; } =item * SSLeay_version B not available in Net-SSLeay-1.42 and before Gives version number (string) of underlaying openssl library. my $ver_string = Net::SSLeay::SSLeay_version($type); # $type # SSLEAY_VERSION - e.g. 'OpenSSL 1.0.0d 8 Feb 2011' # SSLEAY_CFLAGS - e.g. 'compiler: gcc -D_WINDLL -DOPENSSL_USE_APPLINK .....' # SSLEAY_BUILT_ON - e.g. 'built on: Fri May 6 00:00:46 GMT 2011' # SSLEAY_PLATFORM - e.g. 'platform: mingw' # SSLEAY_DIR - e.g. 'OPENSSLDIR: "z:/...."' # # returns: string Net::SSLeay::SSLeay_version(); #is equivalent to Net::SSLeay::SSLeay_version(SSLEAY_VERSION); Check openssl doc L =item * OpenSSL_version_num B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.1.0 Gives version number (numeric) of underlaying openssl library. See L for interpreting the result. my $ver_number = Net::SSLeay::OpenSSL_version_num(); # returns: the number identifying the openssl release =item * OpenSSL_version B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.1.0 Gives version number (string) of underlaying openssl library. my $ver_string = Net::SSLeay::OpenSSL_version($t); # $t # OPENSSL_VERSION - e.g. 'OpenSSL 1.1.0g 2 Nov 2017' # OPENSSL_CFLAGS - e.g. 'compiler: cc -DDSO_DLFCN -DHAVE_DLFCN_H .....' # OPENSSL_BUILT_ON - e.g. 'built on: reproducible build, date unspecified' # OPENSSL_PLATFORM - e.g. 'platform: darwin64-x86_64-cc' # OPENSSL_DIR - e.g. 'OPENSSLDIR: "/opt/openssl-1.1.0g"' # OPENSSL_ENGINES_DIR - e.g. 'ENGINESDIR: "/opt/openssl-1.1.0g/lib/engines-1.1"' # # returns: string Net::SSLeay::OpenSSL_version(); #is equivalent to Net::SSLeay::OpenSSL_version(OPENSSL_VERSION); Check openssl doc L =back =head3 Low level API: Initialization related functions =over =item * library_init Initialize SSL library by registering algorithms. my $rv = Net::SSLeay::library_init(); Check openssl doc L While the original function from OpenSSL always returns 1, Net::SSLeay adds a wrapper around it to make sure that the OpenSSL function is only called once. Thus the function will return 1 if initialization was done and 0 if not, i.e. if initialization was done already before. =item * add_ssl_algorithms The alias for L Net::SSLeay::add_ssl_algorithms(); =item * OpenSSL_add_ssl_algorithms The alias for L Net::SSLeay::OpenSSL_add_ssl_algorithms(); =item * SSLeay_add_ssl_algorithms The alias for L Net::SSLeay::SSLeay_add_ssl_algorithms(); =item * load_error_strings Registers the error strings for all libcrypto + libssl related functions. Net::SSLeay::load_error_strings(); # # returns: no return value Check openssl doc L =item * ERR_load_crypto_strings Registers the error strings for all libcrypto functions. No need to call this function if you have already called L. Net::SSLeay::ERR_load_crypto_strings(); # # returns: no return value Check openssl doc L =item * ERR_load_RAND_strings Registers the error strings for RAND related functions. No need to call this function if you have already called L. Net::SSLeay::ERR_load_RAND_strings(); # # returns: no return value =item * ERR_load_SSL_strings Registers the error strings for SSL related functions. No need to call this function if you have already called L. Net::SSLeay::ERR_load_SSL_strings(); # # returns: no return value =item * OpenSSL_add_all_algorithms B not available in Net-SSLeay-1.45 and before Add algorithms to internal table. Net::SSLeay::OpenSSL_add_all_algorithms(); # # returns: no return value Check openssl doc L =item * OPENSSL_add_all_algorithms_conf B not available in Net-SSLeay-1.45 and before Similar to L - will ALWAYS load the config file Net::SSLeay::OPENSSL_add_all_algorithms_conf(); # # returns: no return value =item * OPENSSL_add_all_algorithms_noconf B not available in Net-SSLeay-1.45 and before Similar to L - will NEVER load the config file Net::SSLeay::OPENSSL_add_all_algorithms_noconf(); # # returns: no return value =back =head3 Low level API: ERR_* and SSL_alert_* related functions B Please note that SSL_alert_* function have "SSL_" part stripped from their names. =over =item * ERR_clear_error Clear the error queue. Net::SSLeay::ERR_clear_error(); # # returns: no return value Check openssl doc L =item * ERR_error_string Generates a human-readable string representing the error code $error. my $rv = Net::SSLeay::ERR_error_string($error); # $error - (unsigned integer) error code # # returns: string Check openssl doc L =item * ERR_get_error Returns the earliest error code from the thread's error queue and removes the entry. This function can be called repeatedly until there are no more error codes to return. my $rv = Net::SSLeay::ERR_get_error(); # # returns: (unsigned integer) error code Check openssl doc L =item * ERR_peek_error Returns the earliest error code from the thread's error queue without modifying it. my $rv = Net::SSLeay::ERR_peek_error(); # # returns: (unsigned integer) error code Check openssl doc L =item * ERR_put_error Adds an error code to the thread's error queue. It signals that the error of $reason code reason occurred in function $func of library $lib, in line number $line of $file. Net::SSLeay::ERR_put_error($lib, $func, $reason, $file, $line); # $lib - (integer) library id (check openssl/err.h for constants e.g. ERR_LIB_SSL) # $func - (integer) function id (check openssl/ssl.h for constants e.g. SSL_F_SSL23_READ) # $reason - (integer) reason id (check openssl/ssl.h for constants e.g. SSL_R_SSL_HANDSHAKE_FAILURE) # $file - (string) file name # $line - (integer) line number in $file # # returns: no return value Check openssl doc L and L =item * alert_desc_string Returns a two letter string as a short form describing the reason of the alert specified by value. my $rv = Net::SSLeay::alert_desc_string($value); # $value - (integer) allert id (check openssl/ssl.h for SSL3_AD_* and TLS1_AD_* constants) # # returns: description string (2 letters) Check openssl doc L =item * alert_desc_string_long Returns a string describing the reason of the alert specified by value. my $rv = Net::SSLeay::alert_desc_string_long($value); # $value - (integer) allert id (check openssl/ssl.h for SSL3_AD_* and TLS1_AD_* constants) # # returns: description string Check openssl doc L =item * alert_type_string Returns a one letter string indicating the type of the alert specified by value. my $rv = Net::SSLeay::alert_type_string($value); # $value - (integer) allert id (check openssl/ssl.h for SSL3_AD_* and TLS1_AD_* constants) # # returns: string (1 letter) Check openssl doc L =item * alert_type_string_long Returns a string indicating the type of the alert specified by value. my $rv = Net::SSLeay::alert_type_string_long($value); # $value - (integer) allert id (check openssl/ssl.h for SSL3_AD_* and TLS1_AD_* constants) # # returns: string Check openssl doc L =back =head3 Low level API: SSL_METHOD_* related functions =over =item * SSLv23_method, SSLv23_server_method and SSLv23_client_method B not available in Net-SSLeay-1.82 and before. Returns SSL_METHOD structure corresponding to general-purpose version-flexible TLS method, the return value can be later used as a param of L. B Consider using TLS_method, TLS_server_method or TLS_client_method with new code. my $rv = Net::SSLeay::SSLv2_method(); # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) =item * SSLv2_method Returns SSL_METHOD structure corresponding to SSLv2 method, the return value can be later used as a param of L. Only available where supported by the underlying openssl. my $rv = Net::SSLeay::SSLv2_method(); # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) =item * SSLv3_method Returns SSL_METHOD structure corresponding to SSLv3 method, the return value can be later used as a param of L. my $rv = Net::SSLeay::SSLv3_method(); # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) Check openssl doc L =item * TLSv1_method, TLSv1_server_method and TLSv1_client_method B Server and client methods not available in Net-SSLeay-1.82 and before. Returns SSL_METHOD structure corresponding to TLSv1 method, the return value can be later used as a param of L. my $rv = Net::SSLeay::TLSv1_method(); # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) Check openssl doc L =item * TLSv1_1_method, TLSv1_1_server_method and TLSv1_1_client_method B Server and client methods not available in Net-SSLeay-1.82 and before. Returns SSL_METHOD structure corresponding to TLSv1_1 method, the return value can be later used as a param of L. Only available where supported by the underlying openssl. my $rv = Net::SSLeay::TLSv1_1_method(); # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) Check openssl doc L =item * TLSv1_2_method, TLSv1_2_server_method and TLSv1_2_client_method B Server and client methods not available in Net-SSLeay-1.82 and before. Returns SSL_METHOD structure corresponding to TLSv1_2 method, the return value can be later used as a param of L. Only available where supported by the underlying openssl. my $rv = Net::SSLeay::TLSv1_2_method(); # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) Check openssl doc L =item * TLS_method, TLS_server_method and TLS_client_method B Not available in Net-SSLeay-1.82 and before. Returns SSL_METHOD structure corresponding to general-purpose version-flexible TLS method, the return value can be later used as a param of L. Only available where supported by the underlying openssl. my $rv = Net::SSLeay::TLS_method(); # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) Check openssl doc L =back =head3 Low level API: ENGINE_* related functions =over =item * ENGINE_load_builtin_engines B Requires an OpenSSL build with dynamic engine loading support. Load all bundled ENGINEs into memory and make them visible. Net::SSLeay::ENGINE_load_builtin_engines(); # # returns: no return value Check openssl doc L =item * ENGINE_register_all_complete B Requires an OpenSSL build with dynamic engine loading support. Register all loaded ENGINEs for every algorithm they collectively implement. Net::SSLeay::ENGINE_register_all_complete(); # # returns: no return value Check openssl doc L =item * ENGINE_set_default B Requires an OpenSSL build with dynamic engine loading support. Set default engine to $e + set its flags to $flags. my $rv = Net::SSLeay::ENGINE_set_default($e, $flags); # $e - value corresponding to openssl's ENGINE structure # $flags - (integer) engine flags # flags value can be made by bitwise "OR"ing: # 0x0001 - ENGINE_METHOD_RSA # 0x0002 - ENGINE_METHOD_DSA # 0x0004 - ENGINE_METHOD_DH # 0x0008 - ENGINE_METHOD_RAND # 0x0010 - ENGINE_METHOD_ECDH # 0x0020 - ENGINE_METHOD_ECDSA # 0x0040 - ENGINE_METHOD_CIPHERS # 0x0080 - ENGINE_METHOD_DIGESTS # 0x0100 - ENGINE_METHOD_STORE # 0x0200 - ENGINE_METHOD_PKEY_METHS # 0x0400 - ENGINE_METHOD_PKEY_ASN1_METHS # Obvious all-or-nothing cases: # 0xFFFF - ENGINE_METHOD_ALL # 0x0000 - ENGINE_METHOD_NONE # # returns: 1 on success, 0 on failure Check openssl doc L =item * ENGINE_by_id Get ENGINE by its identification $id. B Requires an OpenSSL build with dynamic engine loading support. my $rv = Net::SSLeay::ENGINE_by_id($id); # $id - (string) engine identification e.g. "dynamic" # # returns: value corresponding to openssl's ENGINE structure (0 on failure) Check openssl doc L =back =head3 Low level API: EVP_PKEY_* related functions =over =item * EVP_PKEY_copy_parameters Copies the parameters from key $from to key $to. my $rv = Net::SSLeay::EVP_PKEY_copy_parameters($to, $from); # $to - value corresponding to openssl's EVP_PKEY structure # $from - value corresponding to openssl's EVP_PKEY structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * EVP_PKEY_new B not available in Net-SSLeay-1.45 and before Creates a new EVP_PKEY structure. my $rv = Net::SSLeay::EVP_PKEY_new(); # # returns: value corresponding to openssl's EVP_PKEY structure (0 on failure) Check openssl doc L =item * EVP_PKEY_free B not available in Net-SSLeay-1.45 and before Free an allocated EVP_PKEY structure. Net::SSLeay::EVP_PKEY_free($pkey); # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: no return value Check openssl doc L =item * EVP_PKEY_assign_RSA B not available in Net-SSLeay-1.45 and before Set the key referenced by $pkey to $key B No reference counter will be increased, i.e. $key will be freed if $pkey is freed. my $rv = Net::SSLeay::EVP_PKEY_assign_RSA($pkey, $key); # $pkey - value corresponding to openssl's EVP_PKEY structure # $key - value corresponding to openssl's RSA structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * EVP_PKEY_assign_EC_KEY B not available in Net-SSLeay-1.74 and before Set the key referenced by $pkey to $key B No reference counter will be increased, i.e. $key will be freed if $pkey is freed. my $rv = Net::SSLeay::EVP_PKEY_assign_EC_KEY($pkey, $key); # $pkey - value corresponding to openssl's EVP_PKEY structure # $key - value corresponding to openssl's EC_KEY structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * EVP_PKEY_bits B not available in Net-SSLeay-1.45 and before Returns the size of the key $pkey in bits. my $rv = Net::SSLeay::EVP_PKEY_bits($pkey); # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: size in bits =item * EVP_PKEY_size B not available in Net-SSLeay-1.45 and before Returns the maximum size of a signature in bytes. The actual signature may be smaller. my $rv = Net::SSLeay::EVP_PKEY_size($pkey); # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: the maximum size in bytes Check openssl doc L =item * EVP_PKEY_id B not available in Net-SSLeay-1.45 and before; requires at least openssl-1.0.0 Returns $pkey type (integer value of corresponding NID). my $rv = Net::SSLeay::EVP_PKEY_id($pkey); # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: (integer) key type Example: my $pubkey = Net::SSLeay::X509_get_pubkey($x509); my $type = Net::SSLeay::EVP_PKEY_id($pubkey); print Net::SSLeay::OBJ_nid2sn($type); #prints e.g. 'rsaEncryption' =back =head3 Low level API: PEM_* related functions Check openssl doc L =over =item * PEM_read_bio_X509 B not available in Net-SSLeay-1.45 and before Loads PEM formatted X509 certificate via given BIO structure. my $rv = Net::SSLeay::PEM_read_bio_X509($bio); # $bio - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's X509 structure (0 on failure) Example: my $bio = Net::SSLeay::BIO_new_file($filename, 'r'); my $x509 = Net::SSLeay::PEM_read_bio_X509($bio); Net::SSLeay::BIO_free($bio); =item * PEM_read_bio_X509_REQ B not available in Net-SSLeay-1.45 and before Loads PEM formatted X509_REQ object via given BIO structure. my $rv = Net::SSLeay::PEM_read_bio_X509_REQ($bio, $x=NULL, $cb=NULL, $u=NULL); # $bio - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's X509_REQ structure (0 on failure) Example: my $bio = Net::SSLeay::BIO_new_file($filename, 'r'); my $x509_req = Net::SSLeay::PEM_read_bio_X509_REQ($bio); Net::SSLeay::BIO_free($bio); =item * PEM_read_bio_DHparams Reads DH structure from BIO. my $rv = Net::SSLeay::PEM_read_bio_DHparams($bio); # $bio - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's DH structure (0 on failure) =item * PEM_read_bio_X509_CRL Reads X509_CRL structure from BIO. my $rv = Net::SSLeay::PEM_read_bio_X509_CRL($bio); # $bio - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's X509_CRL structure (0 on failure) =item * PEM_read_bio_PrivateKey B not available in Net-SSLeay-1.45 and before Loads PEM formatted private key via given BIO structure. my $rv = Net::SSLeay::PEM_read_bio_PrivateKey($bio, $cb, $data); # $bio - value corresponding to openssl's BIO structure # $cb - reference to perl callback function # $data - data that will be passed to callback function (see examples below) # # returns: value corresponding to openssl's EVP_PKEY structure (0 on failure) Example: my $bio = Net::SSLeay::BIO_new_file($filename, 'r'); my $privkey = Net::SSLeay::PEM_read_bio_PrivateKey($bio); #ask for password if needed Net::SSLeay::BIO_free($bio); To use password you have the following options: $privkey = Net::SSLeay::PEM_read_bio_PrivateKey($bio, \&callback_func); # use callback func for getting password $privkey = Net::SSLeay::PEM_read_bio_PrivateKey($bio, \&callback_func, $data); # use callback_func + pass $data to callback_func $privkey = Net::SSLeay::PEM_read_bio_PrivateKey($bio, undef, "secret"); # use password "secret" $privkey = Net::SSLeay::PEM_read_bio_PrivateKey($bio, undef, ""); # use empty password Callback function signature: sub callback_func { my ($max_passwd_size, $rwflag, $data) = @_; # $max_passwd_size - maximum size of returned password (longer values will be discarded) # $rwflag - indicates whether we are loading (0) or storing (1) - for PEM_read_bio_PrivateKey always 0 # $data - the data passed to PEM_read_bio_PrivateKey as 3rd parameter return "secret"; } =item * PEM_X509_INFO_read_bio Reads a BIO containing a PEM formatted file into a STACK_OF(X509_INFO) structure. my $rv = Net::SSLeay::PEM_X509_INFO_read_bio($bio); # $bio - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's STACK_OF(X509_INFO) structure. Example: my $bio = Net::SSLeay::BIO_new_file($filename, 'r'); my $sk_x509_info = Net::SSLeay::PEM_X509_INFO_read_bio($bio); Net::SSLeay::BIO_free($bio); =item * PEM_get_string_X509 B Does not exactly correspond to any low level API function Converts/exports X509 certificate to string (PEM format). Net::SSLeay::PEM_get_string_X509($x509); # $x509 - value corresponding to openssl's X509 structure # # returns: string with $x509 in PEM format =item * PEM_get_string_PrivateKey B not available in Net-SSLeay-1.45 and before Converts public key $pk into PEM formatted string (optionally protected with password). my $rv = Net::SSLeay::PEM_get_string_PrivateKey($pk, $passwd, $enc_alg); # $pk - value corresponding to openssl's EVP_PKEY structure # $passwd - [optional] (string) password to use for key encryption # $enc_alg - [optional] algorithm to use for key encryption (default: DES_CBC) - value corresponding to openssl's EVP_CIPHER structure # # returns: PEM formatted string Examples: $pem_privkey = Net::SSLeay::PEM_get_string_PrivateKey($pk); $pem_privkey = Net::SSLeay::PEM_get_string_PrivateKey($pk, "secret"); $pem_privkey = Net::SSLeay::PEM_get_string_PrivateKey($pk, "secret", Net::SSLeay::EVP_get_cipherbyname("DES-EDE3-CBC")); =item * PEM_get_string_X509_CRL B not available in Net-SSLeay-1.45 and before Converts X509_CRL object $x509_crl into PEM formatted string. Net::SSLeay::PEM_get_string_X509_CRL($x509_crl); # $x509_crl - value corresponding to openssl's X509_CRL structure # # returns: no return value =item * PEM_get_string_X509_REQ B not available in Net-SSLeay-1.45 and before Converts X509_REQ object $x509_crl into PEM formatted string. Net::SSLeay::PEM_get_string_X509_REQ($x509_req); # $x509_req - value corresponding to openssl's X509_REQ structure # # returns: no return value =back =head3 Low level API: d2i_* (DER format) related functions =over =item * d2i_X509_bio B not available in Net-SSLeay-1.45 and before Loads DER formatted X509 certificate via given BIO structure. my $rv = Net::SSLeay::d2i_X509_bio($bp); # $bp - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's X509 structure (0 on failure) Example: my $bio = Net::SSLeay::BIO_new_file($filename, 'rb'); my $x509 = Net::SSLeay::d2i_X509_bio($bio); Net::SSLeay::BIO_free($bio); Check openssl doc L =item * d2i_X509_CRL_bio B not available in Net-SSLeay-1.45 and before Loads DER formatted X509_CRL object via given BIO structure. my $rv = Net::SSLeay::d2i_X509_CRL_bio($bp); # $bp - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's X509_CRL structure (0 on failure) Example: my $bio = Net::SSLeay::BIO_new_file($filename, 'rb'); my $x509_crl = Net::SSLeay::d2i_X509_CRL_bio($bio); Net::SSLeay::BIO_free($bio); =item * d2i_X509_REQ_bio B not available in Net-SSLeay-1.45 and before Loads DER formatted X509_REQ object via given BIO structure. my $rv = Net::SSLeay::d2i_X509_REQ_bio($bp); # $bp - value corresponding to openssl's BIO structure # # returns: value corresponding to openssl's X509_REQ structure (0 on failure) Example: my $bio = Net::SSLeay::BIO_new_file($filename, 'rb'); my $x509_req = Net::SSLeay::d2i_X509_REQ_bio($bio); Net::SSLeay::BIO_free($bio); =back =head3 Low level API: PKCS12 related functions =over =item * P_PKCS12_load_file B not available in Net-SSLeay-1.45 and before Loads X509 certificate + private key + certificates of CA chain (if present in PKCS12 file). my ($privkey, $cert, @cachain) = Net::SSLeay::P_PKCS12_load_file($filename, $load_chain, $password); # $filename - name of PKCS12 file # $load_chain - [optional] whether load (1) or not(0) CA chain (default: 0) # $password - [optional] password for private key # # returns: triplet ($privkey, $cert, @cachain) # $privkey - value corresponding to openssl's EVP_PKEY structure # $cert - value corresponding to openssl's X509 structure # @cachain - array of values corresponding to openssl's X509 structure (empty if no CA chain in PKCS12) B after you do the job you need to call X509_free() on $privkey + all members of @cachain and EVP_PKEY_free() on $privkey. Examples: my ($privkey, $cert) = Net::SSLeay::P_PKCS12_load_file($filename); #or my ($privkey, $cert) = Net::SSLeay::P_PKCS12_load_file($filename, 0, $password); #or my ($privkey, $cert, @cachain) = Net::SSLeay::P_PKCS12_load_file($filename, 1); #or my ($privkey, $cert, @cachain) = Net::SSLeay::P_PKCS12_load_file($filename, 1, $password); #BEWARE: THIS IS WRONG - MEMORY LEAKS! (you cannot free @cachain items) my ($privkey, $cert) = Net::SSLeay::P_PKCS12_load_file($filename, 1, $password); B With some combinations of Windows, perl, compiler and compiler options, you may see a runtime error "no OPENSSL_Applink", when calling Net::SSLeay::P_PKCS12_load_file. See README.Win32 for more details. =back =head3 Low level API: SESSION_* related functions =over =item * d2i_SSL_SESSION B does not work in Net-SSLeay-1.85 and before Transforms the binary ASN1 representation string of an SSL/TLS session into an SSL_SESSION object. my $ses = Net::SSLeay::d2i_SSL_SESSION($data); # $data - the session as ASN1 representation string # # returns: $ses - the new SSL_SESSION Check openssl doc L =item * i2d_SSL_SESSION B does not work in Net-SSLeay-1.85 and before Transforms the SSL_SESSION object in into the ASN1 representation and returns it as string. my $data = Net::SSLeay::i2d_SSL_SESSION($ses); # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: $data - session as string Check openssl doc L =item * SESSION_new Creates a new SSL_SESSION structure. my $rv = Net::SSLeay::SESSION_new(); # # returns: value corresponding to openssl's SSL_SESSION structure (0 on failure) =item * SESSION_free Free an allocated SSL_SESSION structure. Net::SSLeay::SESSION_free($ses); # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: no return value Check openssl doc L =item * SESSION_up_ref B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0 or LibreSSL 2.7.0 Increases the reference counter on a SSL_SESSION structure. Net::SSLeay::SESSION_up_ref($ses); # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: 1 on success else 0 Check openssl doc L =item * SESSION_dup B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Duplicates a SSL_SESSION structure. Net::SSLeay::SESSION_dup($ses); # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: the duplicated session Check openssl doc L =item * SESSION_is_resumable B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Determine whether an SSL_SESSION object can be used for resumption. Net::SSLeay::SESSION_is_resumable($ses); # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: (integer) 1 if it can or 0 if not Check openssl doc L =item * SESSION_cmp Compare two SSL_SESSION structures. my $rv = Net::SSLeay::SESSION_cmp($sesa, $sesb); # $sesa - value corresponding to openssl's SSL_SESSION structure # $sesb - value corresponding to openssl's SSL_SESSION structure # # returns: 0 if the two structures are the same B Not available in openssl 1.0 or later =item * SESSION_get_app_data Can be used to get application defined value/data. my $rv = Net::SSLeay::SESSION_get_app_data($ses); # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: string/buffer/pointer ??? =item * SESSION_set_app_data Can be used to set some application defined value/data. my $rv = Net::SSLeay::SESSION_set_app_data($s, $a); # $s - value corresponding to openssl's SSL_SESSION structure # $a - (string/buffer/pointer ???) data # # returns: ??? =item * SESSION_get_ex_data Is used to retrieve the information for $idx from session $ses. my $rv = Net::SSLeay::SESSION_get_ex_data($ses, $idx); # $ses - value corresponding to openssl's SSL_SESSION structure # $idx - (integer) index for application specific data # # returns: pointer to ??? Check openssl doc L =item * SESSION_set_ex_data Is used to store application data at arg for idx into the session object. my $rv = Net::SSLeay::SESSION_set_ex_data($ss, $idx, $data); # $ss - value corresponding to openssl's SSL_SESSION structure # $idx - (integer) ??? # $data - (pointer) ??? # # returns: 1 on success, 0 on failure Check openssl doc L =item * SESSION_get_ex_new_index Is used to register a new index for application specific data. my $rv = Net::SSLeay::SESSION_get_ex_new_index($argl, $argp, $new_func, $dup_func, $free_func); # $argl - (long) ??? # $argp - (pointer) ??? # $new_func - function pointer ??? (CRYPTO_EX_new *) # $dup_func - function pointer ??? (CRYPTO_EX_dup *) # $free_func - function pointer ??? (CRYPTO_EX_free *) # # returns: (integer) ??? Check openssl doc L =item * SESSION_get_master_key B Does not exactly correspond to any low level API function Returns 'master_key' value from SSL_SESSION structure $s Net::SSLeay::SESSION_get_master_key($s); # $s - value corresponding to openssl's SSL_SESSION structure # # returns: master key (binary data) =item * SESSION_set_master_key Sets 'master_key' value for SSL_SESSION structure $s Net::SSLeay::SESSION_set_master_key($s, $key); # $s - value corresponding to openssl's SSL_SESSION structure # $key - master key (binary data) # # returns: no return value Not available with OpenSSL 1.1 and later. Code that previously used SESSION_set_master_key must now set $secret in the session_secret callback set with SSL_set_session_secret_cb. =item * SESSION_get_time Returns the time at which the session s was established. The time is given in seconds since 1.1.1970. my $rv = Net::SSLeay::SESSION_get_time($s); # $s - value corresponding to openssl's SSL_SESSION structure # # returns: timestamp (seconds since 1.1.1970) Check openssl doc L =item * get_time Technically the same functionality as L. my $rv = Net::SSLeay::get_time($s); =item * SESSION_get_timeout Returns the timeout value set for session $s in seconds. my $rv = Net::SSLeay::SESSION_get_timeout($s); # $s - value corresponding to openssl's SSL_SESSION structure # # returns: timeout (in seconds) Check openssl doc L =item * get_timeout Technically the same functionality as L. my $rv = Net::SSLeay::get_timeout($s); =item * SESSION_print B Does not exactly correspond to any low level API function Prints session details (e.g. protocol version, cipher, session-id ...) to BIO. my $rv = Net::SSLeay::SESSION_print($fp, $ses); # $fp - value corresponding to openssl's BIO structure # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: 1 on success, 0 on failure You have to use necessary BIO functions like this: # let us have $ssl corresponding to openssl's SSL structure my $ses = Net::SSLeay::get_session($ssl); my $bio = Net::SSLeay::BIO_new(&Net::SSLeay::BIO_s_mem); Net::SSLeay::SESSION_print($bio, $ses); print Net::SSLeay::BIO_read($bio); =item * SESSION_print_fp Prints session details (e.g. protocol version, cipher, session-id ...) to file handle. my $rv = Net::SSLeay::SESSION_print_fp($fp, $ses); # $fp - perl file handle # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: 1 on success, 0 on failure Example: # let us have $ssl corresponding to openssl's SSL structure my $ses = Net::SSLeay::get_session($ssl); open my $fh, ">", "output.txt"; Net::SSLeay::SESSION_print_fp($fh,$ses); =item * SESSION_set_time Replaces the creation time of the session s with the chosen value $t (seconds since 1.1.1970). my $rv = Net::SSLeay::SESSION_set_time($ses, $t); # $ses - value corresponding to openssl's SSL_SESSION structure # $t - time value # # returns: 1 on success Check openssl doc L =item * set_time Technically the same functionality as L. my $rv = Net::SSLeay::set_time($ses, $t); =item * SESSION_set_timeout Sets the timeout value for session s in seconds to $t. my $rv = Net::SSLeay::SESSION_set_timeout($s, $t); # $s - value corresponding to openssl's SSL_SESSION structure # $t - timeout (in seconds) # # returns: 1 on success Check openssl doc L =item * set_timeout Technically the same functionality as L. my $rv = Net::SSLeay::set_timeout($ses, $t); =back =head3 Low level API: SSL_CTX_* related functions B Please note that the function described in this chapter have "SSL_" part stripped from their original openssl names. =over =item * CTX_add_client_CA Adds the CA name extracted from $cacert to the list of CAs sent to the client when requesting a client certificate for $ctx. my $rv = Net::SSLeay::CTX_add_client_CA($ctx, $cacert); # $ctx - value corresponding to openssl's SSL_CTX structure # $cacert - value corresponding to openssl's X509 structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * CTX_add_extra_chain_cert Adds the certificate $x509 to the certificate chain presented together with the certificate. Several certificates can be added one after the other. my $rv = Net::SSLeay::CTX_add_extra_chain_cert($ctx, $x509); # $ctx - value corresponding to openssl's SSL_CTX structure # $x509 - value corresponding to openssl's X509 structure # # returns: 1 on success, check out the error stack to find out the reason for failure otherwise Check openssl doc L =item * CTX_add_session Adds the session $ses to the context $ctx. my $rv = Net::SSLeay::CTX_add_session($ctx, $ses); # $ctx - value corresponding to openssl's SSL_CTX structure # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * CTX_callback_ctrl ??? (more info needed) my $rv = Net::SSLeay::CTX_callback_ctrl($ctx, $cmd, $fp); # $ctx - value corresponding to openssl's SSL_CTX structure # $cmd - (integer) command id # $fp - (function pointer) ??? # # returns: ??? Check openssl doc L =item * CTX_check_private_key Checks the consistency of a private key with the corresponding certificate loaded into $ctx. my $rv = Net::SSLeay::CTX_check_private_key($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * CTX_ctrl Internal handling function for SSL_CTX objects. B openssl doc says: This function should never be called directly! my $rv = Net::SSLeay::CTX_ctrl($ctx, $cmd, $larg, $parg); # $ctx - value corresponding to openssl's SSL_CTX structure # $cmd - (integer) command id # $larg - (integer) long ??? # $parg - (string/pointer) ??? # # returns: (long) result of given command ??? #valid $cmd values 1 - SSL_CTRL_NEED_TMP_RSA 2 - SSL_CTRL_SET_TMP_RSA 3 - SSL_CTRL_SET_TMP_DH 4 - SSL_CTRL_SET_TMP_ECDH 5 - SSL_CTRL_SET_TMP_RSA_CB 6 - SSL_CTRL_SET_TMP_DH_CB 7 - SSL_CTRL_SET_TMP_ECDH_CB 8 - SSL_CTRL_GET_SESSION_REUSED 9 - SSL_CTRL_GET_CLIENT_CERT_REQUEST 10 - SSL_CTRL_GET_NUM_RENEGOTIATIONS 11 - SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS 12 - SSL_CTRL_GET_TOTAL_RENEGOTIATIONS 13 - SSL_CTRL_GET_FLAGS 14 - SSL_CTRL_EXTRA_CHAIN_CERT 15 - SSL_CTRL_SET_MSG_CALLBACK 16 - SSL_CTRL_SET_MSG_CALLBACK_ARG 17 - SSL_CTRL_SET_MTU 20 - SSL_CTRL_SESS_NUMBER 21 - SSL_CTRL_SESS_CONNECT 22 - SSL_CTRL_SESS_CONNECT_GOOD 23 - SSL_CTRL_SESS_CONNECT_RENEGOTIATE 24 - SSL_CTRL_SESS_ACCEPT 25 - SSL_CTRL_SESS_ACCEPT_GOOD 26 - SSL_CTRL_SESS_ACCEPT_RENEGOTIATE 27 - SSL_CTRL_SESS_HIT 28 - SSL_CTRL_SESS_CB_HIT 29 - SSL_CTRL_SESS_MISSES 30 - SSL_CTRL_SESS_TIMEOUTS 31 - SSL_CTRL_SESS_CACHE_FULL 32 - SSL_CTRL_OPTIONS 33 - SSL_CTRL_MODE 40 - SSL_CTRL_GET_READ_AHEAD 41 - SSL_CTRL_SET_READ_AHEAD 42 - SSL_CTRL_SET_SESS_CACHE_SIZE 43 - SSL_CTRL_GET_SESS_CACHE_SIZE 44 - SSL_CTRL_SET_SESS_CACHE_MODE 45 - SSL_CTRL_GET_SESS_CACHE_MODE 50 - SSL_CTRL_GET_MAX_CERT_LIST 51 - SSL_CTRL_SET_MAX_CERT_LIST 52 - SSL_CTRL_SET_MAX_SEND_FRAGMENT 53 - SSL_CTRL_SET_TLSEXT_SERVERNAME_CB 54 - SSL_CTRL_SET_TLSEXT_SERVERNAME_ARG 55 - SSL_CTRL_SET_TLSEXT_HOSTNAME 56 - SSL_CTRL_SET_TLSEXT_DEBUG_CB 57 - SSL_CTRL_SET_TLSEXT_DEBUG_ARG 58 - SSL_CTRL_GET_TLSEXT_TICKET_KEYS 59 - SSL_CTRL_SET_TLSEXT_TICKET_KEYS 60 - SSL_CTRL_SET_TLSEXT_OPAQUE_PRF_INPUT 61 - SSL_CTRL_SET_TLSEXT_OPAQUE_PRF_INPUT_CB 62 - SSL_CTRL_SET_TLSEXT_OPAQUE_PRF_INPUT_CB_ARG 63 - SSL_CTRL_SET_TLSEXT_STATUS_REQ_CB 64 - SSL_CTRL_SET_TLSEXT_STATUS_REQ_CB_ARG 65 - SSL_CTRL_SET_TLSEXT_STATUS_REQ_TYPE 66 - SSL_CTRL_GET_TLSEXT_STATUS_REQ_EXTS 67 - SSL_CTRL_SET_TLSEXT_STATUS_REQ_EXTS 68 - SSL_CTRL_GET_TLSEXT_STATUS_REQ_IDS 69 - SSL_CTRL_SET_TLSEXT_STATUS_REQ_IDS 70 - SSL_CTRL_GET_TLSEXT_STATUS_REQ_OCSP_RESP 71 - SSL_CTRL_SET_TLSEXT_STATUS_REQ_OCSP_RESP 72 - SSL_CTRL_SET_TLSEXT_TICKET_KEY_CB 73 - DTLS_CTRL_GET_TIMEOUT 74 - DTLS_CTRL_HANDLE_TIMEOUT 75 - DTLS_CTRL_LISTEN 76 - SSL_CTRL_GET_RI_SUPPORT 77 - SSL_CTRL_CLEAR_OPTIONS 78 - SSL_CTRL_CLEAR_MODE 82 - SSL_CTRL_GET_EXTRA_CHAIN_CERTS 83 - SSL_CTRL_CLEAR_EXTRA_CHAIN_CERTS 88 - SSL_CTRL_CHAIN 89 - SSL_CTRL_CHAIN_CERT 90 - SSL_CTRL_GET_CURVES 91 - SSL_CTRL_SET_CURVES 92 - SSL_CTRL_SET_CURVES_LIST 93 - SSL_CTRL_GET_SHARED_CURVE 94 - SSL_CTRL_SET_ECDH_AUTO 97 - SSL_CTRL_SET_SIGALGS 98 - SSL_CTRL_SET_SIGALGS_LIST 99 - SSL_CTRL_CERT_FLAGS 100 - SSL_CTRL_CLEAR_CERT_FLAGS 101 - SSL_CTRL_SET_CLIENT_SIGALGS 102 - SSL_CTRL_SET_CLIENT_SIGALGS_LIST 103 - SSL_CTRL_GET_CLIENT_CERT_TYPES 104 - SSL_CTRL_SET_CLIENT_CERT_TYPES 105 - SSL_CTRL_BUILD_CERT_CHAIN 106 - SSL_CTRL_SET_VERIFY_CERT_STORE 107 - SSL_CTRL_SET_CHAIN_CERT_STORE 108 - SSL_CTRL_GET_PEER_SIGNATURE_NID 109 - SSL_CTRL_GET_SERVER_TMP_KEY 110 - SSL_CTRL_GET_RAW_CIPHERLIST 111 - SSL_CTRL_GET_EC_POINT_FORMATS 112 - SSL_CTRL_GET_TLSA_RECORD 113 - SSL_CTRL_SET_TLSA_RECORD 114 - SSL_CTRL_PULL_TLSA_RECORD Check openssl doc L =item * CTX_flush_sessions Causes a run through the session cache of $ctx to remove sessions expired at time $tm. Net::SSLeay::CTX_flush_sessions($ctx, $tm); # $ctx - value corresponding to openssl's SSL_CTX structure # $tm - specifies the time which should be used for the expiration test (seconds since 1.1.1970) # # returns: no return value Check openssl doc L =item * CTX_free Free an allocated SSL_CTX object. Net::SSLeay::CTX_free($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: no return value Check openssl doc L =item * CTX_get_app_data Can be used to get application defined value/data. my $rv = Net::SSLeay::CTX_get_app_data($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: string/buffer/pointer ??? =item * CTX_set_app_data Can be used to set some application defined value/data. my $rv = Net::SSLeay::CTX_set_app_data($ctx, $arg); # $ctx - value corresponding to openssl's SSL_CTX structure # $arg - (string/buffer/pointer ???) data # # returns: ??? =item * CTX_get0_param B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Returns the current verification parameters. my $vpm = Net::SSLeay::CTX_get0_param($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: value corresponding to openssl's X509_VERIFY_PARAM structure Check openssl doc L =item * CTX_get_cert_store Returns the current certificate verification storage. my $rv = Net::SSLeay::CTX_get_cert_store($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: value corresponding to openssl's X509_STORE structure (0 on failure) Check openssl doc L =item * CTX_get_client_CA_list Returns the list of client CAs explicitly set for $ctx using L. my $rv = Net::SSLeay::CTX_get_client_CA_list($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: value corresponding to openssl's X509_NAME_STACK structure (0 on failure) Check openssl doc L =item * CTX_get_ex_data Is used to retrieve the information for index $idx from $ctx. my $rv = Net::SSLeay::CTX_get_ex_data($ssl, $idx); # $ssl - value corresponding to openssl's SSL_CTX structure # $idx - (integer) index for application specific data # # returns: pointer to ??? Check openssl doc L =item * CTX_get_ex_new_index Is used to register a new index for application specific data. my $rv = Net::SSLeay::CTX_get_ex_new_index($argl, $argp, $new_func, $dup_func, $free_func); # $argl - (long) ??? # $argp - (pointer) ??? # $new_func - function pointer ??? (CRYPTO_EX_new *) # $dup_func - function pointer ??? (CRYPTO_EX_dup *) # $free_func - function pointer ??? (CRYPTO_EX_free *) # # returns: (integer) ??? Check openssl doc L =item * CTX_get_mode Returns the mode set for ctx. my $rv = Net::SSLeay::CTX_get_mode($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: mode (bitmask) #to decode the return value (bitmask) use: 0x00000001 corresponds to SSL_MODE_ENABLE_PARTIAL_WRITE 0x00000002 corresponds to SSL_MODE_ACCEPT_MOVING_WRITE_BUFFER 0x00000004 corresponds to SSL_MODE_AUTO_RETRY 0x00000008 corresponds to SSL_MODE_NO_AUTO_CHAIN 0x00000010 corresponds to SSL_MODE_RELEASE_BUFFERS (note: some of the bits might not be supported by older openssl versions) Check openssl doc L =item * CTX_set_mode Adds the mode set via bitmask in $mode to $ctx. Options already set before are not cleared. my $rv = Net::SSLeay::CTX_set_mode($ctx, $mode); # $ctx - value corresponding to openssl's SSL_CTX structure # $mode - mode bitmask # # returns: the new mode bitmask after adding $mode For bitmask details see L (above). Check openssl doc L =item * CTX_get_options Returns the options (bitmask) set for $ctx. my $rv = Net::SSLeay::CTX_get_options($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: options (bitmask) B The available constants and their values in bitmask depend on the TLS library. For example, SSL_OP_NO_TLSv1_3 became available much later than SSL_OP_NO_COMPRESS which is already deprecated by some libraries. Also, some previously used option values have been recycled and are now used for newer options. See the list of constants in this document for options Net::SSLeay currently supports. You are strongly encouraged to B if you need to use numeric values directly. The following is a sample of historic values. It may not be correct anymore. #to decode the return value (bitmask) use: 0x00000004 corresponds to SSL_OP_LEGACY_SERVER_CONNECT 0x00000800 corresponds to SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS 0x00004000 corresponds to SSL_OP_NO_TICKET 0x00010000 corresponds to SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION 0x00400000 corresponds to SSL_OP_CIPHER_SERVER_PREFERENCE 0x04000000 corresponds to SSL_OP_NO_TLSv1 Check openssl doc L =item * CTX_set_options Adds the options set via bitmask in $options to ctx. Options already set before are not cleared. Net::SSLeay::CTX_set_options($ctx, $options); # $ctx - value corresponding to openssl's SSL_CTX structure # $options - options bitmask # # returns: the new options bitmask after adding $options For bitmask details see L (above). Check openssl doc L =item * CTX_get_quiet_shutdown Returns the 'quiet shutdown' setting of $ctx. my $rv = Net::SSLeay::CTX_get_quiet_shutdown($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: (integer) the current setting Check openssl doc L =item * CTX_get_read_ahead my $rv = Net::SSLeay::CTX_get_read_ahead($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: (integer) read_ahead value =item * CTX_get_session_cache_mode Returns the currently used cache mode (bitmask). my $rv = Net::SSLeay::CTX_get_session_cache_mode($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: mode (bitmask) B SESS_CACHE_OFF and other constants are not available in Net-SSLeay-1.82 and before. If the constants are not available, the following values have historically been correct. You are strongly encouraged to B for the current values. #to decode the return value (bitmask) use: 0x0000 corresponds to SSL_SESS_CACHE_OFF 0x0001 corresponds to SSL_SESS_CACHE_CLIENT 0x0002 corresponds to SSL_SESS_CACHE_SERVER 0x0080 corresponds to SSL_SESS_CACHE_NO_AUTO_CLEAR 0x0100 corresponds to SSL_SESS_CACHE_NO_INTERNAL_LOOKUP 0x0200 corresponds to SSL_SESS_CACHE_NO_INTERNAL_STORE (note: some of the bits might not be supported by older openssl versions) Check openssl doc L =item * CTX_set_session_cache_mode Enables/disables session caching by setting the operational mode for $ctx to $mode. my $rv = Net::SSLeay::CTX_set_session_cache_mode($ctx, $mode); # $ctx - value corresponding to openssl's SSL_CTX structure # $mode - mode (bitmask) # # returns: previously set cache mode For bitmask details see L (above). Check openssl doc L =item * CTX_get_timeout Returns the currently set timeout value for $ctx. my $rv = Net::SSLeay::CTX_get_timeout($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: timeout in seconds Check openssl doc L =item * CTX_get_verify_depth Returns the verification depth limit currently set in $ctx. If no limit has been explicitly set, -1 is returned and the default value will be used.", my $rv = Net::SSLeay::CTX_get_verify_depth($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: depth limit currently set in $ctx, -1 if no limit has been explicitly set Check openssl doc L =item * CTX_get_verify_mode Returns the verification mode (bitmask) currently set in $ctx. my $rv = Net::SSLeay::CTX_get_verify_mode($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: mode (bitmask) For bitmask details see L. Check openssl doc L =item * CTX_set_verify Sets the verification flags for $ctx to be $mode and specifies the verify_callback function to be used. Net::SSLeay::CTX_set_verify($ctx, $mode, $callback); # $ctx - value corresponding to openssl's SSL_CTX structure # $mode - mode (bitmask), see OpenSSL manual # $callback - [optional] reference to perl callback function # # returns: no return value Check openssl doc L =item * CTX_set_post_handshake_auth B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Enable the Post-Handshake Authentication extension to be added to the ClientHello such that post-handshake authentication can be requested by the server. Net::SSLeay::CTX_set_posthandshake_auth($ctx, $val); # $ctx - value corresponding to openssl's SSL_CTX structure # $val - 0 then the extension is not sent, otherwise it is # # returns: no return value Check openssl doc L =item * CTX_load_verify_locations Specifies the locations for $ctx, at which CA certificates for verification purposes are located. The certificates available via $CAfile and $CApath are trusted. my $rv = Net::SSLeay::CTX_load_verify_locations($ctx, $CAfile, $CApath); # $ctx - value corresponding to openssl's SSL_CTX structure # $CAfile - (string) file of CA certificates in PEM format, the file can contain several CA certificates (or '') # $CApath - (string) directory containing CA certificates in PEM format (or '') # # returns: 1 on success, 0 on failure (check the error stack to find out the reason) Check openssl doc L =item * CTX_need_tmp_RSA Return the result of C my $rv = Net::SSLeay::CTX_need_tmp_RSA($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: result of SSL_CTRL_NEED_TMP_RSA command Not available with OpenSSL 1.1 and later. =item * CTX_new The same as L my $rv = Net::SSLeay::CTX_new(); # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) Check openssl doc L Not available with OpenSSL 1.1 and later. =item * CTX_v2_new Creates a new SSL_CTX object - based on SSLv2_method() - as framework to establish TLS/SSL enabled connections. my $rv = Net::SSLeay::CTX_v2_new(); # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) =item * CTX_v23_new Creates a new SSL_CTX object - based on SSLv23_method() - as framework to establish TLS/SSL enabled connections. my $rv = Net::SSLeay::CTX_v23_new(); # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) =item * CTX_v3_new Creates a new SSL_CTX object - based on SSLv3_method() - as framework to establish TLS/SSL enabled connections. my $rv = Net::SSLeay::CTX_v3_new(); # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) =item * CTX_tlsv1_new Creates a new SSL_CTX object - based on TLSv1_method() - as framework to establish TLS/SSL enabled connections. my $rv = Net::SSLeay::CTX_tlsv1_new(); # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) =item * CTX_tlsv1_1_new Creates a new SSL_CTX object - based on TLSv1_1_method() - as framework to establish TLS/SSL enabled connections. Only available where supported by the underlying openssl. my $rv = Net::SSLeay::CTX_tlsv1_1_new(); # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) =item * CTX_tlsv1_2_new Creates a new SSL_CTX object - based on TLSv1_2_method() - as framework to establish TLS/SSL enabled connections. Only available where supported by the underlying openssl. my $rv = Net::SSLeay::CTX_tlsv1_2_new(); # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) =item * CTX_new_with_method Creates a new SSL_CTX object based on $meth method my $rv = Net::SSLeay::CTX_new_with_method($meth); # $meth - value corresponding to openssl's SSL_METHOD structure # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) #example my $ctx = Net::SSLeay::CTX_new_with_method(&Net::SSLeay::TLSv1_method); Check openssl doc L =item * CTX_set_min_proto_version, CTX_set_max_proto_version, set_min_proto_version and set_max_proto_version, B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.1.0 or LibreSSL 2.6.0 Set the minimum and maximum supported protocol for $ctx or $ssl. my $rv = Net::SSLeay::CTX_set_min_proto_version($ctx, $version) # $ctx - value corresponding to openssl's SSL_CTX structure # $version - (integer) constat version value or 0 for automatic lowest or highest value # # returns: 1 on success, 0 on failure #example: allow only TLS 1.2 for a SSL_CTX my $rv_min = Net::SSLeay::CTX_set_min_proto_version($ctx, Net::SSLeay::TLS1_2_VERSION()); my $rv_max = Net::SSLeay::CTX_set_max_proto_version($ctx, Net::SSLeay::TLS1_2_VERSION()); #example: allow only TLS 1.1 for a SSL my $rv_min = Net::SSLeay::set_min_proto_version($ssl, Net::SSLeay::TLS1_1_VERSION()); my $rv_max = Net::SSLeay::set_max_proto_version($ssl, Net::SSLeay::TLS1_1_VERSION()); Check openssl doc L =item * CTX_get_min_proto_version, CTX_get_max_proto_version, get_min_proto_version and get_max_proto_version, B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.1.0g Get the minimum and maximum supported protocol for $ctx or $ssl. my $version = Net::SSLeay::CTX_get_min_proto_version($ctx) # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: 0 automatic lowest or highest value, configured value otherwise Check openssl doc L =item * CTX_remove_session Removes the session $ses from the context $ctx. my $rv = Net::SSLeay::CTX_remove_session($ctx, $ses); # $ctx - value corresponding to openssl's SSL_CTX structure # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * CTX_sess_accept my $rv = Net::SSLeay::CTX_sess_accept($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of started SSL/TLS handshakes in server mode Check openssl doc L =item * CTX_sess_accept_good my $rv = Net::SSLeay::CTX_sess_accept_good($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of successfully established SSL/TLS sessions in server mode Check openssl doc L =item * CTX_sess_accept_renegotiate my $rv = Net::SSLeay::CTX_sess_accept_renegotiate($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of start renegotiations in server mode Check openssl doc L =item * CTX_sess_cache_full my $rv = Net::SSLeay::CTX_sess_cache_full($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of sessions that were removed because the maximum session cache size was exceeded Check openssl doc L =item * CTX_sess_cb_hits my $rv = Net::SSLeay::CTX_sess_cb_hits($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of successfully retrieved sessions from the external session cache in server mode Check openssl doc L =item * CTX_sess_connect my $rv = Net::SSLeay::CTX_sess_connect($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of started SSL/TLS handshakes in client mode Check openssl doc L =item * CTX_sess_connect_good my $rv = Net::SSLeay::CTX_sess_connect_good($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of successfully established SSL/TLS sessions in client mode Check openssl doc L =item * CTX_sess_connect_renegotiate my $rv = Net::SSLeay::CTX_sess_connect_renegotiate($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of start renegotiations in client mode Check openssl doc L =item * CTX_sess_get_cache_size Returns the currently valid session cache size. my $rv = Net::SSLeay::CTX_sess_get_cache_size($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: current size Check openssl doc L =item * CTX_sess_hits my $rv = Net::SSLeay::CTX_sess_hits($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of successfully reused sessions Check openssl doc L =item * CTX_sess_misses my $rv = Net::SSLeay::CTX_sess_misses($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of sessions proposed by clients that were not found in the internal session cache in server mode Check openssl doc L =item * CTX_sess_number my $rv = Net::SSLeay::CTX_sess_number($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: current number of sessions in the internal session cache Check openssl doc L =item * CTX_sess_set_cache_size Sets the size of the internal session cache of context $ctx to $size. Net::SSLeay::CTX_sess_set_cache_size($ctx, $size); # $ctx - value corresponding to openssl's SSL_CTX structure # $size - cache size (0 = unlimited) # # returns: previously valid size Check openssl doc L =item * CTX_sess_timeouts Returns the number of sessions proposed by clients and either found in the internal or external session cache in server mode, but that were invalid due to timeout. These sessions are not included in the SSL_CTX_sess_hits count. my $rv = Net::SSLeay::CTX_sess_timeouts($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: number of sessions Check openssl doc L =item * CTX_sess_set_new_cb B not available in Net-SSLeay-1.85 and before Sets the callback function, which is automatically called whenever a new session was negotiated. Net::SSLeay::CTX_sess_set_new_cb($ctx, $func); # $ctx - value corresponding to openssl's SSL_CTX structure # $func - perl reference to callback function # # returns: no return value Check openssl doc L =item * CTX_sess_set_remove_cb B not available in Net-SSLeay-1.85 and before Sets the callback function, which is automatically called whenever a session is removed by the SSL engine. Net::SSLeay::CTX_sess_set_remove_cb($ctx, $func); # $ctx - value corresponding to openssl's SSL_CTX structure # $func - perl reference to callback function # # returns: no return value Check openssl doc L =item * CTX_sessions Returns a pointer to the lhash databases containing the internal session cache for ctx. my $rv = Net::SSLeay::CTX_sessions($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: value corresponding to openssl's LHASH structure (0 on failure) Check openssl doc L =item * CTX_set1_param Applies X509 verification parameters $vpm on $ctx my $rv = Net::SSLeay::CTX_set1_param($ctx, $vpm); # $ctx - value corresponding to openssl's SSL_CTX structure # $vpm - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * CTX_set_cert_store Sets/replaces the certificate verification storage of $ctx to/with $store. Net::SSLeay::CTX_set_cert_store($ctx, $store); # $ctx - value corresponding to openssl's SSL_CTX structure # $store - value corresponding to openssl's X509_STORE structure # # returns: no return value Check openssl doc L =item * CTX_set_cert_verify_callback Sets the verification callback function for $ctx. SSL objects that are created from $ctx inherit the setting valid at the time when C is called. Net::SSLeay::CTX_set_cert_verify_callback($ctx, $func, $data); # $ctx - value corresponding to openssl's SSL_CTX structure # $func - perl reference to callback function # $data - [optional] data that will be passed to callback function when invoked # # returns: no return value Check openssl doc L =item * CTX_set_cipher_list Sets the list of available ciphers for $ctx using the control string $str. The list of ciphers is inherited by all ssl objects created from $ctx. my $rv = Net::SSLeay::CTX_set_cipher_list($s, $str); # $s - value corresponding to openssl's SSL_CTX structure # $str - (string) cipher list e.g. '3DES:+RSA' # # returns: 1 if any cipher could be selected and 0 on complete failure The format of $str is described in L Check openssl doc L =item * CTX_set_ciphersuites B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Configure the available TLSv1.3 ciphersuites. my $rv = Net::SSLeay::CTX_set_ciphersuites($ctx, $str); # $ctx - value corresponding to openssl's SSL_CTX structure # $str - colon (":") separated list of TLSv1.3 ciphersuite names in order of preference # # returns: (integer) 1 if the requested ciphersuite list was configured, and 0 otherwise Check openssl doc L =item * CTX_set_client_CA_list Sets the list of CAs sent to the client when requesting a client certificate for $ctx. Net::SSLeay::CTX_set_client_CA_list($ctx, $list); # $ctx - value corresponding to openssl's SSL_CTX structure # $list - value corresponding to openssl's X509_NAME_STACK structure # # returns: no return value Check openssl doc L =item * CTX_set_default_passwd_cb Sets the default password callback called when loading/storing a PEM certificate with encryption. Net::SSLeay::CTX_set_default_passwd_cb($ctx, $func); # $ctx - value corresponding to openssl's SSL_CTX structure # $func - perl reference to callback function # # returns: no return value Check openssl doc L =item * CTX_set_default_passwd_cb_userdata Sets a pointer to userdata which will be provided to the password callback on invocation. Net::SSLeay::CTX_set_default_passwd_cb_userdata($ctx, $userdata); # $ctx - value corresponding to openssl's SSL_CTX structure # $userdata - data that will be passed to callback function when invoked # # returns: no return value Check openssl doc L =item * CTX_set_default_verify_paths ??? (more info needed) my $rv = Net::SSLeay::CTX_set_default_verify_paths($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: 1 on success, 0 on failure =item * CTX_set_ex_data Is used to store application data at $data for $idx into the $ctx object. my $rv = Net::SSLeay::CTX_set_ex_data($ssl, $idx, $data); # $ssl - value corresponding to openssl's SSL_CTX structure # $idx - (integer) ??? # $data - (pointer) ??? # # returns: 1 on success, 0 on failure Check openssl doc L =item * CTX_set_purpose my $rv = Net::SSLeay::CTX_set_purpose($s, $purpose); # $s - value corresponding to openssl's SSL_CTX structure # $purpose - (integer) purpose identifier # # returns: 1 on success, 0 on failure #avainable purpose identifier 1 - X509_PURPOSE_SSL_CLIENT 2 - X509_PURPOSE_SSL_SERVER 3 - X509_PURPOSE_NS_SSL_SERVER 4 - X509_PURPOSE_SMIME_SIGN 5 - X509_PURPOSE_SMIME_ENCRYPT 6 - X509_PURPOSE_CRL_SIGN 7 - X509_PURPOSE_ANY 8 - X509_PURPOSE_OCSP_HELPER 9 - X509_PURPOSE_TIMESTAMP_SIGN #or use corresponding constants $purpose = &Net::SSLeay::X509_PURPOSE_SSL_CLIENT; ... $purpose = &Net::SSLeay::X509_PURPOSE_TIMESTAMP_SIGN; =item * CTX_set_quiet_shutdown Sets the 'quiet shutdown' flag for $ctx to be mode. SSL objects created from $ctx inherit the mode valid at the time C is called. Net::SSLeay::CTX_set_quiet_shutdown($ctx, $mode); # $ctx - value corresponding to openssl's SSL_CTX structure # $mode - 0 or 1 # # returns: no return value Check openssl doc L =item * CTX_set_read_ahead my $rv = Net::SSLeay::CTX_set_read_ahead($ctx, $val); # $ctx - value corresponding to openssl's SSL_CTX structure # $val - read_ahead value to be set # # returns: the original read_ahead value =item * CTX_set_session_id_context Sets the context $sid_ctx of length $sid_ctx_len within which a session can be reused for the $ctx object. my $rv = Net::SSLeay::CTX_set_session_id_context($ctx, $sid_ctx, $sid_ctx_len); # $ctx - value corresponding to openssl's SSL_CTX structure # $sid_ctx - data buffer # $sid_ctx_len - length of data in $sid_ctx # # returns: 1 on success, 0 on failure (the error is logged to the error stack) Check openssl doc L =item * CTX_set_ssl_version Sets a new default TLS/SSL method for SSL objects newly created from this $ctx. SSL objects already created with C are not affected, except when C is being called. my $rv = Net::SSLeay::CTX_set_ssl_version($ctx, $meth); # $ctx - value corresponding to openssl's SSL_CTX structure # $meth - value corresponding to openssl's SSL_METHOD structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * CTX_set_timeout Sets the timeout for newly created sessions for $ctx to $t. The timeout value $t must be given in seconds. my $rv = Net::SSLeay::CTX_set_timeout($ctx, $t); # $ctx - value corresponding to openssl's SSL_CTX structure # $t - timeout in seconds # # returns: previously set timeout value Check openssl doc L =item * CTX_set_tmp_dh Sets DH parameters to be used to be $dh. The key is inherited by all ssl objects created from $ctx. my $rv = Net::SSLeay::CTX_set_tmp_dh($ctx, $dh); # $ctx - value corresponding to openssl's SSL_CTX structure # $dh - value corresponding to openssl's DH structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * CTX_set_tmp_dh_callback Sets the callback function for $ctx to be used when a DH parameters are required to $tmp_dh_callback. Net::SSLeay::CTX_set_tmp_dh_callback($ctx, $tmp_dh_callback); # $ctx - value corresponding to openssl's SSL_CTX structure # tmp_dh_callback - (function pointer) ??? # # returns: no return value Check openssl doc L =item * CTX_set_tmp_rsa Sets the temporary/ephemeral RSA key to be used to be $rsa. my $rv = Net::SSLeay::CTX_set_tmp_rsa($ctx, $rsa); # $ctx - value corresponding to openssl's SSL_CTX structure # $rsa - value corresponding to openssl's RSA structure # # returns: 1 on success, 0 on failure Check openssl doc L Not available with OpenSSL 1.1 and later. =item * CTX_set_tmp_rsa_callback Sets the callback function for ctx to be used when a temporary/ephemeral RSA key is required to $tmp_rsa_callback. ??? (does this function really work?) Net::SSLeay::CTX_set_tmp_rsa_callback($ctx, $tmp_rsa_callback); # $ctx - value corresponding to openssl's SSL_CTX structure # $tmp_rsa_callback - (function pointer) ??? # # returns: no return value Check openssl doc L Not available with OpenSSL 1.1 and later. =item * CTX_set_trust my $rv = Net::SSLeay::CTX_set_trust($s, $trust); # $s - value corresponding to openssl's SSL_CTX structure # $trust - (integer) trust identifier # # returns: the original value #available trust identifiers 1 - X509_TRUST_COMPAT 2 - X509_TRUST_SSL_CLIENT 3 - X509_TRUST_SSL_SERVER 4 - X509_TRUST_EMAIL 5 - X509_TRUST_OBJECT_SIGN 6 - X509_TRUST_OCSP_SIGN 7 - X509_TRUST_OCSP_REQUEST 8 - X509_TRUST_TSA #or use corresponding constants $trust = &Net::SSLeay::X509_TRUST_COMPAT; ... $trust = &Net::SSLeay::X509_TRUST_TSA; =item * CTX_set_verify_depth Sets the maximum depth for the certificate chain verification that shall be allowed for ctx. Net::SSLeay::CTX_set_verify_depth($ctx, $depth); # $ctx - value corresponding to openssl's SSL_CTX structure # $depth - max. depth # # returns: no return value Check openssl doc L =item * CTX_use_PKCS12_file Adds the certificate and private key from PKCS12 file $p12filename to $ctx. my $rv = Net::SSLeay::CTX_use_PKCS12_file($ctx, $p12filename, $password); # $ctx - value corresponding to openssl's SSL_CTX structure # $p12filename - (string) filename # $password - (string) password to decrypt private key # # returns: 1 on success, 0 on failure =item * CTX_use_PrivateKey Adds the private key $pkey to $ctx. my $rv = Net::SSLeay::CTX_use_PrivateKey($ctx, $pkey); # $ctx - value corresponding to openssl's SSL_CTX structure # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * CTX_use_PrivateKey_file Adds the first private key found in $file to $ctx. my $rv = Net::SSLeay::CTX_use_PrivateKey_file($ctx, $file, $type); # $ctx - value corresponding to openssl's SSL_CTX structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * CTX_use_RSAPrivateKey Adds the RSA private key $rsa to $ctx. my $rv = Net::SSLeay::CTX_use_RSAPrivateKey($ctx, $rsa); # $ctx - value corresponding to openssl's SSL_CTX structure # $rsa - value corresponding to openssl's RSA structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * CTX_use_RSAPrivateKey_file Adds the first RSA private key found in $file to $ctx. my $rv = Net::SSLeay::CTX_use_RSAPrivateKey_file($ctx, $file, $type); # $ctx - value corresponding to openssl's SSL_CTX structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, otherwise check out the error stack to find out the reason =item * CTX_use_certificate Loads the certificate $x into $ctx my $rv = Net::SSLeay::CTX_use_certificate($ctx, $x); # $ctx - value corresponding to openssl's SSL_CTX structure # $x - value corresponding to openssl's X509 structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * CTX_use_certificate_chain_file Loads a certificate chain from $file into $ctx. The certificates must be in PEM format and must be sorted starting with the subject's certificate (actual client or server certificate), followed by intermediate CA certificates if applicable, and ending at the highest level (root) CA. my $rv = Net::SSLeay::CTX_use_certificate_chain_file($ctx, $file); # $ctx - value corresponding to openssl's SSL_CTX structure # $file - (string) file name # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * CTX_use_certificate_file Loads the first certificate stored in $file into $ctx. my $rv = Net::SSLeay::CTX_use_certificate_file($ctx, $file, $type); # $ctx - value corresponding to openssl's SSL_CTX structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * CTX_get_security_level B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0, not in LibreSSL Returns the security level associated with $ctx. my $level = Net::SSLeay::CTX_get_security_level($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: (integer) current security level Check openssl doc L =item * CTX_set_security_level B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0, not in LibreSSL Sets the security level associated with $ctx to $level. Net::SSLeay::CTX_set_security_level($ctx, $level); # $ssl - value corresponding to openssl's SSL_CTX structure # $level - new security level # # returns: no return value Check openssl doc L =item * CTX_set_num_tickets B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Set number of TLSv1.3 session tickets that will be sent to a client. my $rv = Net::SSLeay::CTX_set_num_tickets($ctx, $number_of_tickets); # $ctx - value corresponding to openssl's SSL_CTX structure # $number_of_tickets - number of tickets to send # # returns: 1 on success, 0 on failure Set to zero if you do not no want to support a session resumption. Check openssl doc L =item * CTX_get_num_tickets B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Get number of TLSv1.3 session tickets that will be sent to a client. my $number_of_tickets = Net::SSLeay::CTX_get_num_tickets($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: (integer) number of tickets to send Check openssl doc L =back =head3 Low level API: SSL_* related functions B Please note that the function described in this chapter have "SSL_" part stripped from their original openssl names. =over =item * new Creates a new SSL structure which is needed to hold the data for a TLS/SSL connection. The new structure inherits the settings of the underlying context $ctx: connection method (SSLv2/v3/TLSv1), options, verification settings, timeout settings. my $rv = Net::SSLeay::new($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: value corresponding to openssl's SSL structure (0 on failure) Check openssl doc L =item * accept Waits for a TLS/SSL client to initiate the TLS/SSL handshake. The communication channel must already have been set and assigned to the ssl by setting an underlying BIO. my $rv = Net::SSLeay::accept($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 1 = success, 0 = handshake not successful, <0 = fatal error during handshake Check openssl doc L =item * add_client_CA Adds the CA name extracted from cacert to the list of CAs sent to the client when requesting a client certificate for the chosen ssl, overriding the setting valid for ssl's SSL_CTX object. my $rv = Net::SSLeay::add_client_CA($ssl, $x); # $ssl - value corresponding to openssl's SSL structure # $x - value corresponding to openssl's X509 structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * callback_ctrl ??? (more info needed) my $rv = Net::SSLeay::callback_ctrl($ssl, $cmd, $fp); # $ssl - value corresponding to openssl's SSL structure # $cmd - (integer) command id # $fp - (function pointer) ??? # # returns: ??? Check openssl doc L =item * check_private_key Checks the consistency of a private key with the corresponding certificate loaded into $ssl my $rv = Net::SSLeay::check_private_key($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * clear Reset SSL object to allow another connection. Net::SSLeay::clear($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: no return value Check openssl doc L =item * connect Initiate the TLS/SSL handshake with an TLS/SSL server. my $rv = Net::SSLeay::connect($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 1 = success, 0 = handshake not successful, <0 = fatal error during handshake Check openssl doc L =item * copy_session_id Copies the session structure fro $from to $to (+ also the private key and certificate associated with $from). Net::SSLeay::copy_session_id($to, $from); # $to - value corresponding to openssl's SSL structure # $from - value corresponding to openssl's SSL structure # # returns: no return value =item * ctrl Internal handling function for SSL objects. B openssl doc says: This function should never be called directly! my $rv = Net::SSLeay::ctrl($ssl, $cmd, $larg, $parg); # $ssl - value corresponding to openssl's SSL structure # $cmd - (integer) command id # $larg - (integer) long ??? # $parg - (string/pointer) ??? # # returns: (long) result of given command ??? For more details about valid $cmd values check L. Check openssl doc L =item * do_handshake Will wait for a SSL/TLS handshake to take place. If the connection is in client mode, the handshake will be started. The handshake routines may have to be explicitly set in advance using either SSL_set_connect_state or SSL_set_accept_state(3). my $rv = Net::SSLeay::do_handshake($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 1 = success, 0 = handshake not successful, <0 = fatal error during handshake Check openssl doc L =item * dup Returns a duplicate of $ssl. my $rv = Net::SSLeay::dup($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's SSL structure (0 on failure) =item * free Free an allocated SSL structure. Net::SSLeay::free($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: no return value Check openssl doc L =item * get0_param B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Returns the current verification parameters. my $vpm = Net::SSLeay::get0_param($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's X509_VERIFY_PARAM structure Check openssl doc L =item * get_SSL_CTX Returns a pointer to the SSL_CTX object, from which $ssl was created with Net::SSLeay::new. my $rv = Net::SSLeay::get_SSL_CTX($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's SSL_CTX structure (0 on failure) Check openssl doc L =item * set_SSL_CTX Sets the SSL_CTX the corresponds to an SSL session. my $the_ssl_ctx = Net::SSLeay::set_SSL_CTX($ssl, $ssl_ctx); # $ssl - value corresponding to openssl's SSL structure # $ssl_ctx - Change the ssl object to the given ssl_ctx # # returns - the ssl_ctx =item * get_app_data Can be used to get application defined value/data. my $rv = Net::SSLeay::get_app_data($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: string/buffer/pointer ??? =item * set_app_data Can be used to set some application defined value/data. my $rv = Net::SSLeay::set_app_data($ssl, $arg); # $ssl - value corresponding to openssl's SSL structure # $arg - (string/buffer/pointer ???) data # # returns: ??? =item * get_certificate Gets X509 certificate from an established SSL connection. my $rv = Net::SSLeay::get_certificate($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's X509 structure (0 on failure) =item * get_cipher Obtains the name of the currently used cipher. my $rv = Net::SSLeay::get_cipher($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (string) cipher name e.g. 'DHE-RSA-AES256-SHA' or '', when no session has been established. Check openssl doc L =item * get_cipher_bits Obtain the number of secret/algorithm bits used. my $rv = Net::SSLeay::get_cipher_bits($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: number of secret bits used by current cipher Check openssl doc L and L =item * get_cipher_list Returns the name (string) of the SSL_CIPHER listed for $ssl with priority $n. my $rv = Net::SSLeay::get_cipher_list($ssl, $n); # $ssl - value corresponding to openssl's SSL structure # $n - (integer) priority # # returns: (string) cipher name e.g. 'EDH-DSS-DES-CBC3-SHA' or '' in case of error Call Net::SSLeay::get_cipher_list with priority starting from 0 to obtain the sorted list of available ciphers, until '' is returned: my $priority = 0; while (my $c = Net::SSLeay::get_cipher_list($ssl, $priority)) { print "cipher[$priority] = $c\n"; $priority++; } Check openssl doc L =item * get_client_CA_list Returns the list of client CAs explicitly set for $ssl using C or $ssl's SSL_CTX object with C, when in server mode. In client mode, returns the list of client CAs sent from the server, if any. my $rv = Net::SSLeay::get_client_CA_list($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's STACK_OF(X509_NAME) structure (0 on failure) Check openssl doc L =item * get_current_cipher Returns the cipher actually used. my $rv = Net::SSLeay::get_current_cipher($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's SSL_CIPHER structure (0 on failure) Check openssl doc L =item * get_default_timeout Returns the default timeout value assigned to SSL_SESSION objects negotiated for the protocol valid for $ssl. my $rv = Net::SSLeay::get_default_timeout($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (long) timeout in seconds Check openssl doc L =item * get_error Returns a result code for a preceding call to C, C, C, C, C or C on $ssl. my $rv = Net::SSLeay::get_error($ssl, $ret); # $ssl - value corresponding to openssl's SSL structure # $ret - return value of preceding TLS/SSL I/O operation # # returns: result code, which is one of the following values: # 0 - SSL_ERROR_NONE # 1 - SSL_ERROR_SSL # 2 - SSL_ERROR_WANT_READ # 3 - SSL_ERROR_WANT_WRITE # 4 - SSL_ERROR_WANT_X509_LOOKUP # 5 - SSL_ERROR_SYSCALL # 6 - SSL_ERROR_ZERO_RETURN # 7 - SSL_ERROR_WANT_CONNECT # 8 - SSL_ERROR_WANT_ACCEPT Check openssl doc L =item * get_ex_data Is used to retrieve the information for $idx from $ssl. my $rv = Net::SSLeay::get_ex_data($ssl, $idx); # $ssl - value corresponding to openssl's SSL structure # $idx - (integer) index for application specific data # # returns: pointer to ??? Check openssl doc L =item * set_ex_data Is used to store application data at $data for $idx into the $ssl object. my $rv = Net::SSLeay::set_ex_data($ssl, $idx, $data); # $ssl - value corresponding to openssl's SSL structure # $idx - (integer) ??? # $data - (pointer) ??? # # returns: 1 on success, 0 on failure Check openssl doc L =item * get_ex_new_index Is used to register a new index for application specific data. my $rv = Net::SSLeay::get_ex_new_index($argl, $argp, $new_func, $dup_func, $free_func); # $argl - (long) ??? # $argp - (pointer) ??? # $new_func - function pointer ??? (CRYPTO_EX_new *) # $dup_func - function pointer ??? (CRYPTO_EX_dup *) # $free_func - function pointer ??? (CRYPTO_EX_free *) # # returns: (integer) ??? Check openssl doc L =item * get_fd Returns the file descriptor which is linked to $ssl. my $rv = Net::SSLeay::get_fd($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: file descriptor (>=0) or -1 on failure Check openssl doc L =item * get_finished Obtains the latest 'Finished' message sent to the peer. Return value is zero if there's been no Finished message yet. Default count is 2*EVP_MAX_MD_SIZE that is long enough for all possible Finish messages. If you supply a non-default count, the resulting return value may be longer than returned buf's length. my $rv = Net::SSLeay::get_finished($ssl, $buf, $count); # $ssl - value corresponding to openssl's SSL structure # $buf - buffer where the returned data will be stored # $count - [optional] max size of return data - default is 2*EVP_MAX_MD_SIZE # # returns: length of latest Finished message =item * get_peer_finished Obtains the latest 'Finished' message expected from the peer. Parameters and return value are similar to get_finished(). my $rv = Net::SSLeay::get_peer_finished($ssl, $buf, $count); # $ssl - value corresponding to openssl's SSL structure # $buf - buffer where the returned data will be stored # $count - [optional] max size of return data - default is 2*EVP_MAX_MD_SIZE # # returns: length of latest Finished message =item * get_keyblock_size Gets the length of the TLS keyblock. B Does not exactly correspond to any low level API function. my $rv = Net::SSLeay::get_keyblock_size($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: keyblock size, -1 on error =item * get_mode Returns the mode (bitmask) set for $ssl. my $rv = Net::SSLeay::get_mode($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: mode (bitmask) To decode the return value (bitmask) see documentation for L. Check openssl doc L =item * set_mode Adds the mode set via bitmask in $mode to $ssl. Options already set before are not cleared. my $rv = Net::SSLeay::set_mode($ssl, $mode); # $ssl - value corresponding to openssl's SSL structure # $mode - mode (bitmask) # # returns: the new mode bitmask after adding $mode For $mode bitmask details see L. Check openssl doc L =item * get_options Returns the options (bitmask) set for $ssl. my $rv = Net::SSLeay::get_options($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: options (bitmask) To decode the return value (bitmask) see documentation for L. Check openssl doc L =item * set_options Adds the options set via bitmask in $options to $ssl. Options already set before are not cleared! Net::SSLeay::set_options($ssl, $options); # $ssl - value corresponding to openssl's SSL structure # $options - options (bitmask) # # returns: the new options bitmask after adding $options For $options bitmask details see L. Check openssl doc L =item * get_peer_certificate Get the X509 certificate of the peer. my $rv = Net::SSLeay::get_peer_certificate($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's X509 structure (0 on failure) Check openssl doc L =item * get_peer_cert_chain Get the certificate chain of the peer as an array of X509 structures. my @rv = Net::SSLeay::get_peer_cert_chain($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: list of X509 structures Check openssl doc L =item * get_quiet_shutdown Returns the 'quiet shutdown' setting of ssl. my $rv = Net::SSLeay::get_quiet_shutdown($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) current 'quiet shutdown' value Check openssl doc L =item * get_rbio Get 'read' BIO linked to an SSL object $ssl. my $rv = Net::SSLeay::get_rbio($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's BIO structure (0 on failure) Check openssl doc L =item * get_read_ahead my $rv = Net::SSLeay::get_read_ahead($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) read_ahead value =item * set_read_ahead Net::SSLeay::set_read_ahead($ssl, $val); # $ssl - value corresponding to openssl's SSL structure # $val - read_ahead value to be set # # returns: the original read_ahead value =item * get_security_level B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0, not in LibreSSL Returns the security level associated with $ssl. my $level = Net::SSLeay::get_security_level($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) current security level Check openssl doc L =item * set_security_level B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0, not in LibreSSL Sets the security level associated with $ssl to $level. Net::SSLeay::set_security_level($ssl, $level); # $ssl - value corresponding to openssl's SSL structure # $level - new security level # # returns: no return value Check openssl doc L =item * set_num_tickets B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Set number of TLSv1.3 session tickets that will be sent to a client. my $rv = Net::SSLeay::set_num_tickets($ssl, $number_of_tickets); # $ssl - value corresponding to openssl's SSL structure # $number_of_tickets - number of tickets to send # # returns: 1 on success, 0 on failure Set to zero if you do not no want to support a session resumption. Check openssl doc L =item * get_num_tickets B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Get number of TLSv1.3 session tickets that will be sent to a client. my $number_of_tickets = Net::SSLeay::get_num_tickets($ctx); # $ctx - value corresponding to openssl's SSL structure # # returns: number of tickets to send Check openssl doc L =item * get_server_random Returns internal SSLv3 server_random value. Net::SSLeay::get_server_random($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: server_random value (binary data) =item * get_client_random B Does not exactly correspond to any low level API function Returns internal SSLv3 client_random value. Net::SSLeay::get_client_random($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: client_random value (binary data) =item * export_keying_material Returns keying material based on the string $label and optional $context. Note that with TLSv1.2 and lower, empty context (empty string) and undefined context (no value or 'undef') will return different values. my $out = Net::SSLeay::export_keying_material($ssl, $olen, $label, $context); # $ssl - value corresponding to openssl's SSL structure # $olen - number of bytes to return # $label - application specific label # $context - [optional] context - default is undef for no context # # returns: keying material (binary data) or undef on error Check openssl doc L =item * get_session Retrieve TLS/SSL session data used in $ssl. The reference count of the SSL_SESSION is NOT incremented. my $rv = Net::SSLeay::get_session($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's SSL_SESSION structure (0 on failure) Check openssl doc L =item * SSL_get0_session The alias for L (note that the name is C NOT C). my $rv = Net::SSLeay::SSL_get0_session(); =item * get1_session Returns a pointer to the SSL_SESSION actually used in $ssl. The reference count of the SSL_SESSION is incremented by 1. my $rv = Net::SSLeay::get1_session($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's SSL_SESSION structure (0 on failure) Check openssl doc L =item * get_shared_ciphers Returns string with a list (colon ':' separated) of ciphers shared between client and server within SSL session $ssl. my $rv = Net::SSLeay::get_shared_ciphers() # # returns: string like 'ECDHE-RSA-AES256-SHA:ECDHE-ECDSA-AES256-SHA:DHE-RSA-AES256-SHA:DHE-DSS-AES256-SHA:...' =item * get_shutdown Returns the shutdown mode of $ssl. my $rv = Net::SSLeay::get_shutdown($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: shutdown mode (bitmask) of ssl #to decode the return value (bitmask) use: 0 - No shutdown setting, yet 1 - SSL_SENT_SHUTDOWN 2 - SSL_RECEIVED_SHUTDOWN Check openssl doc L =item * get_ssl_method Returns a function pointer to the TLS/SSL method set in $ssl. my $rv = Net::SSLeay::get_ssl_method($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's SSL_METHOD structure (0 on failure) Check openssl doc L =item * in_init, in_before, is_init_finished, in_connect_init, in_accept_init B not available in Net-SSLeay-1.85 and before. Retrieve information about the handshake state machine. All functions take $ssl as the only argument and return 0 or 1. These functions are recommended over get_state() and state(). my $rv = Net::SSLeay::is_init_finished($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: All functions return 1 or 0 Check openssl doc L =item * get_state B OpenSSL 1.1.0 and later use different constants which are not made available. Use is_init_finished() and related functions instead. Returns the SSL connection state. my $rv = Net::SSLeay::get_state($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) state value # to decode the returned state check: # SSL_ST_* constants in openssl/ssl.h # SSL2_ST_* constants in openssl/ssl2.h # SSL23_ST_* constants in openssl/ssl23.h # SSL3_ST_* + DTLS1_ST_* constants in openssl/ssl3.h =item * state Exactly the same as L. my $rv = Net::SSLeay::state($ssl); =item * set_state Sets the SSL connection state. Net::SSLeay::set_state($ssl,Net::SSLeay::SSL_ST_ACCEPT()); Not available with OpenSSL 1.1 and later. =item * get_verify_depth Returns the verification depth limit currently set in $ssl. my $rv = Net::SSLeay::get_verify_depth($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: current depth or -1 if no limit has been explicitly set Check openssl doc L =item * set_verify_depth Sets the maximum depth for the certificate chain verification that shall be allowed for $ssl. Net::SSLeay::set_verify_depth($ssl, $depth); # $ssl - value corresponding to openssl's SSL structure # $depth - (integer) depth # # returns: no return value Check openssl doc L =item * get_verify_mode Returns the verification mode (bitmask) currently set in $ssl. my $rv = Net::SSLeay::get_verify_mode($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: mode (bitmask) To decode the return value (bitmask) see documentation for L. Check openssl doc L =item * set_verify Sets the verification flags for $ssl to be $mode and specifies the $verify_callback function to be used. Net::SSLeay::set_verify($ssl, $mode, $callback); # $ssl - value corresponding to openssl's SSL structure # $mode - mode (bitmask) # $callback - [optional] reference to perl callback function # # returns: no return value For $mode bitmask details see L. Check openssl doc L =item * set_post_handshake_auth B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Enable the Post-Handshake Authentication extension to be added to the ClientHello such that post-handshake authentication can be requested by the server. Net::SSLeay::set_posthandshake_auth($ssl, $val); # $ssl - value corresponding to openssl's SSL structure # $val - 0 then the extension is not sent, otherwise it is # # returns: no return value Check openssl doc L =item * verify_client_post_handshake B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL verify_client_post_handshake causes a CertificateRequest message to be sent by a server on the given ssl connection. my $rv = Net::SSLeay::verify_client_post_handshake($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 1 if the request succeeded, and 0 if the request failed. The error stack can be examined to determine the failure reason. Check openssl doc L =item * get_verify_result Returns the result of the verification of the X509 certificate presented by the peer, if any. my $rv = Net::SSLeay::get_verify_result($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) # 0 - X509_V_OK: ok # 2 - X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT: unable to get issuer certificate # 3 - X509_V_ERR_UNABLE_TO_GET_CRL: unable to get certificate CRL # 4 - X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE: unable to decrypt certificate's signature # 5 - X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE: unable to decrypt CRL's signature # 6 - X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY: unable to decode issuer public key # 7 - X509_V_ERR_CERT_SIGNATURE_FAILURE: certificate signature failure # 8 - X509_V_ERR_CRL_SIGNATURE_FAILURE: CRL signature failure # 9 - X509_V_ERR_CERT_NOT_YET_VALID: certificate is not yet valid # 10 - X509_V_ERR_CERT_HAS_EXPIRED: certificate has expired # 11 - X509_V_ERR_CRL_NOT_YET_VALID: CRL is not yet valid # 12 - X509_V_ERR_CRL_HAS_EXPIRED: CRL has expired # 13 - X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD: format error in certificate's notBefore field # 14 - X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD: format error in certificate's notAfter field # 15 - X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD: format error in CRL's lastUpdate field # 16 - X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD: format error in CRL's nextUpdate field # 17 - X509_V_ERR_OUT_OF_MEM: out of memory # 18 - X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT: self signed certificate # 19 - X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN: self signed certificate in certificate chain # 20 - X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY: unable to get local issuer certificate # 21 - X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE: unable to verify the first certificate # 22 - X509_V_ERR_CERT_CHAIN_TOO_LONG: certificate chain too long # 23 - X509_V_ERR_CERT_REVOKED: certificate revoked # 24 - X509_V_ERR_INVALID_CA: invalid CA certificate # 25 - X509_V_ERR_PATH_LENGTH_EXCEEDED: path length constraint exceeded # 26 - X509_V_ERR_INVALID_PURPOSE: unsupported certificate purpose # 27 - X509_V_ERR_CERT_UNTRUSTED: certificate not trusted # 28 - X509_V_ERR_CERT_REJECTED: certificate rejected # 29 - X509_V_ERR_SUBJECT_ISSUER_MISMATCH: subject issuer mismatch # 30 - X509_V_ERR_AKID_SKID_MISMATCH: authority and subject key identifier mismatch # 31 - X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH: authority and issuer serial number mismatch # 32 - X509_V_ERR_KEYUSAGE_NO_CERTSIGN:key usage does not include certificate signing # 50 - X509_V_ERR_APPLICATION_VERIFICATION: application verification failure Check openssl doc L =item * set_verify_result Override result of peer certificate verification. Net::SSLeay::set_verify_result($ssl, $v); # $ssl - value corresponding to openssl's SSL structure # $v - (integer) result value # # returns: no return value For more info about valid return values see L Check openssl doc L =item * get_wbio Get 'write' BIO linked to an SSL object $ssl. my $rv = Net::SSLeay::get_wbio($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: value corresponding to openssl's BIO structure (0 on failure) Check openssl doc L =item * load_client_CA_file Load X509 certificates from file (PEM formatted). my $rv = Net::SSLeay::load_client_CA_file($file); # $file - (string) file name # # returns: value corresponding to openssl's STACK_OF(X509_NAME) structure (0 on failure) Check openssl doc L =item * clear_num_renegotiations Executes SSL_CTRL_CLEAR_NUM_RENEGOTIATIONS command on $ssl. my $rv = Net::SSLeay::clear_num_renegotiations($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: command result =item * need_tmp_RSA Executes SSL_CTRL_NEED_TMP_RSA command on $ssl. my $rv = Net::SSLeay::need_tmp_RSA($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: command result Not available with OpenSSL 1.1 and later. =item * num_renegotiations Executes SSL_CTRL_GET_NUM_RENEGOTIATIONS command on $ssl. my $rv = Net::SSLeay::num_renegotiations($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: command result =item * total_renegotiations Executes SSL_CTRL_GET_TOTAL_RENEGOTIATIONS command on $ssl. my $rv = Net::SSLeay::total_renegotiations($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: command result =item * peek Copies $max bytes from the specified $ssl into the returned value. In contrast to the C function, the data in the SSL buffer is unmodified after the SSL_peek() operation. Net::SSLeay::peek($ssl, $max); # $ssl - value corresponding to openssl's SSL structure # $max - [optional] max bytes to peek (integer) - default is 32768 # # in scalar context: data read from the TLS/SSL connection, undef on error # in list context: two-item array consisting of data read (undef on error), # and return code from SSL_peek(). =item * peek_ex B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Copies $max bytes from the specified $ssl into the returned value. In contrast to the C function, the data in the SSL buffer is unmodified after the SSL_peek_ex() operation. my($got, $rv) = Net::SSLeay::peek_ex($ssl, $max); # $ssl - value corresponding to openssl's SSL structure # $max - [optional] max bytes to peek (integer) - default is 32768 # # returns a list: two-item list consisting of data read (undef on error), # and return code from SSL_peek_ex(). Check openssl doc L =item * pending Obtain number of readable bytes buffered in $ssl object. my $rv = Net::SSLeay::pending($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: the number of bytes pending Check openssl doc L =item * has_pending B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0, not in LibreSSL Returns 1 if $ssl has buffered data (whether processed or unprocessed) and 0 otherwise. my $rv = Net::SSLeay::has_pending($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) 1 or 0 Check openssl doc L =item * read Tries to read $max bytes from the specified $ssl. my $got = Net::SSLeay::read($ssl, $max); my($got, $rv) = Net::SSLeay::read($ssl, $max); # $ssl - value corresponding to openssl's SSL structure # $max - [optional] max bytes to read (integer) - default is 32768 # # returns: # in scalar context: data read from the TLS/SSL connection, undef on error # in list context: two-item array consisting of data read (undef on error), # and return code from SSL_read(). Check openssl doc L =item * read_ex B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Tries to read $max bytes from the specified $ssl. my($got, $rv) = Net::SSLeay::read_ex($ssl, $max); # $ssl - value corresponding to openssl's SSL structure # $max - [optional] max bytes to read (integer) - default is 32768 # # returns a list: two-item list consisting of data read (undef on error), # and return code from SSL_read_ex(). Check openssl doc L =item * renegotiate Turn on flags for renegotiation so that renegotiation will happen my $rv = Net::SSLeay::renegotiate($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 1 on success, 0 on failure =item * rstate_string Returns a 2 letter string indicating the current read state of the SSL object $ssl. my $rv = Net::SSLeay::rstate_string($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 2-letter string Check openssl doc L =item * rstate_string_long Returns a string indicating the current read state of the SSL object ssl. my $rv = Net::SSLeay::rstate_string_long($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: string with current state Check openssl doc L =item * session_reused Query whether a reused session was negotiated during handshake. my $rv = Net::SSLeay::session_reused($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 0 - new session was negotiated; 1 - session was reused. Check openssl doc L =item * set1_param Applies X509 verification parameters $vpm on $ssl my $rv = Net::SSLeay::set1_param($ssl, $vpm); # $ssl - value corresponding to openssl's SSL structure # $vpm - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: 1 on success, 0 on failure =item * set_accept_state Sets $ssl to work in server mode. Net::SSLeay::set_accept_state($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: no return value Check openssl doc L =item * set_bio Connects the BIOs $rbio and $wbio for the read and write operations of the TLS/SSL (encrypted) side of $ssl. Net::SSLeay::set_bio($ssl, $rbio, $wbio); # $ssl - value corresponding to openssl's SSL structure # $rbio - value corresponding to openssl's BIO structure # $wbio - value corresponding to openssl's BIO structure # # returns: no return value Check openssl doc L =item * set_cipher_list Sets the list of ciphers only for ssl. my $rv = Net::SSLeay::set_cipher_list($ssl, $str); # $ssl - value corresponding to openssl's SSL structure # $str - (string) cipher list e.g. '3DES:+RSA' # # returns: 1 if any cipher could be selected and 0 on complete failure Check openssl doc L =item * set_ciphersuites B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Configure the available TLSv1.3 ciphersuites. my $rv = Net::SSLeay::set_ciphersuites($ssl, $str); # $ssl - value corresponding to openssl's SSL structure # $str - colon (":") separated list of TLSv1.3 ciphersuite names in order of preference # # returns: (integer) 1 if the requested ciphersuite list was configured, and 0 otherwise Check openssl doc L =item * set_client_CA_list Sets the list of CAs sent to the client when requesting a client certificate for the chosen $ssl, overriding the setting valid for $ssl's SSL_CTX object. my $rv = Net::SSLeay::set_client_CA_list($ssl, $list); # $ssl - value corresponding to openssl's SSL structure # $list - value corresponding to openssl's STACK_OF(X509_NAME) structure # # returns: no return value Check openssl doc L =item * set_connect_state Sets $ssl to work in client mode. Net::SSLeay::set_connect_state($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: no return value Check openssl doc L =item * set_fd Sets the file descriptor $fd as the input/output facility for the TLS/SSL (encrypted) side of $ssl, $fd will typically be the socket file descriptor of a network connection. my $rv = Net::SSLeay::set_fd($ssl, $fd); # $ssl - value corresponding to openssl's SSL structure # $fd - (integer) file handle (got via perl's fileno) # # returns: 1 on success, 0 on failure Check openssl doc L =item * set_psk_client_callback Sets the psk client callback. Net::SSLeay::set_psk_client_callback($ssl, sub { my $hint = shift; return ($identity, $key) } ); # $ssl - value corresponding to openssl's SSL structure # $hint - PSK identity hint send by the server # $identity - PSK identity # $key - PSK key, hex string without the leading '0x', e.g. 'deadbeef' # # returns: no return value Check openssl doc L =item * set_rfd Sets the file descriptor $fd as the input (read) facility for the TLS/SSL (encrypted) side of $ssl. my $rv = Net::SSLeay::set_rfd($ssl, $fd); # $ssl - value corresponding to openssl's SSL structure # $fd - (integer) file handle (got via perl's fileno) # # returns: 1 on success, 0 on failure Check openssl doc L =item * set_wfd my $rv = Net::SSLeay::set_wfd($ssl, $fd); # $ssl - value corresponding to openssl's SSL structure # $fd - (integer) file handle (got via perl's fileno) # # returns: 1 on success, 0 on failure Check openssl doc L =item * set_info_callback Sets the callback function, that can be used to obtain state information for $ssl during connection setup and use. When callback is undef, the callback setting currently valid for ctx is used. Net::SSLeay::set_info_callback($ssl, $cb, [$data]); # $ssl - value corresponding to openssl's SSL structure # $cb - sub { my ($ssl,$where,$ret,$data) = @_; ... } # # returns: no return value Check openssl doc L =item * CTX_set_info_callback Sets the callback function on ctx, that can be used to obtain state information during ssl connection setup and use. When callback is undef, an existing callback will be disabled. Net::SSLeay::CTX_set_info_callback($ssl, $cb, [$data]); # $ssl - value corresponding to openssl's SSL structure # $cb - sub { my ($ssl,$where,$ret,$data) = @_; ... } # # returns: no return value Check openssl doc L =item * set_pref_cipher Sets the list of available ciphers for $ssl using the control string $str. my $rv = Net::SSLeay::set_pref_cipher($ssl, $str); # $ssl - value corresponding to openssl's SSL structure # $str - (string) cipher list e.g. '3DES:+RSA' # # returns: 1 if any cipher could be selected and 0 on complete failure Check openssl doc L =item * CTX_set_psk_client_callback Sets the psk client callback. Net::SSLeay::CTX_set_psk_client_callback($ssl, sub { my $hint = shift; return ($identity, $key) } ); # $ssl - value corresponding to openssl's SSL structure # $hint - PSK identity hint send by the server # $identity - PSK identity # $key - PSK key, hex string without the leading '0x', e.g. 'deadbeef' # # returns: no return value Check openssl doc L =item * set_purpose my $rv = Net::SSLeay::set_purpose($ssl, $purpose); # $ssl - value corresponding to openssl's SSL structure # $purpose - (integer) purpose identifier # # returns: 1 on success, 0 on failure For more info about available $purpose identifiers see L. =item * set_quiet_shutdown Sets the 'quiet shutdown' flag for $ssl to be $mode. Net::SSLeay::set_quiet_shutdown($ssl, $mode); # $ssl - value corresponding to openssl's SSL structure # $mode - 0 or 1 # # returns: no return value Check openssl doc L =item * set_session Set a TLS/SSL session to be used during TLS/SSL connect. my $rv = Net::SSLeay::set_session($to, $ses); # $to - value corresponding to openssl's SSL structure # $ses - value corresponding to openssl's SSL_SESSION structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * set_session_id_context Sets the context $sid_ctx of length $sid_ctx_len within which a session can be reused for the $ssl object. my $rv = Net::SSLeay::set_session_id_context($ssl, $sid_ctx, $sid_ctx_len); # $ssl - value corresponding to openssl's SSL structure # $sid_ctx - data buffer # $sid_ctx_len - length of data in $sid_ctx # # returns: 1 on success, 0 on failure Check openssl doc L =item * set_session_secret_cb Setup pre-shared secret session resumption function. Net::SSLeay::set_session_secret_cb($ssl, $func, $data); # $ssl - value corresponding to openssl's SSL structure # $func - perl reference to callback function # $data - [optional] data that will be passed to callback function when invoked # # returns: no return value The callback function will be called like: callback_function($secret, $ciphers, $pref_cipher, $data); # $secret is the current master session key, usually all 0s at the beginning of a session # $ciphers is ref to an array of peer cipher names # $pref_cipher is a ref to an index into the list of cipher names of # the preferred cipher. Set it if you want to specify a preferred cipher # $data is the data passed to set_session_secret_cb The callback function should return 1 if it likes the suggested cipher (or has selected an alternative by setting pref_cipher), else it should return 0 (in which case OpenSSL will select its own preferred cipher). With OpenSSL 1.1 and later, callback_function can change the master key for the session by altering $secret and returning 1. =item * CTX_set_tlsext_ticket_getkey_cb Setup encryption for TLS session tickets (stateless session reuse). Net::SSLeay::CTX_set_tlsext_ticket_getkey_cb($ctx, $func, $data); # $ctx - value corresponding to openssl's SSL_CTX structure # $func - perl reference to callback function # $data - [optional] data that will be passed to callback function when invoked # # returns: no return value The callback function will be called like: getkey($data,[$key_name]) -> ($key,$current_key_name) # $data is the data passed to set_session_secret_cb # $key_name is the name of the key OpenSSL has extracted from the session ticket # $key is the requested key for ticket encryption + HMAC # $current_key_name is the name for the currently valid key OpenSSL will call the function without a key name if it generates a new ticket. It then needs the callback to return the encryption+HMAC key and an identifier (key name) for this key. When OpenSSL gets a session ticket from the client it extracts the key name and calls the callback with this name as argument. It then expects the callback to return the encryption+HMAC key matching the requested key name and and also the key name which should be used at the moment. If the requested key name and the returned key name differ it means that this session ticket was created with an expired key and need to be renewed. In this case OpenSSL will call the callback again with no key name to create a new session ticket based on the old one. The key must be at least 32 byte of random data which can be created with RAND_bytes. Internally the first 16 byte are used as key in AES-128 encryption while the next 16 byte are used for the SHA-256 HMAC. The key name are binary data and must be exactly 16 byte long. Example: Net::SSLeay::RAND_bytes(my $oldkey,32); Net::SSLeay::RAND_bytes(my $newkey,32); my $oldkey_name = pack("a16",'oldsecret'); my $newkey_name = pack("a16",'newsecret'); my @keys = ( [ $newkey_name, $newkey ], # current active key [ $oldkey_name, $oldkey ], # already expired ); Net::SSLeay::CTX_set_tlsext_ticket_getkey_cb($server2->_ctx, sub { my ($mykeys,$name) = @_; # return (current_key, current_key_name) if no name given return ($mykeys->[0][1],$mykeys->[0][0]) if ! $name; # return (matching_key, current_key_name) if we find a key matching # the given name for(my $i = 0; $i<@$mykeys; $i++) { next if $name ne $mykeys->[$i][0]; return ($mykeys->[$i][1],$mykeys->[0][0]); } # no matching key found return; },\@keys); This function is based on the OpenSSL function SSL_CTX_set_tlsext_ticket_key_cb but provides a simpler to use interface. For more information see L =item * set_session_ticket_ext_cb Setup callback for TLS session tickets (stateless session reuse). Net::SSLeay::set_session_ticket_ext_cb($ssl, $func, $data); # $ssl - value corresponding to openssl's SSL structure # $func - perl reference to callback function # $data - [optional] data that will be passed to callback function when invoked # # returns: no return value The callback function will be called like: getticket($ssl,$ticket,$data) -> $return_value # $ssl is a value corresponding to openssl's SSL structure # $ticket is a value of received TLS session ticket (can also be empty) # $data is the data passed to set_session_ticket_ext_cb # $return_value is either 0 (failure) or 1 (success) This function is based on the OpenSSL function SSL_set_session_ticket_ext_cb. =item * set_session_ticket_ext Set TLS session ticket (stateless session reuse). Net::SSLeay::set_session_ticket_ext($ssl, $ticket); # $ssl - value corresponding to openssl's SSL structure # $ticket - is a value of TLS session ticket which client will send (can also be empty string) # # returns: no return value The callback function will be called like: getticket($ssl,$ticket,$data) -> $return_value # $ssl is a value corresponding to openssl's SSL structure # $ticket is a value of received TLS session ticket (can also be empty) # $data is the data passed to set_session_ticket_ext_cb # $return_value is either 0 (failure) or 1 (success) This function is based on the OpenSSL function SSL_set_session_ticket_ext_cb. =item * set_shutdown Sets the shutdown state of $ssl to $mode. Net::SSLeay::set_shutdown($ssl, $mode); # $ssl - value corresponding to openssl's SSL structure # $mode - (integer) shutdown mode: # 0 - No shutdown # 1 - SSL_SENT_SHUTDOWN # 2 - SSL_RECEIVED_SHUTDOWN # 3 - SSL_RECEIVED_SHUTDOWN+SSL_SENT_SHUTDOWN # # returns: no return value Check openssl doc L =item * set_ssl_method Sets a new TLS/SSL method for a particular $ssl object. my $rv = Net::SSLeay::set_ssl_method($ssl, $method); # $ssl - value corresponding to openssl's SSL structure # $method - value corresponding to openssl's SSL_METHOD structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * set_tmp_dh Sets DH parameters to be used to be $dh. my $rv = Net::SSLeay::set_tmp_dh($ssl, $dh); # $ssl - value corresponding to openssl's SSL structure # $dh - value corresponding to openssl's DH structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * set_tmp_dh_callback Sets the callback function for $ssl to be used when a DH parameters are required to $dh_cb. ??? (does this function really work?) Net::SSLeay::set_tmp_dh_callback($ssl, $dh); # $ssl - value corresponding to openssl's SSL structure # $dh_cb - pointer to function ??? # # returns: no return value Check openssl doc L =item * set_tmp_rsa Sets the temporary/ephemeral RSA key to be used in $ssl to be $rsa. my $rv = Net::SSLeay::set_tmp_rsa($ssl, $rsa); # $ssl - value corresponding to openssl's SSL structure # $rsa - value corresponding to openssl's RSA structure # # returns: 1 on success, 0 on failure Example: $rsakey = Net::SSLeay::RSA_generate_key(); Net::SSLeay::set_tmp_rsa($ssl, $rsakey); Net::SSLeay::RSA_free($rsakey); Check openssl doc L =item * set_tmp_rsa_callback Sets the callback function for $ssl to be used when a temporary/ephemeral RSA key is required to $tmp_rsa_callback. ??? (does this function really work?) Net::SSLeay::set_tmp_rsa_callback($ssl, $tmp_rsa_callback); # $ssl - value corresponding to openssl's SSL structure # $tmp_rsa_callback - (function pointer) ??? # # returns: no return value Check openssl doc L =item * set_trust my $rv = Net::SSLeay::set_trust($ssl, $trust); # $ssl - value corresponding to openssl's SSL structure # $trust - (integer) trust identifier # # returns: the original value For more details about $trust values see L. =item * shutdown Shuts down an active TLS/SSL connection. It sends the 'close notify' shutdown alert to the peer. my $rv = Net::SSLeay::shutdown($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 1 - shutdown was successfully completed # 0 - shutdown is not yet finished, # -1 - shutdown was not successful Check openssl doc L =item * state_string Returns a 6 letter string indicating the current state of the SSL object $ssl. my $rv = Net::SSLeay::state_string($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: 6-letter string Check openssl doc L =item * state_string_long Returns a string indicating the current state of the SSL object $ssl. my $rv = Net::SSLeay::state_string_long($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: state strings Check openssl doc L =item * set_default_passwd_cb B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.1.0f. Not needed with LibreSSL. Sets the default password callback called when loading/storing a PEM certificate with encryption for $ssl. Net::SSLeay::set_default_passwd_cb($ssl, $func); # $ssl - value corresponding to openssl's SSL structure # $func - perl reference to callback function # # returns: no return value Check openssl doc L =item * set_default_passwd_cb_userdata B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.1.0f. Not needed with LibreSSL. Sets a pointer to userdata which will be provided to the password callback of $ssl on invocation. Net::SSLeay::set_default_passwd_cb_userdata($ssl, $userdata); # $ssl - value corresponding to openssl's SSL structure # $userdata - data that will be passed to callback function when invoked # # returns: no return value Check openssl doc L =item * use_PrivateKey Adds $pkey as private key to $ssl. my $rv = Net::SSLeay::use_PrivateKey($ssl, $pkey); # $ssl - value corresponding to openssl's SSL structure # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_PrivateKey_ASN1 Adds the private key of type $pk stored in $data to $ssl. my $rv = Net::SSLeay::use_PrivateKey_ASN1($pk, $ssl, $d, $len); # $pk - (integer) key type, NID of corresponding algorithm # $ssl - value corresponding to openssl's SSL structure # $data - key data (binary) # $len - length of $data # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_PrivateKey_file Adds the first private key found in $file to $ssl. my $rv = Net::SSLeay::use_PrivateKey_file($ssl, $file, $type); # $ssl - value corresponding to openssl's SSL structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_RSAPrivateKey Adds $rsa as RSA private key to $ssl. my $rv = Net::SSLeay::use_RSAPrivateKey($ssl, $rsa); # $ssl - value corresponding to openssl's SSL structure # $rsa - value corresponding to openssl's RSA structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_RSAPrivateKey_ASN1 Adds RSA private key stored in $data to $ssl. my $rv = Net::SSLeay::use_RSAPrivateKey_ASN1($ssl, $data, $len); # $ssl - value corresponding to openssl's SSL structure # $data - key data (binary) # $len - length of $data # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_RSAPrivateKey_file Adds the first RSA private key found in $file to $ssl. my $rv = Net::SSLeay::use_RSAPrivateKey_file($ssl, $file, $type); # $ssl - value corresponding to openssl's SSL structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_certificate Loads the certificate $x into $ssl. my $rv = Net::SSLeay::use_certificate($ssl, $x); # $ssl - value corresponding to openssl's SSL structure # $x - value corresponding to openssl's X509 structure # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_certificate_ASN1 Loads the ASN1 encoded certificate from $data to $ssl. my $rv = Net::SSLeay::use_certificate_ASN1($ssl, $data, $len); # $ssl - value corresponding to openssl's SSL structure # $data - certificate data (binary) # $len - length of $data # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_certificate_chain_file B: not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.1.0 Loads a certificate chain from $file into $ssl. The certificates must be in PEM format and must be sorted starting with the subject's certificate (actual client or server certificate), followed by intermediate CA certificates if applicable, and ending at the highest level (root) CA. my $rv = Net::SSLeay::use_certificate_chain_file($ssl, $file); # $ssl - value corresponding to openssl's SSL structure # $file - (string) file name # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * use_certificate_file Loads the first certificate stored in $file into $ssl. my $rv = Net::SSLeay::use_certificate_file($ssl, $file, $type); # $ssl - value corresponding to openssl's SSL structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, otherwise check out the error stack to find out the reason Check openssl doc L =item * get_version Returns SSL/TLS protocol name my $rv = Net::SSLeay::get_version($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (string) protocol name, see OpenSSL manual for the full list # TLSv1 # TLSv1.3 Check openssl doc L =item * version Returns SSL/TLS protocol version my $rv = Net::SSLeay::version($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) protocol version, see OpenSSL manual for the full list # 0x0301 - TLS1_VERSION (TLSv1) # 0xFEFF - DTLS1_VERSION (DTLSv1) Check openssl doc L =item * client_version B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0, not in LibreSSL Returns TLS protocol version used by the client when initiating the connection my $rv = Net::SSLeay::client_version($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) protocol version, see OpenSSL manual for the full list # 0x0301 - TLS1_VERSION (TLSv1) # 0xFEFF - DTLS1_VERSION (DTLSv1) Check openssl doc L =item * is_dtls B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.0, not in LibreSSL my $rv = Net::SSLeay::is_dtls($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) zero or one # 0 - connection is not using DTLS # 1 - connection is using DTLS Check openssl doc L =item * want Returns state information for the SSL object $ssl. my $rv = Net::SSLeay::want($ssl); # $ssl - value corresponding to openssl's SSL structure # # returns: state # 1 - SSL_NOTHING # 2 - SSL_WRITING # 3 - SSL_READING # 4 - SSL_X509_LOOKUP Check openssl doc L =item * write Writes data from the buffer $data into the specified $ssl connection. my $rv = Net::SSLeay::write($ssl, $data); # $ssl - value corresponding to openssl's SSL structure # $data - data to be written # # returns: >0 - (success) number of bytes actually written to the TLS/SSL connection # 0 - write not successful, probably the underlying connection was closed # <0 - error Check openssl doc L =item * write_ex B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Writes data from the buffer $data into the specified $ssl connection. my ($len, $rv) = Net::SSLeay::write_ex($ssl, $data); # $ssl - value corresponding to openssl's SSL structure # $data - data to be written # # returns a list: two-item list consisting of number of bytes written, # and return code from SSL_write_ex() Check openssl doc L =item * write_partial B Does not exactly correspond to any low level API function Writes a fragment of data in $data from the buffer $data into the specified $ssl connection. This is a non-blocking function like L. my $rv = Net::SSLeay::write_partial($ssl, $from, $count, $data); # $ssl - value corresponding to openssl's SSL structure # $from - (integer) offset from the beginning of $data # $count - (integer) length of data to be written # $data - data buffer # # returns: >0 - (success) number of bytes actually written to the TLS/SSL connection # 0 - write not successful, probably the underlying connection was closed # <0 - error =item * set_tlsext_host_name B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.8f Sets TLS servername extension on SLL object $ssl to value $name. my $rv = set_tlsext_host_name($ssl, $name); # $ssl - value corresponding to openssl's SSL structure # $name - (string) name to be set # # returns: 1 on success, 0 on failure =back =head3 Low level API: RAND_* related functions Check openssl doc related to RAND stuff L =over =item * RAND_add Mixes the $num bytes at $buf into the PRNG state. Net::SSLeay::RAND_add($buf, $num, $entropy); # $buf - buffer with data to be mixed into the PRNG state # $num - number of bytes in $buf # $entropy - estimate of how much randomness is contained in $buf (in bytes) # # returns: no return value Check openssl doc L =item * RAND_seed Equivalent to L when $num == $entropy. Net::SSLeay::RAND_seed($buf); # Perlishly figures out buf size # $buf - buffer with data to be mixed into the PRNG state # $num - number of bytes in $buf # # returns: no return value Check openssl doc L =item * RAND_status Gives PRNG status (seeded enough or not). my $rv = Net::SSLeay::RAND_status(); #returns: 1 if the PRNG has been seeded with enough data, 0 otherwise Check openssl doc L =item * RAND_bytes Puts $num cryptographically strong pseudo-random bytes into $buf. my $rv = Net::SSLeay::RAND_bytes($buf, $num); # $buf - buffer where the random data will be stored # $num - the size (in bytes) of requested random data # # returns: 1 on success, -1 if not supported by the current RAND method, or 0 on other failure Check openssl doc L =item * RAND_priv_bytes B not available in Net-SSLeay-1.85 and before; requires at least OpenSSL 1.1.1, not in LibreSSL Puts $num cryptographically strong pseudo-random bytes into $buf. my $rv = Net::SSLeay::RAND_priv_bytes($buf, $num); # $buf - buffer where the random data will be stored # $num - the size (in bytes) of requested random data # # returns: 1 on success, -1 if not supported by the current RAND method, or 0 on other failure RAND_priv_bytes has the same semantics as RAND_bytes, but see see the documentation for more information. Check openssl doc L =item * RAND_pseudo_bytes Puts $num pseudo-random (not necessarily unpredictable) bytes into $buf. my $rv = Net::SSLeay::RAND_pseudo_bytes($buf, $num); # $buf - buffer where the random data will be stored # $num - the size (in bytes) of requested random data # # returns: 1 if the bytes generated are cryptographically strong, 0 otherwise Check openssl doc L =item * RAND_cleanup Erase the PRNG state. Net::SSLeay::RAND_cleanup(); # no args, no return value Check openssl doc L =item * RAND_egd_bytes Queries the entropy gathering daemon EGD on socket $path for $bytes bytes. my $rv = Net::SSLeay::RAND_egd_bytes($path, $bytes); # $path - path to a socket of entropy gathering daemon EGD # $bytes - number of bytes we want from EGD # # returns: the number of bytes read from the daemon on success, and -1 on failure Check openssl doc L =item * RAND_file_name Generates a default path for the random seed file. my $file = Net::SSLeay::RAND_file_name($num); # $num - maximum size of returned file name # # returns: string with file name on success, '' (empty string) on failure Check openssl doc L =item * RAND_load_file B Is no longer functional on LibreSSL Reads $max_bytes of bytes from $file_name and adds them to the PRNG. my $rv = Net::SSLeay::RAND_load_file($file_name, $max_bytes); # $file_name - the name of file # $max_bytes - bytes to read from $file_name; -1 => the complete file is read # # returns: the number of bytes read Check openssl doc L =item * RAND_write_file Writes 1024 random bytes to $file_name which can be used to initialize the PRNG by calling L in a later session. my $rv = Net::SSLeay::RAND_write_file($file_name); # $file_name - the name of file # # returns: the number of bytes written, and -1 if the bytes written were generated without appropriate seed Check openssl doc L =item * RAND_poll Collects some entropy from operating system and adds it to the PRNG. my $rv = Net::SSLeay::RAND_poll(); # returns: 1 on success, 0 on failure (unable to gather reasonable entropy) =back =head3 Low level API: OBJ_* related functions =over =item * OBJ_cmp Compares ASN1_OBJECT $a to ASN1_OBJECT $b. my $rv = Net::SSLeay::OBJ_cmp($a, $b); # $a - value corresponding to openssl's ASN1_OBJECT structure # $b - value corresponding to openssl's ASN1_OBJECT structure # # returns: if the two are identical 0 is returned Check openssl doc L =item * OBJ_dup Returns a copy/duplicate of $o. my $rv = Net::SSLeay::OBJ_dup($o); # $o - value corresponding to openssl's ASN1_OBJECT structure # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) Check openssl doc L =item * OBJ_nid2ln Returns long name for given NID $n. my $rv = Net::SSLeay::OBJ_nid2ln($n); # $n - (integer) NID # # returns: (string) long name e.g. 'commonName' Check openssl doc L =item * OBJ_ln2nid Returns NID corresponding to given long name $n. my $rv = Net::SSLeay::OBJ_ln2nid($s); # $s - (string) long name e.g. 'commonName' # # returns: (integer) NID =item * OBJ_nid2sn Returns short name for given NID $n. my $rv = Net::SSLeay::OBJ_nid2sn($n); # $n - (integer) NID # # returns: (string) short name e.g. 'CN' Example: print Net::SSLeay::OBJ_nid2sn(&Net::SSLeay::NID_commonName); =item * OBJ_sn2nid Returns NID corresponding to given short name $s. my $rv = Net::SSLeay::OBJ_sn2nid($s); # $s - (string) short name e.g. 'CN' # # returns: (integer) NID Example: print "NID_commonName constant=", &Net::SSLeay::NID_commonName; print "OBJ_sn2nid('CN')=", Net::SSLeay::OBJ_sn2nid('CN'); =item * OBJ_nid2obj Returns ASN1_OBJECT for given NID $n. my $rv = Net::SSLeay::OBJ_nid2obj($n); # $n - (integer) NID # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) Check openssl doc L =item * OBJ_obj2nid Returns NID corresponding to given ASN1_OBJECT $o. my $rv = Net::SSLeay::OBJ_obj2nid($o); # $o - value corresponding to openssl's ASN1_OBJECT structure # # returns: (integer) NID Check openssl doc L =item * OBJ_txt2obj Converts the text string s into an ASN1_OBJECT structure. If $no_name is 0 then long names (e.g. 'commonName') and short names (e.g. 'CN') will be interpreted as well as numerical forms (e.g. '2.5.4.3'). If $no_name is 1 only the numerical form is acceptable. my $rv = Net::SSLeay::OBJ_txt2obj($s, $no_name); # $s - text string to be converted # $no_name - (integer) 0 or 1 # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) Check openssl doc L =item * OBJ_obj2txt Converts the ASN1_OBJECT a into a textual representation. Net::SSLeay::OBJ_obj2txt($a, $no_name); # $a - value corresponding to openssl's ASN1_OBJECT structure # $no_name - (integer) 0 or 1 # # returns: textual representation e.g. 'commonName' ($no_name=0), '2.5.4.3' ($no_name=1) Check openssl doc L =item * OBJ_txt2nid Returns NID corresponding to text string $s which can be a long name, a short name or the numerical representation of an object. my $rv = Net::SSLeay::OBJ_txt2nid($s); # $s - (string) e.g. 'commonName' or 'CN' or '2.5.4.3' # # returns: (integer) NID Example: my $nid = Net::SSLeay::OBJ_txt2nid('2.5.4.3'); Net::SSLeay::OBJ_nid2sn($n); Check openssl doc L =back =head3 Low level API: ASN1_INTEGER_* related functions =over =item * ASN1_INTEGER_new B not available in Net-SSLeay-1.45 and before Creates a new ASN1_INTEGER structure. my $rv = Net::SSLeay::ASN1_INTEGER_new(); # # returns: value corresponding to openssl's ASN1_INTEGER structure (0 on failure) =item * ASN1_INTEGER_free B not available in Net-SSLeay-1.45 and before Free an allocated ASN1_INTEGER structure. Net::SSLeay::ASN1_INTEGER_free($i); # $i - value corresponding to openssl's ASN1_INTEGER structure # # returns: no return value =item * ASN1_INTEGER_get B not available in Net-SSLeay-1.45 and before Returns integer value of given ASN1_INTEGER object. B If the value stored in ASN1_INTEGER is greater than max. integer that can be stored in 'long' type (usually 32bit but may vary according to platform) then this function will return -1. For getting large ASN1_INTEGER values consider using L or L. my $rv = Net::SSLeay::ASN1_INTEGER_get($a); # $a - value corresponding to openssl's ASN1_INTEGER structure # # returns: integer value of ASN1_INTEGER object in $a =item * ASN1_INTEGER_set B not available in Net-SSLeay-1.45 and before Sets value of given ASN1_INTEGER object to value $val B $val has max. limit (= max. integer that can be stored in 'long' type). For setting large ASN1_INTEGER values consider using L or L. my $rv = Net::SSLeay::ASN1_INTEGER_set($i, $val); # $i - value corresponding to openssl's ASN1_INTEGER structure # $val - integer value # # returns: 1 on success, 0 on failure =item * P_ASN1_INTEGER_get_dec B not available in Net-SSLeay-1.45 and before Returns string with decimal representation of integer value of given ASN1_INTEGER object. Net::SSLeay::P_ASN1_INTEGER_get_dec($i); # $i - value corresponding to openssl's ASN1_INTEGER structure # # returns: string with decimal representation =item * P_ASN1_INTEGER_get_hex B not available in Net-SSLeay-1.45 and before Returns string with hexadecimal representation of integer value of given ASN1_INTEGER object. Net::SSLeay::P_ASN1_INTEGER_get_hex($i); # $i - value corresponding to openssl's ASN1_INTEGER structure # # returns: string with hexadecimal representation =item * P_ASN1_INTEGER_set_dec B not available in Net-SSLeay-1.45 and before Sets value of given ASN1_INTEGER object to value $val (decimal string, suitable for large integers) Net::SSLeay::P_ASN1_INTEGER_set_dec($i, $str); # $i - value corresponding to openssl's ASN1_INTEGER structure # $str - string with decimal representation # # returns: 1 on success, 0 on failure =item * P_ASN1_INTEGER_set_hex B not available in Net-SSLeay-1.45 and before Sets value of given ASN1_INTEGER object to value $val (hexadecimal string, suitable for large integers) Net::SSLeay::P_ASN1_INTEGER_set_hex($i, $str); # $i - value corresponding to openssl's ASN1_INTEGER structure # $str - string with hexadecimal representation # # returns: 1 on success, 0 on failure =back =head3 Low level API: ASN1_STRING_* related functions =over =item * P_ASN1_STRING_get B not available in Net-SSLeay-1.45 and before Returns string value of given ASN1_STRING object. Net::SSLeay::P_ASN1_STRING_get($s, $utf8_decode); # $s - value corresponding to openssl's ASN1_STRING structure # $utf8_decode - [optional] 0 or 1 whether the returned value should be utf8 decoded (default=0) # # returns: string $string = Net::SSLeay::P_ASN1_STRING_get($s); #is the same as: $string = Net::SSLeay::P_ASN1_STRING_get($s, 0); =back =head3 Low level API: ASN1_TIME_* related functions =over =item * ASN1_TIME_new B not available in Net-SSLeay-1.42 and before my $time = ASN1_TIME_new(); # returns: value corresponding to openssl's ASN1_TIME structure =item * ASN1_TIME_free B not available in Net-SSLeay-1.42 and before ASN1_TIME_free($time); # $time - value corresponding to openssl's ASN1_TIME structure =item * ASN1_TIME_set B not available in Net-SSLeay-1.42 and before ASN1_TIME_set($time, $t); # $time - value corresponding to openssl's ASN1_TIME structure # $t - time value in seconds since 1.1.1970 B It is platform dependent how this function will handle dates after 2038. Although perl's integer is large enough the internal implementation of this function is dependent on the size of time_t structure (32bit time_t has problem with 2038). If you want to safely set date and time after 2038 use function L. =item * P_ASN1_TIME_get_isotime B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7e B Does not exactly correspond to any low level API function Gives ISO-8601 string representation of ASN1_TIME structure. my $datetime_string = P_ASN1_TIME_get_isotime($time); # $time - value corresponding to openssl's ASN1_TIME structure # # returns: datetime string like '2033-05-16T20:39:37Z' or '' on failure The output format is compatible with module L =item * P_ASN1_TIME_set_isotime B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7e B Does not exactly correspond to any low level API function Sets time and date value of ANS1_time structure. my $rv = P_ASN1_TIME_set_isotime($time, $string); # $time - value corresponding to openssl's ASN1_TIME structure # $string - ISO-8601 timedate string like '2033-05-16T20:39:37Z' # # returns: 1 on success, 0 on failure The C<$string> parameter has to be in full form like C<"2012-03-22T23:55:33"> or C<"2012-03-22T23:55:33Z"> or C<"2012-03-22T23:55:33CET">. Short forms like C<"2012-03-22T23:55"> or C<"2012-03-22"> are not supported. =item * P_ASN1_TIME_put2string B not available in Net-SSLeay-1.42 and before, has bugs with openssl-0.9.8i B Does not exactly correspond to any low level API function Gives string representation of ASN1_TIME structure. my $str = P_ASN1_TIME_put2string($time); # $time - value corresponding to openssl's ASN1_TIME structure # # returns: datetime string like 'May 16 20:39:37 2033 GMT' =item * P_ASN1_UTCTIME_put2string B deprecated function, only for backward compatibility, just an alias for L =back =head3 Low level API: X509_* related functions =over =item * X509_new B not available in Net-SSLeay-1.45 and before Allocates and initializes a X509 structure. my $rv = Net::SSLeay::X509_new(); # # returns: value corresponding to openssl's X509 structure (0 on failure) Check openssl doc L =item * X509_free Frees up the X509 structure. Net::SSLeay::X509_free($a); # $a - value corresponding to openssl's X509 structure # # returns: no return value Check openssl doc L =item * X509_check_host B not available in Net-SSLeay-1.68 and before; requires at least OpenSSL 1.0.2. X509_CHECK_FLAG_NEVER_CHECK_SUBJECT requires OpenSSL 1.1.0. Checks f the certificate Subject Alternative Name (SAN) or Subject CommonName (CN) matches the specified host name. my $rv = Net::SSLeay::X509_check_host($cert, $name, $flags, $peername); # $cert - value corresponding to openssl's X509 structure # $name - host name to check # $flags (optional, default: 0) - can be the bitwise OR of: # &Net::SSLeay::X509_CHECK_FLAG_ALWAYS_CHECK_SUBJECT # &Net::SSLeay::X509_CHECK_FLAG_NO_WILDCARDS # &Net::SSLeay::X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS # &Net::SSLeay::X509_CHECK_FLAG_MULTI_LABEL_WILDCARDS # &Net::SSLeay::X509_CHECK_FLAG_SINGLE_LABEL_SUBDOMAINS # &Net::SSLeay::X509_CHECK_FLAG_NEVER_CHECK_SUBJECT # $peername (optional) - If not omitted and $host matches $cert, # a copy of the matching SAN or CN from # the peer certificate is stored in $peername. # # returns: # 1 for a successful match # 0 for a failed match # -1 for an internal error # -2 if the input is malformed Check openssl doc L. =item * X509_check_email B not available in Net-SSLeay-1.68 and before; requires at least OpenSSL 1.0.2. Checks if the certificate matches the specified email address. my $rv = Net::SSLeay::X509_check_email($cert, $address, $flags); # $cert - value corresponding to openssl's X509 structure # $address - email address to check # $flags (optional, default: 0) - see X509_check_host() # # returns: see X509_check_host() Check openssl doc L. =item * X509_check_ip B not available in Net-SSLeay-1.68 and before; requires at least OpenSSL 1.0.2. Checks if the certificate matches the specified IPv4 or IPv6 address. my $rv = Net::SSLeay::X509_check_email($cert, $address, $flags); # $cert - value corresponding to openssl's X509 structure # $address - IP address to check in binary format, in network byte order # $flags (optional, default: 0) - see X509_check_host() # # returns: see X509_check_host() Check openssl doc L. =item * X509_check_ip_asc B not available in Net-SSLeay-1.68 and before; requires at least OpenSSL 1.0.2. Checks if the certificate matches the specified IPv4 or IPv6 address. my $rv = Net::SSLeay::X509_check_email($cert, $address, $flags); # $cert - value corresponding to openssl's X509 structure # $address - IP address to check in text representation # $flags (optional, default: 0) - see X509_check_host() # # returns: see X509_check_host() Check openssl doc L. =item * X509_certificate_type B not available in Net-SSLeay-1.45 and before Returns bitmask with type of certificate $x. my $rv = Net::SSLeay::X509_certificate_type($x); # $x - value corresponding to openssl's X509 structure # # returns: (integer) bitmask with certificate type #to decode bitmask returned by this function use these constants: &Net::SSLeay::EVP_PKS_DSA &Net::SSLeay::EVP_PKS_EC &Net::SSLeay::EVP_PKS_RSA &Net::SSLeay::EVP_PKT_ENC &Net::SSLeay::EVP_PKT_EXCH &Net::SSLeay::EVP_PKT_EXP &Net::SSLeay::EVP_PKT_SIGN &Net::SSLeay::EVP_PK_DH &Net::SSLeay::EVP_PK_DSA &Net::SSLeay::EVP_PK_EC &Net::SSLeay::EVP_PK_RSA =item * X509_digest B not available in Net-SSLeay-1.45 and before Computes digest/fingerprint of X509 $data using $type hash function. my $digest_value = Net::SSLeay::X509_digest($data, $type); # $data - value corresponding to openssl's X509 structure # $type - value corresponding to openssl's EVP_MD structure - e.g. got via EVP_get_digestbyname() # # returns: hash value (binary) #to get printable (hex) value of digest use: print unpack('H*', $digest_value); =item * X509_issuer_and_serial_hash B not available in Net-SSLeay-1.45 and before Sort of a checksum of issuer name and serial number of X509 certificate $x. The result is not a full hash (e.g. sha-1), it is kind-of-a-hash truncated to the size of 'unsigned long' (32 bits). The resulting value might differ across different openssl versions for the same X509 certificate. my $rv = Net::SSLeay::X509_issuer_and_serial_hash($x); # $x - value corresponding to openssl's X509 structure # # returns: number representing checksum =item * X509_issuer_name_hash B not available in Net-SSLeay-1.45 and before Sort of a checksum of issuer name of X509 certificate $x. The result is not a full hash (e.g. sha-1), it is kind-of-a-hash truncated to the size of 'unsigned long' (32 bits). The resulting value might differ across different openssl versions for the same X509 certificate. my $rv = Net::SSLeay::X509_issuer_name_hash($x); # $x - value corresponding to openssl's X509 structure # # returns: number representing checksum =item * X509_subject_name_hash B not available in Net-SSLeay-1.45 and before Sort of a checksum of subject name of X509 certificate $x. The result is not a full hash (e.g. sha-1), it is kind-of-a-hash truncated to the size of 'unsigned long' (32 bits). The resulting value might differ across different openssl versions for the same X509 certificate. my $rv = Net::SSLeay::X509_subject_name_hash($x); # $x - value corresponding to openssl's X509 structure # # returns: number representing checksum =item * X509_pubkey_digest B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Computes digest/fingerprint of public key from X509 certificate $data using $type hash function. my $digest_value = Net::SSLeay::X509_pubkey_digest($data, $type); # $data - value corresponding to openssl's X509 structure # $type - value corresponding to openssl's EVP_MD structure - e.g. got via EVP_get_digestbyname() # # returns: hash value (binary) #to get printable (hex) value of digest use: print unpack('H*', $digest_value); =item * X509_set_issuer_name B not available in Net-SSLeay-1.45 and before Sets issuer of X509 certificate $x to $name. my $rv = Net::SSLeay::X509_set_issuer_name($x, $name); # $x - value corresponding to openssl's X509 structure # $name - value corresponding to openssl's X509_NAME structure # # returns: 1 on success, 0 on failure =item * X509_set_pubkey B not available in Net-SSLeay-1.45 and before Sets public key of X509 certificate $x to $pkey. my $rv = Net::SSLeay::X509_set_pubkey($x, $pkey); # $x - value corresponding to openssl's X509 structure # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: 1 on success, 0 on failure =item * X509_set_serialNumber B not available in Net-SSLeay-1.45 and before Sets serial number of X509 certificate $x to $serial. my $rv = Net::SSLeay::X509_set_serialNumber($x, $serial); # $x - value corresponding to openssl's X509 structure # $serial - value corresponding to openssl's ASN1_INTEGER structure # # returns: 1 on success, 0 on failure #to create $serial value use one of these: $serial = Net::SSLeay::P_ASN1_INTEGER_set_hex('45ad6f'); $serial = Net::SSLeay::P_ASN1_INTEGER_set_dec('7896541238529631478'); $serial = Net::SSLeay::ASN1_INTEGER_set(45896); =item * X509_set_subject_name B not available in Net-SSLeay-1.45 and before Sets subject of X509 certificate $x to $name. my $rv = Net::SSLeay::X509_set_subject_name($x, $name); # $x - value corresponding to openssl's X509 structure # $name - value corresponding to openssl's X509_NAME structure # # returns: 1 on success, 0 on failure =item * X509_set_version B not available in Net-SSLeay-1.45 and before Set 'version' value for X509 certificate $ to $version. my $rv = Net::SSLeay::X509_set_version($x, $version); # $x - value corresponding to openssl's X509 structure # $version - (integer) version number # # returns: 1 on success, 0 on failure =item * X509_sign B not available in Net-SSLeay-1.45 and before Sign X509 certificate $x with private key $pkey (using digest algorithm $md). my $rv = Net::SSLeay::X509_sign($x, $pkey, $md); # $x - value corresponding to openssl's X509 structure # $pkey - value corresponding to openssl's EVP_PKEY structure # $md - value corresponding to openssl's EVP_MD structure # # returns: 1 on success, 0 on failure =item * X509_verify B not available in Net-SSLeay-1.45 and before Verifies X509 object $a using public key $r (pubkey of issuing CA). my $rv = Net::SSLeay::X509_verify($x, $r); # $x - value corresponding to openssl's X509 structure # $r - value corresponding to openssl's EVP_PKEY structure # # returns: 0 - verify failure, 1 - verify OK, <0 - error =item * X509_get_ext_count B not available in Net-SSLeay-1.45 and before Returns the total number of extensions in X509 object $x. my $rv = Net::SSLeay::X509_get_ext_count($x); # $x - value corresponding to openssl's X509 structure # # returns: count of extensions =item * X509_get_pubkey B not available in Net-SSLeay-1.45 and before Returns public key corresponding to given X509 object $x. my $rv = Net::SSLeay::X509_get_pubkey($x); # $x - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's EVP_PKEY structure (0 on failure) B This method returns only the public key's key bits, without the algorithm or parameters. Use C to return the full public key (SPKI) instead. =item * X509_get_X509_PUBKEY B not available in Net-SSLeay-1.72 and before Returns the full public key (SPKI) of given X509 certificate $x. Net::SSLeay::X509_get_X509_PUBKEY($x); # $x - value corresponding to openssl's X509 structure # # returns: public key data in DER format (binary) =item * X509_get_serialNumber B not available in Net-SSLeay-1.45 and before Returns serial number of X509 certificate $x. my $rv = Net::SSLeay::X509_get_serialNumber($x); # $x - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's ASN1_INTEGER structure (0 on failure) See L, L or L to decode ASN1_INTEGER object. =item * X509_get0_serialNumber B available in Net-SSLeay-1.86 onwards X509_get0_serialNumber() is the same as X509_get_serialNumber() except it accepts a const parameter and returns a const result. =item * X509_get_version B not available in Net-SSLeay-1.45 and before Returns 'version' value of given X509 certificate $x. my $rv = Net::SSLeay::X509_get_version($x); # $x - value corresponding to openssl's X509 structure # # returns: (integer) version =item * X509_get_ext Returns X509_EXTENSION from $x509 based on given position/index. my $rv = Net::SSLeay::X509_get_ext($x509, $index); # $x509 - value corresponding to openssl's X509 structure # $index - (integer) position/index of extension within $x509 # # returns: value corresponding to openssl's X509_EXTENSION structure (0 on failure) =item * X509_get_ext_by_NID Returns X509_EXTENSION from $x509 based on given NID. my $rv = Net::SSLeay::X509_get_ext_by_NID($x509, $nid, $loc); # $x509 - value corresponding to openssl's X509 structure # $nid - (integer) NID value # $loc - (integer) position to start lookup at # # returns: position/index of extension, negative value on error # call Net::SSLeay::X509_get_ext($x509, $rv) to get the actual extension =item * X509_get_fingerprint Returns fingerprint of certificate $cert. B Does not exactly correspond to any low level API function. The implementation is basen on openssl's C. Net::SSLeay::X509_get_fingerprint($x509, $type); # $x509 - value corresponding to openssl's X509 structure # $type - (string) digest type, currently supported values: # "md5" # "sha1" # "sha256" # "ripemd160" # # returns: certificate digest - hexadecimal string (NOT binary data!) =item * X509_get_issuer_name Return an X509_NAME object representing the issuer of the certificate $cert. my $rv = Net::SSLeay::X509_get_issuer_name($cert); # $cert - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's X509_NAME structure (0 on failure) =item * X509_get_notAfter Return an object giving the time after which the certificate $cert is not valid. my $rv = Net::SSLeay::X509_get_notAfter($cert); # $cert - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's ASN1_TIME structure (0 on failure) To get human readable/printable form the return value you can use: my $time = Net::SSLeay::X509_get_notAfter($cert); print "notAfter=", Net::SSLeay::P_ASN1_TIME_get_isotime($time), "\n"; =item * X509_get_notBefore Return an object giving the time before which the certificate $cert is not valid my $rv = Net::SSLeay::X509_get_notBefore($cert); # $cert - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's ASN1_TIME structure (0 on failure) To get human readable/printable form the return value you can use: my $time = Net::SSLeay::X509_get_notBefore($cert); print "notBefore=", Net::SSLeay::P_ASN1_TIME_get_isotime($time), "\n"; =item * X509_get_subjectAltNames B Does not exactly correspond to any low level API function. Returns the list of alternative subject names from X509 certificate $cert. my @rv = Net::SSLeay::X509_get_subjectAltNames($cert); # $cert - value corresponding to openssl's X509 structure # # returns: list containing pairs - name_type (integer), name_value (string) # where name_type can be: # 0 - GEN_OTHERNAME # 1 - GEN_EMAIL # 2 - GEN_DNS # 3 - GEN_X400 # 4 - GEN_DIRNAME # 5 - GEN_EDIPARTY # 6 - GEN_URI # 7 - GEN_IPADD # 8 - GEN_RID Note: type 7 - GEN_IPADD contains the IP address as a packed binary address. =item * X509_get_subject_name Returns the subject of the certificate $cert. my $rv = Net::SSLeay::X509_get_subject_name($cert); # $cert - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's X509_NAME structure (0 on failure) =item * X509_gmtime_adj Adjust th ASN1_TIME object to the timestamp (in GMT). my $rv = Net::SSLeay::X509_gmtime_adj($s, $adj); # $s - value corresponding to openssl's ASN1_TIME structure # $adj - timestamp (seconds since 1.1.1970) # # returns: value corresponding to openssl's ASN1_TIME structure (0 on failure) B this function may fail for dates after 2038 as it is dependent on time_t size on your system (32bit time_t does not work after 2038). Consider using L instead). =item * X509_load_cert_crl_file Takes PEM file and loads all X509 certificates and X509 CRLs from that file into X509_LOOKUP structure. my $rv = Net::SSLeay::X509_load_cert_crl_file($ctx, $file, $type); # $ctx - value corresponding to openssl's X509_LOOKUP structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # if not FILETYPE_PEM then behaves as Net::SSLeay::X509_load_cert_file() # # returns: 1 on success, 0 on failure =item * X509_load_cert_file Loads/adds X509 certificate from $file to X509_LOOKUP structure my $rv = Net::SSLeay::X509_load_cert_file($ctx, $file, $type); # $ctx - value corresponding to openssl's X509_LOOKUP structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, 0 on failure =item * X509_load_crl_file Loads/adds X509 CRL from $file to X509_LOOKUP structure my $rv = Net::SSLeay::X509_load_crl_file($ctx, $file, $type); # $ctx - value corresponding to openssl's X509_LOOKUP structure # $file - (string) file name # $type - (integer) type - use constants &Net::SSLeay::FILETYPE_PEM or &Net::SSLeay::FILETYPE_ASN1 # # returns: 1 on success, 0 on failure =item * X509_policy_level_get0_node ??? (more info needed) my $rv = Net::SSLeay::X509_policy_level_get0_node($level, $i); # $level - value corresponding to openssl's X509_POLICY_LEVEL structure # $i - (integer) index/position # # returns: value corresponding to openssl's X509_POLICY_NODE structure (0 on failure) =item * X509_policy_level_node_count ??? (more info needed) my $rv = Net::SSLeay::X509_policy_level_node_count($level); # $level - value corresponding to openssl's X509_POLICY_LEVEL structure # # returns: (integer) node count =item * X509_policy_node_get0_parent ??? (more info needed) my $rv = Net::SSLeay::X509_policy_node_get0_parent($node); # $node - value corresponding to openssl's X509_POLICY_NODE structure # # returns: value corresponding to openssl's X509_POLICY_NODE structure (0 on failure) =item * X509_policy_node_get0_policy ??? (more info needed) my $rv = Net::SSLeay::X509_policy_node_get0_policy($node); # $node - value corresponding to openssl's X509_POLICY_NODE structure # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) =item * X509_policy_node_get0_qualifiers ??? (more info needed) my $rv = Net::SSLeay::X509_policy_node_get0_qualifiers($node); # $node - value corresponding to openssl's X509_POLICY_NODE structure # # returns: value corresponding to openssl's STACK_OF(POLICYQUALINFO) structure (0 on failure) =item * X509_policy_tree_free ??? (more info needed) Net::SSLeay::X509_policy_tree_free($tree); # $tree - value corresponding to openssl's X509_POLICY_TREE structure # # returns: no return value =item * X509_policy_tree_get0_level ??? (more info needed) my $rv = Net::SSLeay::X509_policy_tree_get0_level($tree, $i); # $tree - value corresponding to openssl's X509_POLICY_TREE structure # $i - (integer) level index # # returns: value corresponding to openssl's X509_POLICY_LEVEL structure (0 on failure) =item * X509_policy_tree_get0_policies ??? (more info needed) my $rv = Net::SSLeay::X509_policy_tree_get0_policies($tree); # $tree - value corresponding to openssl's X509_POLICY_TREE structure # # returns: value corresponding to openssl's X509_POLICY_NODE structure (0 on failure) =item * X509_policy_tree_get0_user_policies ??? (more info needed) my $rv = Net::SSLeay::X509_policy_tree_get0_user_policies($tree); # $tree - value corresponding to openssl's X509_POLICY_TREE structure # # returns: value corresponding to openssl's X509_POLICY_NODE structure (0 on failure) =item * X509_policy_tree_level_count ??? (more info needed) my $rv = Net::SSLeay::X509_policy_tree_level_count($tree); # $tree - value corresponding to openssl's X509_POLICY_TREE structure # # returns: (integer) count =item * X509_verify_cert_error_string Returns a human readable error string for verification error $n. my $rv = Net::SSLeay::X509_verify_cert_error_string($n); # $n - (long) numeric error code # # returns: error string Check openssl doc L =item * P_X509_add_extensions B not available in Net-SSLeay-1.45 and before Adds one or more X509 extensions to X509 object $x. my $rv = Net::SSLeay::P_X509_add_extensions($x, $ca_cert, $nid, $value); # $x - value corresponding to openssl's X509 structure # $ca_cert - value corresponding to openssl's X509 structure (issuer's cert - necessary for sertting NID_authority_key_identifier) # $nid - NID identifying extension to be set # $value - extension value # # returns: 1 on success, 0 on failure You can set more extensions at once: my $rv = Net::SSLeay::P_X509_add_extensions($x509, $ca_cert, &Net::SSLeay::NID_key_usage => 'digitalSignature,keyEncipherment', &Net::SSLeay::NID_subject_key_identifier => 'hash', &Net::SSLeay::NID_authority_key_identifier => 'keyid', &Net::SSLeay::NID_authority_key_identifier => 'issuer', &Net::SSLeay::NID_basic_constraints => 'CA:FALSE', &Net::SSLeay::NID_ext_key_usage => 'serverAuth,clientAuth', &Net::SSLeay::NID_netscape_cert_type => 'server', &Net::SSLeay::NID_subject_alt_name => 'DNS:s1.dom.com,DNS:s2.dom.com,DNS:s3.dom.com', ); =item * P_X509_copy_extensions B not available in Net-SSLeay-1.45 and before Copies X509 extensions from X509_REQ object to X509 object - handy when you need to turn X509_REQ into X509 certificate. Net::SSLeay::P_X509_copy_extensions($x509_req, $x509, $override); # $x509_req - value corresponding to openssl's X509_REQ structure # $x509 - value corresponding to openssl's X509 structure # $override - (integer) flag indication whether to override already existing items in $x509 (default 1) # # returns: 1 on success, 0 on failure =item * P_X509_get_crl_distribution_points B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Get the list of CRL distribution points from X509 certificate. my @cdp = Net::SSLeay::P_X509_get_crl_distribution_points($x509); # $x509 - value corresponding to openssl's X509 structure # # returns: list of distribution points (usually URLs) =item * P_X509_get_ext_key_usage B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Gets the list of extended key usage of given X509 certificate $cert. my @ext_usage = Net::SSLeay::P_X509_get_ext_key_usage($cert, $format); # $cert - value corresponding to openssl's X509 structure # $format - choose type of return values: 0=OIDs, 1=NIDs, 2=shortnames, 3=longnames # # returns: list of values Examples: my @extkeyusage_oid = Net::SSLeay::P_X509_get_ext_key_usage($x509,0); # returns for example: ("1.3.6.1.5.5.7.3.1", "1.3.6.1.5.5.7.3.2") my @extkeyusage_nid = Net::SSLeay::P_X509_get_ext_key_usage($x509,1); # returns for example: (129, 130) my @extkeyusage_sn = Net::SSLeay::P_X509_get_ext_key_usage($x509,2); # returns for example: ("serverAuth", "clientAuth") my @extkeyusage_ln = Net::SSLeay::P_X509_get_ext_key_usage($x509,3); # returns for example: ("TLS Web Server Authentication", "TLS Web Client Authentication") =item * P_X509_get_key_usage B not available in Net-SSLeay-1.45 and before Gets the list of key usage of given X509 certificate $cert. my @keyusage = Net::SSLeay::P_X509_get_key_usage($cert); # $cert - value corresponding to openssl's X509 structure # # returns: list of key usage values which can be none, one or more from the following list: # "digitalSignature" # "nonRepudiation" # "keyEncipherment" # "dataEncipherment" # "keyAgreement" # "keyCertSign" # "cRLSign" # "encipherOnly" # "decipherOnly" =item * P_X509_get_netscape_cert_type B not available in Net-SSLeay-1.45 and before Gets the list of Netscape cert types of given X509 certificate $cert. Net::SSLeay::P_X509_get_netscape_cert_type($cert); # $cert - value corresponding to openssl's X509 structure # # returns: list of Netscape type values which can be none, one or more from the following list: # "client" # "server" # "email" # "objsign" # "reserved" # "sslCA" # "emailCA" # "objCA" =item * P_X509_get_pubkey_alg B not available in Net-SSLeay-1.45 and before Returns ASN1_OBJECT corresponding to X509 certificate public key algorithm. my $rv = Net::SSLeay::P_X509_get_pubkey_alg($x); # $x - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) To get textual representation use: my $alg = Net::SSLeay::OBJ_obj2txt(Net::SSLeay::P_X509_get_pubkey_alg($x509)); # returns for example: "rsaEncryption" =item * P_X509_get_signature_alg B not available in Net-SSLeay-1.45 and before Returns ASN1_OBJECT corresponding to X509 signarite key algorithm. my $rv = Net::SSLeay::P_X509_get_signature_alg($x); # $x - value corresponding to openssl's X509 structure # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) To get textual representation use: my $alg = Net::SSLeay::OBJ_obj2txt(Net::SSLeay::P_X509_get_signature_alg($x509)) # returns for example: "sha1WithRSAEncryption" =item * sk_X509_new_null Returns a new, empty, STACK_OF(X509) structure. my $rv = Net::SSLeay::sk_X509_new_null(); # # returns: value corresponding to openssl's STACK_OF(X509) structure =item * sk_X509_push Pushes an X509 structure onto a STACK_OF(X509) structure. my $rv = Net::SSLeay::sk_X509_push($sk_x509, $x509); # $sk_x509 - value corresponding to openssl's STACK_OF(X509) structure # $x509 - value corresponding to openssl's X509 structure # # returns: 1 if successful, 0 if unsuccessful =back =head3 Low level API: X509_REQ_* related functions =over =item * X509_REQ_new B not available in Net-SSLeay-1.45 and before Creates a new X509_REQ structure. my $rv = Net::SSLeay::X509_REQ_new(); # # returns: value corresponding to openssl's X509_REQ structure (0 on failure) =item * X509_REQ_free B not available in Net-SSLeay-1.45 and before Free an allocated X509_REQ structure. Net::SSLeay::X509_REQ_free($x); # $x - value corresponding to openssl's X509_REQ structure # # returns: no return value =item * X509_REQ_add1_attr_by_NID B not available in Net-SSLeay-1.45 and before Adds an attribute whose name is defined by a NID $nid. The field value to be added is in $bytes. my $rv = Net::SSLeay::X509_REQ_add1_attr_by_NID($req, $nid, $type, $bytes); # $req - value corresponding to openssl's X509_REQ structure # $nid - (integer) NID value # $type - (integer) type of data in $bytes (see below) # $bytes - data to be set # # returns: 1 on success, 0 on failure # values for $type - use constants: &Net::SSLeay::MBSTRING_UTF8 - $bytes contains utf8 encoded data &Net::SSLeay::MBSTRING_ASC - $bytes contains ASCII data =item * X509_REQ_digest B not available in Net-SSLeay-1.45 and before Computes digest/fingerprint of X509_REQ $data using $type hash function. my $digest_value = Net::SSLeay::X509_REQ_digest($data, $type); # $data - value corresponding to openssl's X509_REQ structure # $type - value corresponding to openssl's EVP_MD structure - e.g. got via EVP_get_digestbyname() # # returns: hash value (binary) #to get printable (hex) value of digest use: print unpack('H*', $digest_value); =item * X509_REQ_get_attr_by_NID B not available in Net-SSLeay-1.45 and before Retrieve the next index matching $nid after $lastpos ($lastpos should initially be set to -1). my $rv = Net::SSLeay::X509_REQ_get_attr_by_NID($req, $nid, $lastpos=-1); # $req - value corresponding to openssl's X509_REQ structure # $nid - (integer) NID value # $lastpos - [optional] (integer) index where to start search (default -1) # # returns: index (-1 if there are no more entries) Note: use L to get the actual attribute value - e.g. my $index = Net::SSLeay::X509_REQ_get_attr_by_NID($req, $nid); my @attr_values = Net::SSLeay::P_X509_REQ_get_attr($req, $index); =item * X509_REQ_get_attr_by_OBJ B not available in Net-SSLeay-1.45 and before Retrieve the next index matching $obj after $lastpos ($lastpos should initially be set to -1). my $rv = Net::SSLeay::X509_REQ_get_attr_by_OBJ($req, $obj, $lastpos=-1); # $req - value corresponding to openssl's X509_REQ structure # $obj - value corresponding to openssl's ASN1_OBJECT structure # $lastpos - [optional] (integer) index where to start search (default -1) # # returns: index (-1 if there are no more entries) Note: use L to get the actual attribute value - e.g. my $index = Net::SSLeay::X509_REQ_get_attr_by_NID($req, $nid); my @attr_values = Net::SSLeay::P_X509_REQ_get_attr($req, $index); =item * X509_REQ_get_attr_count B not available in Net-SSLeay-1.45 and before Returns the total number of attributes in $req. my $rv = Net::SSLeay::X509_REQ_get_attr_count($req); # $req - value corresponding to openssl's X509_REQ structure # # returns: (integer) items count =item * X509_REQ_get_pubkey B not available in Net-SSLeay-1.45 and before Returns public key corresponding to given X509_REQ object $x. my $rv = Net::SSLeay::X509_REQ_get_pubkey($x); # $x - value corresponding to openssl's X509_REQ structure # # returns: value corresponding to openssl's EVP_PKEY structure (0 on failure) =item * X509_REQ_get_subject_name B not available in Net-SSLeay-1.45 and before Returns X509_NAME object corresponding to subject name of given X509_REQ object $x. my $rv = Net::SSLeay::X509_REQ_get_subject_name($x); # $x - value corresponding to openssl's X509_REQ structure # # returns: value corresponding to openssl's X509_NAME structure (0 on failure) =item * X509_REQ_get_version B not available in Net-SSLeay-1.45 and before Returns 'version' value for given X509_REQ object $x. my $rv = Net::SSLeay::X509_REQ_get_version($x); # $x - value corresponding to openssl's X509_REQ structure # # returns: (integer) version e.g. 0 = "version 1" =item * X509_REQ_set_pubkey B not available in Net-SSLeay-1.45 and before Sets public key of given X509_REQ object $x to $pkey. my $rv = Net::SSLeay::X509_REQ_set_pubkey($x, $pkey); # $x - value corresponding to openssl's X509_REQ structure # $pkey - value corresponding to openssl's EVP_PKEY structure # # returns: 1 on success, 0 on failure =item * X509_REQ_set_subject_name B not available in Net-SSLeay-1.45 and before Sets subject name of given X509_REQ object $x to X509_NAME object $name. my $rv = Net::SSLeay::X509_REQ_set_subject_name($x, $name); # $x - value corresponding to openssl's X509_REQ structure # $name - value corresponding to openssl's X509_NAME structure # # returns: 1 on success, 0 on failure =item * X509_REQ_set_version B not available in Net-SSLeay-1.45 and before Sets 'version' of given X509_REQ object $x to $version. my $rv = Net::SSLeay::X509_REQ_set_version($x, $version); # $x - value corresponding to openssl's X509_REQ structure # $version - (integer) e.g. 0 = "version 1" # # returns: 1 on success, 0 on failure =item * X509_REQ_sign B not available in Net-SSLeay-1.45 and before Sign X509_REQ object $x with private key $pk (using digest algorithm $md). my $rv = Net::SSLeay::X509_REQ_sign($x, $pk, $md); # $x - value corresponding to openssl's X509_REQ structure # $pk - value corresponding to openssl's EVP_PKEY structure (requestor's private key) # $md - value corresponding to openssl's EVP_MD structure # # returns: 1 on success, 0 on failure =item * X509_REQ_verify B not available in Net-SSLeay-1.45 and before Verifies X509_REQ object $x using public key $r (pubkey of requesting party). my $rv = Net::SSLeay::X509_REQ_verify($x, $r); # $x - value corresponding to openssl's X509_REQ structure # $r - value corresponding to openssl's EVP_PKEY structure # # returns: 0 - verify failure, 1 - verify OK, <0 - error =item * P_X509_REQ_add_extensions B not available in Net-SSLeay-1.45 and before Adds one or more X509 extensions to X509_REQ object $x. my $rv = Net::SSLeay::P_X509_REQ_add_extensions($x, $nid, $value); # $x - value corresponding to openssl's X509_REQ structure # $nid - NID identifying extension to be set # $value - extension value # # returns: 1 on success, 0 on failure You can set more extensions at once: my $rv = Net::SSLeay::P_X509_REQ_add_extensions($x509_req, &Net::SSLeay::NID_key_usage => 'digitalSignature,keyEncipherment', &Net::SSLeay::NID_basic_constraints => 'CA:FALSE', &Net::SSLeay::NID_ext_key_usage => 'serverAuth,clientAuth', &Net::SSLeay::NID_netscape_cert_type => 'server', &Net::SSLeay::NID_subject_alt_name => 'DNS:s1.com,DNS:s2.com', &Net::SSLeay::NID_crl_distribution_points => 'URI:http://pki.com/crl1,URI:http://pki.com/crl2', ); =item * P_X509_REQ_get_attr B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Returns attribute value for X509_REQ's attribute at index $n. Net::SSLeay::P_X509_REQ_get_attr($req, $n); # $req - value corresponding to openssl's X509_REQ structure # $n - (integer) attribute index # # returns: value corresponding to openssl's ASN1_STRING structure =back =head3 Low level API: X509_CRL_* related functions =over =item * X509_CRL_new B not available in Net-SSLeay-1.45 and before Creates a new X509_CRL structure. my $rv = Net::SSLeay::X509_CRL_new(); # # returns: value corresponding to openssl's X509_CRL structure (0 on failure) =item * X509_CRL_free B not available in Net-SSLeay-1.45 and before Free an allocated X509_CRL structure. Net::SSLeay::X509_CRL_free($x); # $x - value corresponding to openssl's X509_CRL structure # # returns: no return value =item * X509_CRL_digest B not available in Net-SSLeay-1.45 and before Computes digest/fingerprint of X509_CRL $data using $type hash function. my $digest_value = Net::SSLeay::X509_CRL_digest($data, $type); # $data - value corresponding to openssl's X509_CRL structure # $type - value corresponding to openssl's EVP_MD structure - e.g. got via EVP_get_digestbyname() # # returns: hash value (binary) Example: my $x509_crl my $md = Net::SSLeay::EVP_get_digestbyname("sha1"); my $digest_value = Net::SSLeay::X509_CRL_digest($x509_crl, $md); #to get printable (hex) value of digest use: print "digest=", unpack('H*', $digest_value), "\n"; =item * X509_CRL_get_ext B not available in Net-SSLeay-1.54 and before Returns X509_EXTENSION from $x509 based on given position/index. my $rv = Net::SSLeay::X509_CRL_get_ext($x509, $index); # $x509 - value corresponding to openssl's X509_CRL structure # $index - (integer) position/index of extension within $x509 # # returns: value corresponding to openssl's X509_EXTENSION structure (0 on failure) =item * X509_CRL_get_ext_by_NID B not available in Net-SSLeay-1.54 and before Returns X509_EXTENSION from $x509 based on given NID. my $rv = Net::SSLeay::X509_CRL_get_ext_by_NID($x509, $nid, $loc); # $x509 - value corresponding to openssl's X509_CRL structure # $nid - (integer) NID value # $loc - (integer) position to start lookup at # # returns: position/index of extension, negative value on error # call Net::SSLeay::X509_CRL_get_ext($x509, $rv) to get the actual extension =item * X509_CRL_get_ext_count B not available in Net-SSLeay-1.54 and before Returns the total number of extensions in X509_CRL object $x. my $rv = Net::SSLeay::X509_CRL_get_ext_count($x); # $x - value corresponding to openssl's X509_CRL structure # # returns: count of extensions =item * X509_CRL_get_issuer B not available in Net-SSLeay-1.45 and before Returns X509_NAME object corresponding to the issuer of X509_CRL $x. my $rv = Net::SSLeay::X509_CRL_get_issuer($x); # $x - value corresponding to openssl's X509_CRL structure # # returns: value corresponding to openssl's X509_NAME structure (0 on failure) See other C functions to get more info from X509_NAME structure. =item * X509_CRL_get_lastUpdate B not available in Net-SSLeay-1.45 and before Returns 'lastUpdate' date-time value of X509_CRL object $x. my $rv = Net::SSLeay::X509_CRL_get_lastUpdate($x); # $x - value corresponding to openssl's X509_CRL structure # # returns: value corresponding to openssl's ASN1_TIME structure (0 on failure) =item * X509_CRL_get_nextUpdate B not available in Net-SSLeay-1.45 and before Returns 'nextUpdate' date-time value of X509_CRL object $x. my $rv = Net::SSLeay::X509_CRL_get_nextUpdate($x); # $x - value corresponding to openssl's X509_CRL structure # # returns: value corresponding to openssl's ASN1_TIME structure (0 on failure) =item * X509_CRL_get_version B not available in Net-SSLeay-1.45 and before Returns 'version' value of given X509_CRL structure $x. my $rv = Net::SSLeay::X509_CRL_get_version($x); # $x - value corresponding to openssl's X509_CRL structure # # returns: (integer) version =item * X509_CRL_set_issuer_name B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Sets the issuer of X509_CRL object $x to X509_NAME object $name. my $rv = Net::SSLeay::X509_CRL_set_issuer_name($x, $name); # $x - value corresponding to openssl's X509_CRL structure # $name - value corresponding to openssl's X509_NAME structure # # returns: 1 on success, 0 on failure =item * X509_CRL_set_lastUpdate B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Sets 'lastUpdate' value of X509_CRL object $x to $tm. my $rv = Net::SSLeay::X509_CRL_set_lastUpdate($x, $tm); # $x - value corresponding to openssl's X509_CRL structure # $tm - value corresponding to openssl's ASN1_TIME structure # # returns: 1 on success, 0 on failure =item * X509_CRL_set_nextUpdate B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Sets 'nextUpdate' value of X509_CRL object $x to $tm. my $rv = Net::SSLeay::X509_CRL_set_nextUpdate($x, $tm); # $x - value corresponding to openssl's X509_CRL structure # $tm - value corresponding to openssl's ASN1_TIME structure # # returns: 1 on success, 0 on failure =item * X509_CRL_set_version B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Sets 'version' value of given X509_CRL structure $x to $version. my $rv = Net::SSLeay::X509_CRL_set_version($x, $version); # $x - value corresponding to openssl's X509_CRL structure # $version - (integer) version number (1 = version 2 CRL) # # returns: 1 on success, 0 on failure Note that if you want to use any X509_CRL extension you need to set "version 2 CRL" - C. =item * X509_CRL_sign B not available in Net-SSLeay-1.45 and before Sign X509_CRL object $x with private key $pkey (using digest algorithm $md). my $rv = Net::SSLeay::X509_CRL_sign($x, $pkey, $md); # $x - value corresponding to openssl's X509_CRL structure # $pkey - value corresponding to openssl's EVP_PKEY structure # $md - value corresponding to openssl's EVP_MD structure # # returns: 1 on success, 0 on failure =item * X509_CRL_sort B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Sorts the data of X509_CRL object so it will be written in serial number order. my $rv = Net::SSLeay::X509_CRL_sort($x); # $x - value corresponding to openssl's X509_CRL structure # # returns: 1 on success, 0 on failure =item * X509_CRL_verify B not available in Net-SSLeay-1.45 and before Verifies X509_CRL object $a using public key $r (pubkey of issuing CA). my $rv = Net::SSLeay::X509_CRL_verify($a, $r); # $a - value corresponding to openssl's X509_CRL structure # $r - value corresponding to openssl's EVP_PKEY structure # # returns: 0 - verify failure, 1 - verify OK, <0 - error =item * P_X509_CRL_add_revoked_serial_hex B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Adds given serial number $serial_hex to X509_CRL object $crl. Net::SSLeay::P_X509_CRL_add_revoked_serial_hex($crl, $serial_hex, $rev_time, $reason_code, $comp_time); # $crl - value corresponding to openssl's X509_CRL structure # $serial_hex - string (hexadecimal) representation of serial number # $rev_time - (revocation time) value corresponding to openssl's ASN1_TIME structure # $reason_code - [optional] (integer) reason code (see below) - default 0 # $comp_time - [optional] (compromise time) value corresponding to openssl's ASN1_TIME structure # # returns: no return value reason codes: 0 - unspecified 1 - keyCompromise 2 - CACompromise 3 - affiliationChanged 4 - superseded 5 - cessationOfOperation 6 - certificateHold 7 - removeFromCRL =item * P_X509_CRL_get_serial B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Returns serial number of X509_CRL object. my $rv = Net::SSLeay::P_X509_CRL_get_serial($crl); # $crl - value corresponding to openssl's X509_CRL structure # # returns: value corresponding to openssl's ASN1_INTEGER structure (0 on failure) =item * P_X509_CRL_set_serial B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.7 Sets serial number of X509_CRL object to $crl_number. my $rv = Net::SSLeay::P_X509_CRL_set_serial($crl, $crl_number); # $crl - value corresponding to openssl's X509_CRL structure # $crl_number - value corresponding to openssl's ASN1_INTEGER structure # # returns: 1 on success, 0 on failure =back =head3 Low level API: X509_EXTENSION_* related functions =over =item * X509_EXTENSION_get_critical B not available in Net-SSLeay-1.45 and before Returns 'critical' flag of given X509_EXTENSION object $ex. my $rv = Net::SSLeay::X509_EXTENSION_get_critical($ex); # $ex - value corresponding to openssl's X509_EXTENSION structure # # returns: (integer) 1 - critical, 0 - noncritical =item * X509_EXTENSION_get_data B not available in Net-SSLeay-1.45 and before Returns value (raw data) of X509_EXTENSION object $ne. my $rv = Net::SSLeay::X509_EXTENSION_get_data($ne); # $ne - value corresponding to openssl's X509_EXTENSION structure # # returns: value corresponding to openssl's ASN1_OCTET_STRING structure (0 on failure) Note: you can use L to convert ASN1_OCTET_STRING into perl scalar variable. =item * X509_EXTENSION_get_object B not available in Net-SSLeay-1.45 and before Returns OID (ASN1_OBJECT) of X509_EXTENSION object $ne. my $rv = Net::SSLeay::X509_EXTENSION_get_object($ex); # $ex - value corresponding to openssl's X509_EXTENSION structure # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) =item * X509V3_EXT_print B not available in Net-SSLeay-1.45 and before Returns string representation of given X509_EXTENSION object $ext. Net::SSLeay::X509V3_EXT_print($ext, $flags, $utf8_decode); # $ext - value corresponding to openssl's X509_EXTENSION structure # $flags - [optional] (integer) Currently the flag argument is unused and should be set to 0 # $utf8_decode - [optional] 0 or 1 whether the returned value should be utf8 decoded (default=0) # # returns: no return value =item * X509V3_EXT_d2i Parses an extension and returns its internal structure. my $rv = Net::SSLeay::X509V3_EXT_d2i($ext); # $ext - value corresponding to openssl's X509_EXTENSION structure # # returns: pointer ??? =back =head3 Low level API: X509_NAME_* related functions =over =item * X509_NAME_ENTRY_get_data B not available in Net-SSLeay-1.45 and before Retrieves the field value of $ne in and ASN1_STRING structure. my $rv = Net::SSLeay::X509_NAME_ENTRY_get_data($ne); # $ne - value corresponding to openssl's X509_NAME_ENTRY structure # # returns: value corresponding to openssl's ASN1_STRING structure (0 on failure) Check openssl doc L =item * X509_NAME_ENTRY_get_object B not available in Net-SSLeay-1.45 and before Retrieves the field name of $ne in and ASN1_OBJECT structure. my $rv = Net::SSLeay::X509_NAME_ENTRY_get_object($ne); # $ne - value corresponding to openssl's X509_NAME_ENTRY structure # # returns: value corresponding to openssl's ASN1_OBJECT structure (0 on failure) Check openssl doc L =item * X509_NAME_new B not available in Net-SSLeay-1.55 and before; requires at least openssl-0.9.5 Creates a new X509_NAME structure. Adds a field whose name is defined by a string $field. The field value to be added is in $bytes. my $rv = Net::SSLeay::X509_NAME_new(); # # returns: value corresponding to openssl's X509_NAME structure (0 on failure) =item * X509_NAME_hash B not available in Net-SSLeay-1.55 and before; requires at least openssl-0.9.5 Sort of a checksum of issuer name $name. The result is not a full hash (e.g. sha-1), it is kind-of-a-hash truncated to the size of 'unsigned long' (32 bits). The resulting value might differ across different openssl versions for the same X509 certificate. my $rv = Net::SSLeay::X509_NAME_hash($name); # $name - value corresponding to openssl's X509_NAME structure # # returns: number representing checksum =item * X509_NAME_add_entry_by_txt B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.5 Adds a field whose name is defined by a string $field. The field value to be added is in $bytes. my $rv = Net::SSLeay::X509_NAME_add_entry_by_txt($name, $field, $type, $bytes, $len, $loc, $set); # $name - value corresponding to openssl's X509_NAME structure # $field - (string) field definition (name) - e.g. "organizationName" # $type - (integer) type of data in $bytes (see below) # $bytes - data to be set # $loc - [optional] (integer) index where the new entry is inserted: if it is -1 (default) it is appended # $set - [optional] (integer) determines how the new type is added. If it is 0 (default) a new RDN is created # # returns: 1 on success, 0 on failure # values for $type - use constants: &Net::SSLeay::MBSTRING_UTF8 - $bytes contains utf8 encoded data &Net::SSLeay::MBSTRING_ASC - $bytes contains ASCII data Unicode note: when passing non-ascii (unicode) string in $bytes do not forget to set C<$flags = &Net::SSLeay::MBSTRING_UTF8> and encode the perl $string via C<$bytes = encode('utf-8', $string)>. Check openssl doc L =item * X509_NAME_add_entry_by_NID B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.5 Adds a field whose name is defined by a NID $nid. The field value to be added is in $bytes. my $rv = Net::SSLeay::X509_NAME_add_entry_by_NID($name, $nid, $type, $bytes, $len, $loc, $set); # $name - value corresponding to openssl's X509_NAME structure # $nid - (integer) field definition - NID value # $type - (integer) type of data in $bytes (see below) # $bytes - data to be set # $loc - [optional] (integer) index where the new entry is inserted: if it is -1 (default) it is appended # $set - [optional] (integer) determines how the new type is added. If it is 0 (default) a new RDN is created # # returns: 1 on success, 0 on failure Check openssl doc L =item * X509_NAME_add_entry_by_OBJ B not available in Net-SSLeay-1.45 and before; requires at least openssl-0.9.5 Adds a field whose name is defined by a object (OID) $obj . The field value to be added is in $bytes. my $rv = Net::SSLeay::X509_NAME_add_entry_by_OBJ($name, $obj, $type, $bytes, $len, $loc, $set); # $name - value corresponding to openssl's X509_NAME structure # $obj - field definition - value corresponding to openssl's ASN1_OBJECT structure # $type - (integer) type of data in $bytes (see below) # $bytes - data to be set # $loc - [optional] (integer) index where the new entry is inserted: if it is -1 (default) it is appended # $set - [optional] (integer) determines how the new type is added. If it is 0 (default) a new RDN is created # # returns: 1 on success, 0 on failure Check openssl doc L =item * X509_NAME_cmp B not available in Net-SSLeay-1.45 and before Compares two X509_NAME obejcts. my $rv = Net::SSLeay::X509_NAME_cmp($a, $b); # $a - value corresponding to openssl's X509_NAME structure # $b - value corresponding to openssl's X509_NAME structure # # returns: 0 if $a matches $b; non zero otherwise =item * X509_NAME_digest B not available in Net-SSLeay-1.45 and before Computes digest/fingerprint of X509_NAME $data using $type hash function. my $digest_value = Net::SSLeay::X509_NAME_digest($data, $type); # $data - value corresponding to openssl's X509_NAME structure # $type - value corresponding to openssl's EVP_MD structure - e.g. got via EVP_get_digestbyname() # # returns: hash value (binary) #to get printable (hex) value of digest use: print unpack('H*', $digest_value); =item * X509_NAME_entry_count B not available in Net-SSLeay-1.45 and before Returns the total number of entries in $name. my $rv = Net::SSLeay::X509_NAME_entry_count($name); # $name - value corresponding to openssl's X509_NAME structure # # returns: (integer) entries count Check openssl doc L =item * X509_NAME_get_entry B not available in Net-SSLeay-1.45 and before Retrieves the X509_NAME_ENTRY from $name corresponding to index $loc. Acceptable values for $loc run from 0 to C. The value returned is an internal pointer which must not be freed. my $rv = Net::SSLeay::X509_NAME_get_entry($name, $loc); # $name - value corresponding to openssl's X509_NAME structure # $loc - (integer) index of wanted entry # # returns: value corresponding to openssl's X509_NAME_ENTRY structure (0 on failure) Check openssl doc L =item * X509_NAME_print_ex B not available in Net-SSLeay-1.45 and before Returns a string with human readable version of $name. Net::SSLeay::X509_NAME_print_ex($name, $flags, $utf8_decode); # $name - value corresponding to openssl's X509_NAME structure # $flags - [optional] conversion flags (default XN_FLAG_RFC2253) - see below # $utf8_decode - [optional] 0 or 1 whether the returned value should be utf8 decoded (default=0) # # returns: string representation of $name #available conversion flags - use constants: &Net::SSLeay::XN_FLAG_COMPAT &Net::SSLeay::XN_FLAG_DN_REV &Net::SSLeay::XN_FLAG_DUMP_UNKNOWN_FIELDS &Net::SSLeay::XN_FLAG_FN_ALIGN &Net::SSLeay::XN_FLAG_FN_LN &Net::SSLeay::XN_FLAG_FN_MASK &Net::SSLeay::XN_FLAG_FN_NONE &Net::SSLeay::XN_FLAG_FN_OID &Net::SSLeay::XN_FLAG_FN_SN &Net::SSLeay::XN_FLAG_MULTILINE &Net::SSLeay::XN_FLAG_ONELINE &Net::SSLeay::XN_FLAG_RFC2253 &Net::SSLeay::XN_FLAG_SEP_COMMA_PLUS &Net::SSLeay::XN_FLAG_SEP_CPLUS_SPC &Net::SSLeay::XN_FLAG_SEP_MASK &Net::SSLeay::XN_FLAG_SEP_MULTILINE &Net::SSLeay::XN_FLAG_SEP_SPLUS_SPC &Net::SSLeay::XN_FLAG_SPC_EQ Most likely you will be fine with default: Net::SSLeay::X509_NAME_print_ex($name, &Net::SSLeay::XN_FLAG_RFC2253); Or you might want RFC2253-like output without utf8 chars escaping: use Net::SSLeay qw/XN_FLAG_RFC2253 ASN1_STRFLGS_ESC_MSB/; my $flag_rfc22536_utf8 = (XN_FLAG_RFC2253) & (~ ASN1_STRFLGS_ESC_MSB); my $result = Net::SSLeay::X509_NAME_print_ex($name, $flag_rfc22536_utf8, 1); Check openssl doc L =item * X509_NAME_get_text_by_NID Retrieves the text from the first entry in name which matches $nid, if no such entry exists -1 is returned. B this is a legacy function which has various limitations which makes it of minimal use in practice. It can only find the first matching entry and will copy the contents of the field verbatim: this can be highly confusing if the target is a multicharacter string type like a BMPString or a UTF8String. Net::SSLeay::X509_NAME_get_text_by_NID($name, $nid); # $name - value corresponding to openssl's X509_NAME structure # $nid - NID value (integer) # # returns: text value Check openssl doc L =item * X509_NAME_oneline Return an ASCII version of $name. Net::SSLeay::X509_NAME_oneline($name); # $name - value corresponding to openssl's X509_NAME structure # # returns: (string) ASCII version of $name Check openssl doc L =item * sk_X509_NAME_free Free an allocated STACK_OF(X509_NAME) structure. Net::SSLeay::sk_X509_NAME_free($sk); # $sk - value corresponding to openssl's STACK_OF(X509_NAME) structure # # returns: no return value =item * sk_X509_NAME_num Return number of items in STACK_OF(X509_NAME) my $rv = Net::SSLeay::sk_X509_NAME_num($sk); # $sk - value corresponding to openssl's STACK_OF(X509_NAME) structure # # returns: number of items =item * sk_X509_NAME_value Returns X509_NAME from position $index in STACK_OF(X509_NAME) my $rv = Net::SSLeay::sk_X509_NAME_value($sk, $i); # $sk - value corresponding to openssl's STACK_OF(X509_NAME) structure # $i - (integer) index/position # # returns: value corresponding to openssl's X509_NAME structure (0 on failure) =item * add_file_cert_subjects_to_stack Add a file of certs to a stack. All certs in $file that are not already in the $stackCAs will be added. my $rv = Net::SSLeay::add_file_cert_subjects_to_stack($stackCAs, $file); # $stackCAs - value corresponding to openssl's STACK_OF(X509_NAME) structure # $file - (string) filename # # returns: 1 on success, 0 on failure =item * add_dir_cert_subjects_to_stack Add a directory of certs to a stack. All certs in $dir that are not already in the $stackCAs will be added. my $rv = Net::SSLeay::add_dir_cert_subjects_to_stack($stackCAs, $dir); # $stackCAs - value corresponding to openssl's STACK_OF(X509_NAME) structure # $dir - (string) the directory to append from. All files in this directory will be examined as potential certs. Any that are acceptable to SSL_add_dir_cert_subjects_to_stack() that are not already in the stack will be included. # # returns: 1 on success, 0 on failure =back =head3 Low level API: X509_STORE_* related functions =over =item * X509_STORE_CTX_new returns a newly initialised X509_STORE_CTX structure. =item * X509_STORE_CTX_init X509_STORE_CTX_init() sets up an X509_STORE_CTX for a subsequent verification operation. It must be called before each call to X509_verify_cert(). Net::SSLeay::X509_STORE_CTX_init($x509_store_ctx, $x509_store, $x509, $chain); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure (required) # $x509_store - value corresponding to openssl's X509_STORE structure (optional) # $x509 - value corresponding to openssl's X509 structure (optional) # $chain - value corresponding to openssl's STACK_OF(X509) structure (optional) Check openssl doc L =item * X509_STORE_CTX_free Frees an X509_STORE_CTX structure. Net::SSLeay::X509_STORE_CTX_free($x509_store_ctx); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure =item * X509_verify_cert The X509_verify_cert() function attempts to discover and validate a certificate chain based on parameters in ctx. A complete description of the process is contained in the verify(1) manual page. If this function returns 0, use X509_STORE_CTX_get_error to get additional error information. my $rv = Net::SSLeay::X509_verify_cert($x509_store_ctx); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # # returns: 1 if a complete chain can be built and validated, otherwise 0 Check openssl doc L =item * X509_STORE_CTX_get_current_cert Returns the certificate in ctx which caused the error or 0 if no certificate is relevant. my $rv = Net::SSLeay::X509_STORE_CTX_get_current_cert($x509_store_ctx); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # # returns: value corresponding to openssl's X509 structure (0 on failure) Check openssl doc L =item * X509_STORE_CTX_get_error Returns the error code of $ctx. my $rv = Net::SSLeay::X509_STORE_CTX_get_error($x509_store_ctx); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # # returns: (integer) error code For more info about erro code values check function L. Check openssl doc L =item * X509_STORE_CTX_get_error_depth Returns the depth of the error. This is a non-negative integer representing where in the certificate chain the error occurred. If it is zero it occurred in the end entity certificate, one if it is the certificate which signed the end entity certificate and so on. my $rv = Net::SSLeay::X509_STORE_CTX_get_error_depth($x509_store_ctx); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # # returns: (integer) depth Check openssl doc L =item * X509_STORE_CTX_get_ex_data Is used to retrieve the information for $idx from $x509_store_ctx. my $rv = Net::SSLeay::X509_STORE_CTX_get_ex_data($x509_store_ctx, $idx); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # $idx - (integer) index for application specific data # # returns: pointer to ??? =item * X509_STORE_CTX_set_ex_data Is used to store application data at arg for idx into $x509_store_ctx. my $rv = Net::SSLeay::X509_STORE_CTX_set_ex_data($x509_store_ctx, $idx, $data); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # $idx - (integer) ??? # $data - (pointer) ??? # # returns: 1 on success, 0 on failure =item * X509_STORE_CTX_set_cert Sets the certificate to be verified in $x509_store_ctx to $x. Net::SSLeay::X509_STORE_CTX_set_cert($x509_store_ctx, $x); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # $x - value corresponding to openssl's X509 structure # # returns: no return value Check openssl doc L =item * X509_STORE_new Returns a newly initialized X509_STORE structure. my $rv = Net::SSLeay::X509_STORE_new(); # # returns: value corresponding to openssl's X509_STORE structure (0 on failure) =item * X509_STORE_free Frees an X509_STORE structure Net::SSLeay::X509_STORE_free($x509_store); # $x509_store - value corresponding to openssl's X509_STORE structure =item * X509_STORE_add_lookup Adds a lookup to an X509_STORE for a given lookup method. my $method = &Net::SSLeay::X509_LOOKUP_hash_dir; my $rv = Net::SSLeay::X509_STORE_add_lookup($x509_store, $method); # $method - value corresponding to openssl's X509_LOOKUP_METHOD structure # $x509_store - value corresponding to openssl's X509_STORE structure # # returns: value corresponding to openssl's X509_LOOKUP structure Check openssl doc L =item * X509_STORE_CTX_set_error Sets the error code of $ctx to $s. For example it might be used in a verification callback to set an error based on additional checks. Net::SSLeay::X509_STORE_CTX_set_error($x509_store_ctx, $s); # $x509_store_ctx - value corresponding to openssl's X509_STORE_CTX structure # $s - (integer) error id # # returns: no return value Check openssl doc L =item * X509_STORE_add_cert Adds X509 certificate $x into the X509_STORE $store. my $rv = Net::SSLeay::X509_STORE_add_cert($store, $x); # $store - value corresponding to openssl's X509_STORE structure # $x - value corresponding to openssl's X509 structure # # returns: 1 on success, 0 on failure =item * X509_STORE_add_crl Adds X509 CRL $x into the X509_STORE $store. my $rv = Net::SSLeay::X509_STORE_add_crl($store, $x); # $store - value corresponding to openssl's X509_STORE structure # $x - value corresponding to openssl's X509_CRL structure # # returns: 1 on success, 0 on failure =item * X509_STORE_set1_param ??? (more info needed) my $rv = Net::SSLeay::X509_STORE_set1_param($store, $pm); # $store - value corresponding to openssl's X509_STORE structure # $pm - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: 1 on success, 0 on failure =item * X509_LOOKUP_hash_dir Returns an X509_LOOKUP structure that instructs an X509_STORE to load files from a directory containing certificates with filenames in the format I or crls with filenames in the format IBI my $rv = Net::SSLeay::X509_LOOKUP_hash_dir(); # # returns: value corresponding to openssl's X509_LOOKUP_METHOD structure, with the hashed directory method Check openssl doc L =item * X509_LOOKUP_add_dir Add a directory to an X509_LOOKUP structure, usually obtained from X509_STORE_add_lookup. my $method = &Net::SSLeay::X509_LOOKUP_hash_dir; my $lookup = Net::SSLeay::X509_STORE_add_lookup($x509_store, $method); my $type = &Net::SSLeay::X509_FILETYPE_PEM; Net::SSLeay::X509_LOOKUP_add_dir($lookup, $dir, $type); # $lookup - value corresponding to openssl's X509_LOOKUP structure # $dir - string path to a directory s# $type - constant corresponding to the type of file in the directory - can be X509_FILETYPE_PEM, X509_FILETYPE_DEFAULT, or X509_FILETYPE_ASN1 =item * X509_STORE_set_flags Net::SSLeay::X509_STORE_set_flags($ctx, $flags); # $ctx - value corresponding to openssl's X509_STORE structure # $flags - (unsigned long) flags to be set (bitmask) # # returns: no return value #to create $flags value use corresponding constants like $flags = Net::SSLeay::X509_V_FLAG_CRL_CHECK(); For more details about $flags bitmask see L. =item * X509_STORE_set_purpose Net::SSLeay::X509_STORE_set_purpose($ctx, $purpose); # $ctx - value corresponding to openssl's X509_STORE structure # $purpose - (integer) purpose identifier # # returns: no return value For more details about $purpose identifier check L. =item * X509_STORE_set_trust Net::SSLeay::X509_STORE_set_trust($ctx, $trust); # $ctx - value corresponding to openssl's X509_STORE structure # $trust - (integer) trust identifier # # returns: no return value For more details about $trust identifier check L. =back =head3 Low Level API: X509_INFO related functions =over =item * sk_X509_INFO_num Returns the number of values in a STACK_OF(X509_INFO) structure. my $rv = Net::SSLeay::sk_X509_INFO_num($sk_x509_info); # $sk_x509_info - value corresponding to openssl's STACK_OF(X509_INFO) structure # # returns: number of values in $sk_X509_info =item * sk_X509_INFO_value Returns the value of a STACK_OF(X509_INFO) structure at a given index. my $rv = Net::SSLeay::sk_X509_INFO_value($sk_x509_info, $index); # $sk_x509_info - value corresponding to openssl's STACK_OF(X509_INFO) structure # $index - index into the stack # # returns: value corresponding to openssl's X509_INFO structure at the given index =item * P_X509_INFO_get_x509 Returns the X509 structure stored in an X509_INFO structure. my $rv = Net::SSLeay::P_X509_INFO_get_x509($x509_info); # $x509_info - value corresponding to openssl's X509_INFO structure # # returns: value corresponding to openssl's X509 structure =back =head3 Low level API: X509_VERIFY_PARAM_* related functions =over =item * X509_VERIFY_PARAM_add0_policy Enables policy checking (it is disabled by default) and adds $policy to the acceptable policy set. my $rv = Net::SSLeay::X509_VERIFY_PARAM_add0_policy($param, $policy); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $policy - value corresponding to openssl's ASN1_OBJECT structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * X509_VERIFY_PARAM_add0_table ??? (more info needed) my $rv = Net::SSLeay::X509_VERIFY_PARAM_add0_table($param); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: 1 on success, 0 on failure =item * X509_VERIFY_PARAM_add1_host B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Adds an additional reference identifier that can match the peer's certificate. my $rv = Net::SSLeay::X509_VERIFY_PARAM_add1_host($param, $name); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $name - (string) name to be set # # returns: 1 on success, 0 on failure See also OpenSSL docs, L and L for more information, including wildcard matching. Check openssl doc L =item * X509_VERIFY_PARAM_clear_flags Clears the flags $flags in param. my $rv = Net::SSLeay::X509_VERIFY_PARAM_clear_flags($param, $flags); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $flags - (unsigned long) flags to be set (bitmask) # # returns: 1 on success, 0 on failure For more details about $flags bitmask see L. Check openssl doc L =item * X509_VERIFY_PARAM_free Frees up the X509_VERIFY_PARAM structure. Net::SSLeay::X509_VERIFY_PARAM_free($param); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: no return value =item * X509_VERIFY_PARAM_get0_peername B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Returns the DNS hostname or subject CommonName from the peer certificate that matched one of the reference identifiers. my $rv = Net::SSLeay::X509_VERIFY_PARAM_get0_peername($param); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: (string) name e.g. '*.example.com' or undef Check openssl doc L =item * X509_VERIFY_PARAM_get_depth Returns the current verification depth. my $rv = Net::SSLeay::X509_VERIFY_PARAM_get_depth($param); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: (ineger) depth Check openssl doc L =item * X509_VERIFY_PARAM_get_flags Returns the current verification flags. my $rv = Net::SSLeay::X509_VERIFY_PARAM_get_flags($param); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: (unsigned long) flags to be set (bitmask) For more details about returned flags bitmask see L. Check openssl doc L =item * X509_VERIFY_PARAM_set_flags my $rv = Net::SSLeay::X509_VERIFY_PARAM_set_flags($param, $flags); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $flags - (unsigned long) flags to be set (bitmask) # # returns: 1 on success, 0 on failure #to create $flags value use corresponding constants like $flags = Net::SSLeay::X509_V_FLAG_CRL_CHECK(); For more details about $flags bitmask, see the OpenSSL docs below. Check openssl doc L =item * X509_VERIFY_PARAM_inherit ??? (more info needed) my $rv = Net::SSLeay::X509_VERIFY_PARAM_inherit($to, $from); # $to - value corresponding to openssl's X509_VERIFY_PARAM structure # $from - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: 1 on success, 0 on failure =item * X509_VERIFY_PARAM_lookup Finds X509_VERIFY_PARAM by name. my $rv = Net::SSLeay::X509_VERIFY_PARAM_lookup($name); # $name - (string) name we want to find # # returns: value corresponding to openssl's X509_VERIFY_PARAM structure (0 on failure) =item * X509_VERIFY_PARAM_new Creates a new X509_VERIFY_PARAM structure. my $rv = Net::SSLeay::X509_VERIFY_PARAM_new(); # # returns: value corresponding to openssl's X509_VERIFY_PARAM structure (0 on failure) =item * X509_VERIFY_PARAM_set1 Sets the name of X509_VERIFY_PARAM structure $to to the same value as the name of X509_VERIFY_PARAM structure $from. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set1($to, $from); # $to - value corresponding to openssl's X509_VERIFY_PARAM structure # $from - value corresponding to openssl's X509_VERIFY_PARAM structure # # returns: 1 on success, 0 on failure =item * X509_VERIFY_PARAM_set1_email B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Sets the expected RFC822 email address to email. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set1_email($param, $email); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $email - (string) email to be set # # returns: 1 on success, 0 on failure Check openssl doc L =item * X509_VERIFY_PARAM_set1_host B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Sets the expected DNS hostname to name clearing any previously specified host name or names. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set1_host($param, $name); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $name - (string) name to be set # # returns: 1 on success, 0 on failure See also OpenSSL docs, L and L for more information, including wildcard matching. Check openssl doc L =item * X509_VERIFY_PARAM_set1_ip B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Sets the expected IP address to ip. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set1_ip($param, $ip); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $ip - (binary) 4 octet IPv4 or 16 octet IPv6 address # # returns: 1 on success, 0 on failure Check openssl doc L =item * X509_VERIFY_PARAM_set1_ip_asc B not available in Net-SSLeay-1.82 and before; requires at least OpenSSL 1.0.2 Sets the expected IP address to ipasc. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set1_asc($param, $ipasc); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $ip - (string) IPv4 or IPv6 address # # returns: 1 on success, 0 on failure Check openssl doc L =item * X509_VERIFY_PARAM_set1_name Sets the name of X509_VERIFY_PARAM structure $param to $name. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set1_name($param, $name); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $name - (string) name to be set # # returns: 1 on success, 0 on failure =item * X509_VERIFY_PARAM_set1_policies Enables policy checking (it is disabled by default) and sets the acceptable policy set to policies. Any existing policy set is cleared. The policies parameter can be 0 to clear an existing policy set. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set1_policies($param, $policies); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $policies - value corresponding to openssl's STACK_OF(ASN1_OBJECT) structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * X509_VERIFY_PARAM_set_depth Sets the maximum verification depth to depth. That is the maximum number of untrusted CA certificates that can appear in a chain. Net::SSLeay::X509_VERIFY_PARAM_set_depth($param, $depth); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $depth - (integer) depth to be set # # returns: no return value Check openssl doc L =item * X509_VERIFY_PARAM_set_hostflags Net::SSLeay::X509_VERIFY_PARAM_set_hostflags($param, $flags); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $flags - (unsigned int) flags to be set (bitmask) # # returns: no return value See also OpenSSL docs, L and L for more information. The flags for controlling wildcard checks and other features are defined in OpenSSL docs. Check openssl doc L =item * X509_VERIFY_PARAM_set_purpose Sets the verification purpose in $param to $purpose. This determines the acceptable purpose of the certificate chain, for example SSL client or SSL server. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set_purpose($param, $purpose); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $purpose - (integer) purpose identifier # # returns: 1 on success, 0 on failure For more details about $purpose identifier check L. Check openssl doc L =item * X509_VERIFY_PARAM_set_time Sets the verification time in $param to $t. Normally the current time is used. Net::SSLeay::X509_VERIFY_PARAM_set_time($param, $t); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $t - (time_t) time in seconds since 1.1.1970 # # returns: no return value Check openssl doc L =item * X509_VERIFY_PARAM_set_trust Sets the trust setting in $param to $trust. my $rv = Net::SSLeay::X509_VERIFY_PARAM_set_trust($param, $trust); # $param - value corresponding to openssl's X509_VERIFY_PARAM structure # $trust - (integer) trust identifier # # returns: 1 on success, 0 on failure For more details about $trust identifier check L. Check openssl doc L =item * X509_VERIFY_PARAM_table_cleanup ??? (more info needed) Net::SSLeay::X509_VERIFY_PARAM_table_cleanup(); # # returns: no return value =back =head3 Low level API: Cipher (EVP_CIPHER_*) related functions =over =item * EVP_get_cipherbyname B not available in Net-SSLeay-1.45 and before Returns an EVP_CIPHER structure when passed a cipher name. my $rv = Net::SSLeay::EVP_get_cipherbyname($name); # $name - (string) cipher name e.g. 'aes-128-cbc', 'camellia-256-ecb', 'des-ede', ... # # returns: value corresponding to openssl's EVP_CIPHER structure Check openssl doc L =back =head3 Low level API: Digest (EVP_MD_*) related functions =over =item * OpenSSL_add_all_digests B not available in Net-SSLeay-1.42 and before Net::SSLeay::OpenSSL_add_all_digests(); # no args, no return value http://www.openssl.org/docs/crypto/OpenSSL_add_all_algorithms.html =item * P_EVP_MD_list_all B not available in Net-SSLeay-1.42 and before; requires at least openssl-1.0.0 B Does not exactly correspond to any low level API function my $rv = Net::SSLeay::P_EVP_MD_list_all(); # # returns: arrayref - list of available digest names The returned digest names correspond to values expected by L. Note that some of the digests are available by default and some only after calling L. =item * EVP_get_digestbyname B not available in Net-SSLeay-1.42 and before my $rv = Net::SSLeay::EVP_get_digestbyname($name); # $name - string with digest name # # returns: value corresponding to openssl's EVP_MD structure The $name param can be: md2 md4 md5 mdc2 ripemd160 sha sha1 sha224 sha256 sha512 whirlpool Or better check the supported digests by calling L. =item * EVP_MD_type B not available in Net-SSLeay-1.42 and before my $rv = Net::SSLeay::EVP_MD_type($md); # $md - value corresponding to openssl's EVP_MD structure # # returns: the NID (integer) of the OBJECT IDENTIFIER representing the given message digest =item * EVP_MD_size B not available in Net-SSLeay-1.42 and before my $rv = Net::SSLeay::EVP_MD_size($md); # $md - value corresponding to openssl's EVP_MD structure # # returns: the size of the message digest in bytes (e.g. 20 for SHA1) =item * EVP_MD_CTX_md B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Net::SSLeay::EVP_MD_CTX_md($ctx); # $ctx - value corresponding to openssl's EVP_MD_CTX structure # # returns: value corresponding to openssl's EVP_MD structure =item * EVP_MD_CTX_create B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Allocates, initializes and returns a digest context. my $rv = Net::SSLeay::EVP_MD_CTX_create(); # # returns: value corresponding to openssl's EVP_MD_CTX structure The complete idea behind EVP_MD_CTX looks like this example: Net::SSLeay::OpenSSL_add_all_digests(); my $md = Net::SSLeay::EVP_get_digestbyname("sha1"); my $ctx = Net::SSLeay::EVP_MD_CTX_create(); Net::SSLeay::EVP_DigestInit($ctx, $md); while(my $chunk = get_piece_of_data()) { Net::SSLeay::EVP_DigestUpdate($ctx,$chunk); } my $result = Net::SSLeay::EVP_DigestFinal($ctx); Net::SSLeay::EVP_MD_CTX_destroy($ctx); print "digest=", unpack('H*', $result), "\n"; #print hex value =item * EVP_DigestInit_ex B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Sets up digest context $ctx to use a digest $type from ENGINE $impl, $ctx must be initialized before calling this function, type will typically be supplied by a function such as L. If $impl is 0 then the default implementation of digest $type is used. my $rv = Net::SSLeay::EVP_DigestInit_ex($ctx, $type, $impl); # $ctx - value corresponding to openssl's EVP_MD_CTX structure # $type - value corresponding to openssl's EVP_MD structure # $impl - value corresponding to openssl's ENGINE structure # # returns: 1 for success and 0 for failure =item * EVP_DigestInit B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Behaves in the same way as L except the passed context $ctx does not have to be initialized, and it always uses the default digest implementation. my $rv = Net::SSLeay::EVP_DigestInit($ctx, $type); # $ctx - value corresponding to openssl's EVP_MD_CTX structure # $type - value corresponding to openssl's EVP_MD structure # # returns: 1 for success and 0 for failure =item * EVP_MD_CTX_destroy B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Cleans up digest context $ctx and frees up the space allocated to it, it should be called only on a context created using L. Net::SSLeay::EVP_MD_CTX_destroy($ctx); # $ctx - value corresponding to openssl's EVP_MD_CTX structure # # returns: no return value =item * EVP_DigestUpdate B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 my $rv = Net::SSLeay::EVP_DigestUpdate($ctx, $data); # $ctx - value corresponding to openssl's EVP_MD_CTX structure # $data - data to be hashed # # returns: 1 for success and 0 for failure =item * EVP_DigestFinal_ex B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Retrieves the digest value from $ctx. After calling L no additional calls to L can be made, but L can be called to initialize a new digest operation. my $digest_value = Net::SSLeay::EVP_DigestFinal_ex($ctx); # $ctx - value corresponding to openssl's EVP_MD_CTX structure # # returns: hash value (binary) #to get printable (hex) value of digest use: print unpack('H*', $digest_value); =item * EVP_DigestFinal B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Similar to L except the digest context ctx is automatically cleaned up. my $rv = Net::SSLeay::EVP_DigestFinal($ctx); # $ctx - value corresponding to openssl's EVP_MD_CTX structure # # returns: hash value (binary) #to get printable (hex) value of digest use: print unpack('H*', $digest_value); =item * MD2 B no supported by default in openssl-1.0.0 Computes MD2 from given $data (all data needs to be loaded into memory) my $digest = Net::SSLeay::MD2($data); print "digest(hexadecimal)=", unpack('H*', $digest); =item * MD4 Computes MD4 from given $data (all data needs to be loaded into memory) my $digest = Net::SSLeay::MD4($data); print "digest(hexadecimal)=", unpack('H*', $digest); =item * MD5 Computes MD5 from given $data (all data needs to be loaded into memory) my $digest = Net::SSLeay::MD5($data); print "digest(hexadecimal)=", unpack('H*', $digest); =item * RIPEMD160 Computes RIPEMD160 from given $data (all data needs to be loaded into memory) my $digest = Net::SSLeay::RIPEMD160($data); print "digest(hexadecimal)=", unpack('H*', $digest); =item * SHA1 B not available in Net-SSLeay-1.42 and before Computes SHA1 from given $data (all data needs to be loaded into memory) my $digest = Net::SSLeay::SHA1($data); print "digest(hexadecimal)=", unpack('H*', $digest); =item * SHA256 B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.8 Computes SHA256 from given $data (all data needs to be loaded into memory) my $digest = Net::SSLeay::SHA256($data); print "digest(hexadecimal)=", unpack('H*', $digest); =item * SHA512 B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.8 Computes SHA512 from given $data (all data needs to be loaded into memory) my $digest = Net::SSLeay::SHA512($data); print "digest(hexadecimal)=", unpack('H*', $digest); =item * EVP_Digest B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.7 Computes "any" digest from given $data (all data needs to be loaded into memory) my $md = Net::SSLeay::EVP_get_digestbyname("sha1"); #or any other algorithm my $digest = Net::SSLeay::EVP_Digest($data, $md); print "digest(hexadecimal)=", unpack('H*', $digest); =item * EVP_sha1 B not available in Net-SSLeay-1.42 and before my $md = Net::SSLeay::EVP_sha1(); # # returns: value corresponding to openssl's EVP_MD structure =item * EVP_sha256 B requires at least openssl-0.9.8 my $md = Net::SSLeay::EVP_sha256(); # # returns: value corresponding to openssl's EVP_MD structure =item * EVP_sha512 B not available in Net-SSLeay-1.42 and before; requires at least openssl-0.9.8 my $md = Net::SSLeay::EVP_sha512(); # # returns: value corresponding to openssl's EVP_MD structure =item * EVP_add_digest my $rv = Net::SSLeay::EVP_add_digest($digest); # $digest - value corresponding to openssl's EVP_MD structure # # returns: 1 on success, 0 otherwise =back =head3 Low level API: CIPHER_* related functions =over =item * CIPHER_get_name B not available in Net-SSLeay-1.42 and before Returns name of the cipher used. my $rv = Net::SSLeay::CIPHER_description($cipher); # $cipher - value corresponding to openssl's SSL_CIPHER structure # # returns: (string) cipher name e.g. 'DHE-RSA-AES256-SHA' Check openssl doc L Example: my $ssl_cipher = Net::SSLeay::get_current_cipher($ssl); my $cipher_name = Net::SSLeay::CIPHER_get_name($ssl_cipher); =item * CIPHER_description Returns a textual description of the cipher used. ??? (does this function really work?) my $rv = Net::SSLeay::CIPHER_description($cipher, $buf, $size); # $cipher - value corresponding to openssl's SSL_CIPHER structure # $bufer - (string/buffer) ??? # $size - (integer) ??? # # returns: (string) cipher description e.g. 'DHE-RSA-AES256-SHA SSLv3 Kx=DH Au=RSA Enc=AES(256) Mac=SHA1' Check openssl doc L =item * CIPHER_get_bits Returns the number of secret bits used for cipher. my $rv = Net::SSLeay::CIPHER_get_bits($c); # $c - value corresponding to openssl's SSL_CIPHER structure # # returns: (integert) number of secret bits, 0 on error Check openssl doc L =back =head3 Low level API: RSA_* related functions =over =item * RSA_generate_key Generates a key pair and returns it in a newly allocated RSA structure. The pseudo-random number generator must be seeded prior to calling RSA_generate_key. my $rv = Net::SSLeay::RSA_generate_key($bits, $e, $perl_cb, $perl_cb_arg); # $bits - (integer) modulus size in bits e.g. 512, 1024, 2048 # $e - (integer) public exponent, an odd number, typically 3, 17 or 65537 # $perl_cb - [optional] reference to perl callback function # $perl_cb_arg - [optional] data that will be passed to callback function when invoked # # returns: value corresponding to openssl's RSA structure (0 on failure) Check openssl doc L =item * RSA_free Frees the RSA structure and its components. The key is erased before the memory is returned to the system. Net::SSLeay::RSA_free($r); # $r - value corresponding to openssl's RSA structure # # returns: no return value Check openssl doc L =item * RSA_get_key_parameters Returns a list of pointers to BIGNUMs representing the parameters of the key in this order: (n, e, d, p, q, dmp1, dmq1, iqmp) Caution: returned list consists of SV pointers to BIGNUMs, which would need to be blessed as Crypt::OpenSSL::Bignum for further use my (@params) = RSA_get_key_parameters($r); =back =head3 Low level API: BIO_* related functions =over =item * BIO_eof Returns 1 if the BIO has read EOF, the precise meaning of 'EOF' varies according to the BIO type. my $rv = Net::SSLeay::BIO_eof($s); # $s - value corresponding to openssl's BIO structure # # returns: 1 if EOF has been reached 0 otherwise Check openssl doc L =item * BIO_f_ssl Returns the SSL BIO method. This is a filter BIO which is a wrapper round the OpenSSL SSL routines adding a BIO 'flavour' to SSL I/O. my $rv = Net::SSLeay::BIO_f_ssl(); # # returns: value corresponding to openssl's BIO_METHOD structure (0 on failure) Check openssl doc L =item * BIO_free Frees up a single BIO. my $rv = Net::SSLeay::BIO_free($bio;); # $bio; - value corresponding to openssl's BIO structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * BIO_new Returns a new BIO using method $type my $rv = Net::SSLeay::BIO_new($type); # $type - value corresponding to openssl's BIO_METHOD structure # # returns: value corresponding to openssl's BIO structure (0 on failure) Check openssl doc L =item * BIO_new_buffer_ssl_connect Creates a new BIO chain consisting of a buffering BIO, an SSL BIO (using ctx) and a connect BIO. my $rv = Net::SSLeay::BIO_new_buffer_ssl_connect($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: value corresponding to openssl's BIO structure (0 on failure) Check openssl doc L =item * BIO_new_file Creates a new file BIO with mode $mode the meaning of mode is the same as the stdio function fopen(). The BIO_CLOSE flag is set on the returned BIO. my $rv = Net::SSLeay::BIO_new_file($filename, $mode); # $filename - (string) filename # $mode - (string) opening mode (as mode by stdio function fopen) # # returns: value corresponding to openssl's BIO structure (0 on failure) Check openssl doc L =item * BIO_new_ssl Allocates an SSL BIO using SSL_CTX ctx and using client mode if client is non zero. my $rv = Net::SSLeay::BIO_new_ssl($ctx, $client); # $ctx - value corresponding to openssl's SSL_CTX structure # $client - (integer) 0 or 1 - indicates ssl client mode # # returns: value corresponding to openssl's BIO structure (0 on failure) Check openssl doc L =item * BIO_new_ssl_connect Creates a new BIO chain consisting of an SSL BIO (using ctx) followed by a connect BIO. my $rv = Net::SSLeay::BIO_new_ssl_connect($ctx); # $ctx - value corresponding to openssl's SSL_CTX structure # # returns: value corresponding to openssl's BIO structure (0 on failure) Check openssl doc L =item * BIO_pending Return the number of pending characters in the BIOs read buffers. my $rv = Net::SSLeay::BIO_pending($s); # $s - value corresponding to openssl's BIO structure # # returns: the amount of pending data Check openssl doc L =item * BIO_wpending Return the number of pending characters in the BIOs write buffers. my $rv = Net::SSLeay::BIO_wpending($s); # $s - value corresponding to openssl's BIO structure # # returns: the amount of pending data Check openssl doc L =item * BIO_read Read the underlying descriptor. Net::SSLeay::BIO_read($s, $max); # $s - value corresponding to openssl's BIO structure # $max - [optional] max. bytes to read (if not specified, the value 32768 is used) # # returns: data Check openssl doc L =item * BIO_write Attempts to write data from $buffer to BIO $b. my $rv = Net::SSLeay::BIO_write($b, $buffer); # $b - value corresponding to openssl's BIO structure # $buffer - data # # returns: amount of data successfully written # or that no data was successfully read or written if the result is 0 or -1 # or -2 when the operation is not implemented in the specific BIO type Check openssl doc L =item * BIO_s_mem Return the memory BIO method function. my $rv = Net::SSLeay::BIO_s_mem(); # # returns: value corresponding to openssl's BIO_METHOD structure (0 on failure) Check openssl doc L =item * BIO_ssl_copy_session_id Copies an SSL session id between BIO chains from and to. It does this by locating the SSL BIOs in each chain and calling SSL_copy_session_id() on the internal SSL pointer. my $rv = Net::SSLeay::BIO_ssl_copy_session_id($to, $from); # $to - value corresponding to openssl's BIO structure # $from - value corresponding to openssl's BIO structure # # returns: 1 on success, 0 on failure Check openssl doc L =item * BIO_ssl_shutdown Closes down an SSL connection on BIO chain bio. It does this by locating the SSL BIO in the chain and calling SSL_shutdown() on its internal SSL pointer. Net::SSLeay::BIO_ssl_shutdown($ssl_bio); # $ssl_bio - value corresponding to openssl's BIO structure # # returns: no return value Check openssl doc L =back =head3 Low level API: Server side Server Name Indication (SNI) support =over =item * set_tlsext_host_name TBA =item * get_servername TBA =item * get_servername_type TBA =item * CTX_set_tlsext_servername_callback B requires at least OpenSSL 0.9.8f This function is used in a server to support Server side Server Name Indication (SNI). Net::SSLeay::CTX_set_tlsext_servername_callback($ctx, $code) # $ctx - SSL context # $code - reference to a subroutine that will be called when a new connection is being initiated # # returns: no return value On the client side: use set_tlsext_host_name($ssl, $servername) before initiating the SSL connection. On the server side: Set up an additional SSL_CTX() for each different certificate; Add a servername callback to each SSL_CTX() using CTX_set_tlsext_servername_callback(); The callback function is required to retrieve the client-supplied servername with get_servername(ssl). Figure out the right SSL_CTX to go with that host name, then switch the SSL object to that SSL_CTX with set_SSL_CTX(). Example: # set callback Net::SSLeay::CTX_set_tlsext_servername_callback($ctx, sub { my $ssl = shift; my $h = Net::SSLeay::get_servername($ssl); Net::SSLeay::set_SSL_CTX($ssl, $hostnames{$h}->{ctx}) if exists $hostnames{$h}; } ); More complete example: # ... initialize Net::SSLeay my %hostnames = ( 'sni1' => { cert=>'sni1.pem', key=>'sni1.key' }, 'sni2' => { cert=>'sni2.pem', key=>'sni2.key' }, ); # create a new context for each certificate/key pair for my $name (keys %hostnames) { $hostnames{$name}->{ctx} = Net::SSLeay::CTX_new or die; Net::SSLeay::CTX_set_cipher_list($hostnames{$name}->{ctx}, 'ALL'); Net::SSLeay::set_cert_and_key($hostnames{$name}->{ctx}, $hostnames{$name}->{cert}, $hostnames{$name}->{key}) or die; } # create default context my $ctx = Net::SSLeay::CTX_new or die; Net::SSLeay::CTX_set_cipher_list($ctx, 'ALL'); Net::SSLeay::set_cert_and_key($ctx, 'cert.pem','key.pem') or die; # set callback Net::SSLeay::CTX_set_tlsext_servername_callback($ctx, sub { my $ssl = shift; my $h = Net::SSLeay::get_servername($ssl); Net::SSLeay::set_SSL_CTX($ssl, $hostnames{$h}->{ctx}) if exists $hostnames{$h}; } ); # ... later $s = Net::SSLeay::new($ctx); Net::SSLeay::set_fd($s, fileno($accepted_socket)); Net::SSLeay::accept($s); =back =head3 Low level API: NPN (next protocol negotiation) related functions NPN is being replaced with ALPN, a more recent TLS extension for application protocol negotiation that's in process of being adopted by IETF. Please look below for APLN API description. Simple approach for using NPN support looks like this: ### client side use Net::SSLeay; use IO::Socket::INET; Net::SSLeay::initialize(); my $sock = IO::Socket::INET->new(PeerAddr=>'encrypted.google.com:443') or die; my $ctx = Net::SSLeay::CTX_tlsv1_new() or die; Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL); Net::SSLeay::CTX_set_next_proto_select_cb($ctx, ['http1.1','spdy/2']); my $ssl = Net::SSLeay::new($ctx) or die; Net::SSLeay::set_fd($ssl, fileno($sock)) or die; Net::SSLeay::connect($ssl); warn "client:negotiated=",Net::SSLeay::P_next_proto_negotiated($ssl), "\n"; warn "client:last_status=", Net::SSLeay::P_next_proto_last_status($ssl), "\n"; ### server side use Net::SSLeay; use IO::Socket::INET; Net::SSLeay::initialize(); my $ctx = Net::SSLeay::CTX_tlsv1_new() or die; Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL); Net::SSLeay::set_cert_and_key($ctx, "cert.pem", "key.pem"); Net::SSLeay::CTX_set_next_protos_advertised_cb($ctx, ['spdy/2','http1.1']); my $sock = IO::Socket::INET->new(LocalAddr=>'localhost', LocalPort=>5443, Proto=>'tcp', Listen=>20) or die; while (1) { my $ssl = Net::SSLeay::new($ctx); warn("server:waiting for incoming connection...\n"); my $fd = $sock->accept(); Net::SSLeay::set_fd($ssl, $fd->fileno); Net::SSLeay::accept($ssl); warn "server:negotiated=",Net::SSLeay::P_next_proto_negotiated($ssl),"\n"; my $got = Net::SSLeay::read($ssl); Net::SSLeay::ssl_write_all($ssl, "length=".length($got)); Net::SSLeay::free($ssl); $fd->close(); } # check with: openssl s_client -connect localhost:5443 -nextprotoneg http/1.1,spdy/2 Please note that the selection (negotiation) is performed by client side, the server side simply advertise the list of supported protocols. Advanced approach allows you to implement your own negotiation algorithm. #see below documentation for: Net::SSleay::CTX_set_next_proto_select_cb($ctx, $perl_callback_function, $callback_data); Net::SSleay::CTX_set_next_protos_advertised_cb($ctx, $perl_callback_function, $callback_data); Detection of NPN support (works even in older Net::SSLeay versions): use Net::SSLeay; if (exists &Net::SSLeay::P_next_proto_negotiated) { # do NPN stuff } =over =item * CTX_set_next_proto_select_cb B not available in Net-SSLeay-1.45 and before; requires at least openssl-1.0.1 B You need CTX_set_next_proto_select_cb on B of SSL connection. Simple usage - in this case a "common" negotiation algorithm (as implemented by openssl's function SSL_select_next_proto) is used. $rv = Net::SSleay::CTX_set_next_proto_select_cb($ctx, $arrayref); # $ctx - value corresponding to openssl's SSL_CTX structure # $arrayref - list of accepted protocols - e.g. ['http1.0', 'http1.1'] # # returns: 0 on success, 1 on failure Advanced usage (you probably do not need this): $rv = Net::SSleay::CTX_set_next_proto_select_cb($ctx, $perl_callback_function, $callback_data); # $ctx - value corresponding to openssl's SSL_CTX structure # $perl_callback_function - reference to perl function # $callback_data - [optional] data to passed to callback function when invoked # # returns: 0 on success, 1 on failure # where callback function looks like sub npn_advertised_cb_invoke { my ($ssl, $arrayref_proto_list_advertised_by_server, $callback_data) = @_; my $status; # ... $status = 1; #status can be: # 0 - OPENSSL_NPN_UNSUPPORTED # 1 - OPENSSL_NPN_NEGOTIATED # 2 - OPENSSL_NPN_NO_OVERLAP return $status, ['http1.1','spdy/2']; # the callback has to return 2 values } To undefine/clear this callback use: Net::SSleay::CTX_set_next_proto_select_cb($ctx, undef); =item * CTX_set_next_protos_advertised_cb B not available in Net-SSLeay-1.45 and before; requires at least openssl-1.0.1 B You need CTX_set_next_proto_select_cb on B of SSL connection. Simple usage: $rv = Net::SSleay::CTX_set_next_protos_advertised_cb($ctx, $arrayref); # $ctx - value corresponding to openssl's SSL_CTX structure # $arrayref - list of advertised protocols - e.g. ['http1.0', 'http1.1'] # # returns: 0 on success, 1 on failure Advanced usage (you probably do not need this): $rv = Net::SSleay::CTX_set_next_protos_advertised_cb($ctx, $perl_callback_function, $callback_data); # $ctx - value corresponding to openssl's SSL_CTX structure # $perl_callback_function - reference to perl function # $callback_data - [optional] data to passed to callback function when invoked # # returns: 0 on success, 1 on failure # where callback function looks like sub npn_advertised_cb_invoke { my ($ssl, $callback_data) = @_; # ... return ['http1.1','spdy/2']; # the callback has to return arrayref } To undefine/clear this callback use: Net::SSleay::CTX_set_next_protos_advertised_cb($ctx, undef); =item * P_next_proto_negotiated B not available in Net-SSLeay-1.45 and before; requires at least openssl-1.0.1 Returns the name of negotiated protocol for given SSL connection $ssl. $rv = Net::SSLeay::P_next_proto_negotiated($ssl) # $ssl - value corresponding to openssl's SSL structure # # returns: (string) negotiated protocol name (or undef if no negotiation was done or failed with fatal error) =item * P_next_proto_last_status B not available in Net-SSLeay-1.45 and before; requires at least openssl-1.0.1 Returns the result of the last negotiation for given SSL connection $ssl. $rv = Net::SSLeay::P_next_proto_last_status($ssl) # $ssl - value corresponding to openssl's SSL structure # # returns: (integer) negotiation status # 0 - OPENSSL_NPN_UNSUPPORTED # 1 - OPENSSL_NPN_NEGOTIATED # 2 - OPENSSL_NPN_NO_OVERLAP =back =head3 Low level API: ALPN (application layer protocol negotiation) related functions Application protocol can be negotiated via two different mechanisms employing two different TLS extensions: NPN (obsolete) and ALPN (recommended). The API is rather similar, with slight differences reflecting protocol specifics. In particular, with ALPN the protocol negotiation takes place on server, while with NPN the client implements the protocol negotiation logic. With ALPN, the most basic implementation looks like this: ### client side use Net::SSLeay; use IO::Socket::INET; Net::SSLeay::initialize(); my $sock = IO::Socket::INET->new(PeerAddr=>'encrypted.google.com:443') or die; my $ctx = Net::SSLeay::CTX_tlsv1_new() or die; Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL); Net::SSLeay::CTX_set_alpn_protos($ctx, ['http/1.1', 'http/2.0', 'spdy/3]); my $ssl = Net::SSLeay::new($ctx) or die; Net::SSLeay::set_fd($ssl, fileno($sock)) or die; Net::SSLeay::connect($ssl); warn "client:selected=",Net::SSLeay::P_alpn_selected($ssl), "\n"; ### server side use Net::SSLeay; use IO::Socket::INET; Net::SSLeay::initialize(); my $ctx = Net::SSLeay::CTX_tlsv1_new() or die; Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL); Net::SSLeay::set_cert_and_key($ctx, "cert.pem", "key.pem"); Net::SSLeay::CTX_set_alpn_select_cb($ctx, ['http/1.1', 'http/2.0', 'spdy/3]); my $sock = IO::Socket::INET->new(LocalAddr=>'localhost', LocalPort=>5443, Proto=>'tcp', Listen=>20) or die; while (1) { my $ssl = Net::SSLeay::new($ctx); warn("server:waiting for incoming connection...\n"); my $fd = $sock->accept(); Net::SSLeay::set_fd($ssl, $fd->fileno); Net::SSLeay::accept($ssl); warn "server:selected=",Net::SSLeay::P_alpn_selected($ssl),"\n"; my $got = Net::SSLeay::read($ssl); Net::SSLeay::ssl_write_all($ssl, "length=".length($got)); Net::SSLeay::free($ssl); $fd->close(); } # check with: openssl s_client -connect localhost:5443 -alpn spdy/3,http/1.1 Advanced approach allows you to implement your own negotiation algorithm. #see below documentation for: Net::SSleay::CTX_set_alpn_select_cb($ctx, $perl_callback_function, $callback_data); Detection of ALPN support (works even in older Net::SSLeay versions): use Net::SSLeay; if (exists &Net::SSLeay::P_alpn_selected) { # do ALPN stuff } =over =item * CTX_set_alpn_select_cb B not available in Net-SSLeay-1.55 and before; requires at least openssl-1.0.2 B You need CTX_set_alpn_select_cb on B of TLS connection. Simple usage - in this case a "common" negotiation algorithm (as implemented by openssl's function SSL_select_next_proto) is used. $rv = Net::SSleay::CTX_set_alpn_select_cb($ctx, $arrayref); # $ctx - value corresponding to openssl's SSL_CTX structure # $arrayref - list of accepted protocols - e.g. ['http/2.0', 'http/1.1', 'spdy/3'] # # returns: 0 on success, 1 on failure Advanced usage (you probably do not need this): $rv = Net::SSleay::CTX_set_alpn_select_cb($ctx, $perl_callback_function, $callback_data); # $ctx - value corresponding to openssl's SSL_CTX structure # $perl_callback_function - reference to perl function # $callback_data - [optional] data to passed to callback function when invoked # # returns: 0 on success, 1 on failure # where callback function looks like sub alpn_select_cb_invoke { my ($ssl, $arrayref_proto_list_advertised_by_client, $callback_data) = @_; # ... if ($negotiated) { return 'http/2.0'; } else { return undef; } } To undefine/clear this callback use: Net::SSleay::CTX_set_alpn_select_cb($ctx, undef); =item * set_alpn_protos B not available in Net-SSLeay-1.55 and before; requires at least openssl-1.0.2 B You need set_alpn_protos on B of TLS connection. This adds list of supported application layer protocols to ClientHello message sent by a client. It advertises the enumeration of supported protocols: Net::SSLeay::set_alpn_protos($ssl, ['http/1.1', 'http/2.0', 'spdy/3]); # returns 0 on success =item * CTX_set_alpn_protos B not available in Net-SSLeay-1.55 and before; requires at least openssl-1.0.2 B You need CTX_set_alpn_protos on B of TLS connection. This adds list of supported application layer protocols to ClientHello message sent by a client. It advertises the enumeration of supported protocols: Net::SSLeay::CTX_set_alpn_protos($ctx, ['http/1.1', 'http/2.0', 'spdy/3]); # returns 0 on success =item * P_alpn_selected B not available in Net-SSLeay-1.55 and before; requires at least openssl-1.0.2 Returns the name of negotiated protocol for given TLS connection $ssl. $rv = Net::SSLeay::P_alpn_selected($ssl) # $ssl - value corresponding to openssl's SSL structure # # returns: (string) negotiated protocol name (or undef if no negotiation was done or failed with fatal error) =back =head3 Low level API: DANE Support OpenSSL version 1.0.2 adds preliminary support RFC6698 Domain Authentication of Named Entities (DANE) Transport Layer Association within OpenSSL =over =item * SSL_get_tlsa_record_byname B DELETED from net-ssleay, since it is not supported by OpenSSL In order to facilitate DANE there is additional interface, SSL_get_tlsa_record_byname, accepting hostname, port and socket type that returns packed TLSA record. In order to make it even easier there is additional SSL_ctrl function that calls SSL_get_tlsa_record_byname for you. Latter is recommended for programmers that wish to maintain broader binary compatibility, e.g. make application work with both 1.0.2 and prior version (in which case call to SSL_ctrl with new code returning error would have to be ignored when running with prior version). Net::SSLeay::get_tlsa_record_byname($name, $port, $type); =back =head3 Low level API: Other functions =over =item * COMP_add_compression_method Adds the compression method cm with the identifier id to the list of available compression methods. This list is globally maintained for all SSL operations within this application. It cannot be set for specific SSL_CTX or SSL objects. my $rv = Net::SSLeay::COMP_add_compression_method($id, $cm); # $id - (integer) compression method id # 0 to 63: methods defined by the IETF # 64 to 192: external party methods assigned by IANA # 193 to 255: reserved for private use # # $cm - value corresponding to openssl's COMP_METHOD structure # # returns: 0 on success, 1 on failure (check the error queue to find out the reason) Check openssl doc L =item * DH_free Frees the DH structure and its components. The values are erased before the memory is returned to the system. Net::SSLeay::DH_free($dh); # $dh - value corresponding to openssl's DH structure # # returns: no return value Check openssl doc L =item * FIPS_mode_set Enable or disable FIPS mode in a FIPS capable OpenSSL. Net::SSLeay:: FIPS_mode_set($enable); # $enable - (integer) 1 to enable, 0 to disable =back =head3 Low level API: EC related functions =over =item * CTX_set_tmp_ecdh TBA =item * EC_KEY_free TBA =item * EC_KEY_new_by_curve_name TBA =item * EC_KEY_generate_key Generates a EC key and returns it in a newly allocated EC_KEY structure. The EC key then can be used to create a PKEY which can be used in calls like X509_set_pubkey. my $key = Net::SSLeay::EVP_PKEY_new(); my $ec = Net::SSLeay::EC_KEY_generate_key($curve); Net::SSLeay::EVP_PKEY_assign_EC_KEY($key,$ec); # $curve - curve name like 'secp521r1' or the matching Id (integer) of the curve # # returns: value corresponding to openssl's EC_KEY structure (0 on failure) This function has no equivalent in OpenSSL but combines multiple OpenSSL functions for an easier interface. =item * CTX_set_ecdh_auto, set_ecdh_auto These functions enable or disable the automatic curve selection on the server side by calling SSL_CTX_set_ecdh_auto or SSL_set_ecdh_auto respectively. If enabled the highest preference curve is automatically used for ECDH temporary keys used during key exchange. This function is no longer available for OpenSSL 1.1.0 or higher. Net::SSLeay::CTX_set_ecdh_auto($ctx,1); Net::SSLeay::set_ecdh_auto($ssl,1); =item * CTX_set1_curves_list, set1_curves_list These functions set the supported curves (in order of preference) by calling SSL_CTX_set1_curves_list or SSL_set1_curves_list respectively. For a TLS client these curves are offered to the server in the supported curves extension while on the server side these are used to determine the shared curve. These functions are only available since OpenSSL 1.1.0. Net::SSLeay::CTX_set1_curves_list($ctx,"P-521:P-384:P-256"); Net::SSLeay::set1_curves_list($ssl,"P-521:P-384:P-256"); =item * CTX_set1_groups_list, set1_groups_list These functions set the supported groups (in order of preference) by calling SSL_CTX_set1_groups_list or SSL_set1_groups_list respectively. This is practically the same as CTX_set1_curves_list and set1_curves_list except that all DH groups can be given as supported by TLS 1.3. These functions are only available since OpenSSL 1.1.1. Net::SSLeay::CTX_set1_groups_list($ctx,"P-521:P-384:P-256"); Net::SSLeay::set1_groups_list($ssl,"P-521:P-384:P-256"); =back =head2 Constants There are many openssl constants available in L. You can use them like this: use Net::SSLeay; print &Net::SSLeay::NID_commonName; #or print Net::SSLeay::NID_commonName(); Or you can import them and use: use Net::SSLeay qw/NID_commonName/; print &NID_commonName; #or print NID_commonName(); #or print NID_commonName; The constants names are derived from openssl constants, however constants starting with C prefix have name with C part stripped - e.g. openssl's constant C is available as C The list of all available constant names: =for comment the next part is the output of: perl helper_script/regen_openssl_constants.pl -gen-pod ASN1_STRFLGS_ESC_CTRL NID_netscape R_UNKNOWN_REMOTE_ERROR_TYPE ASN1_STRFLGS_ESC_MSB NID_netscape_base_url R_UNKNOWN_STATE ASN1_STRFLGS_ESC_QUOTE NID_netscape_ca_policy_url R_X509_LIB ASN1_STRFLGS_RFC2253 NID_netscape_ca_revocation_url SENT_SHUTDOWN CB_ACCEPT_EXIT NID_netscape_cert_extension SESSION_ASN1_VERSION CB_ACCEPT_LOOP NID_netscape_cert_sequence SESS_CACHE_BOTH CB_ALERT NID_netscape_cert_type SESS_CACHE_CLIENT CB_CONNECT_EXIT NID_netscape_comment SESS_CACHE_NO_AUTO_CLEAR CB_CONNECT_LOOP NID_netscape_data_type SESS_CACHE_NO_INTERNAL CB_EXIT NID_netscape_renewal_url SESS_CACHE_NO_INTERNAL_LOOKUP CB_HANDSHAKE_DONE NID_netscape_revocation_url SESS_CACHE_NO_INTERNAL_STORE CB_HANDSHAKE_START NID_netscape_ssl_server_name SESS_CACHE_OFF CB_LOOP NID_ns_sgc SESS_CACHE_SERVER CB_READ NID_organizationName SSL3_VERSION CB_READ_ALERT NID_organizationalUnitName SSLEAY_BUILT_ON CB_WRITE NID_pbeWithMD2AndDES_CBC SSLEAY_CFLAGS CB_WRITE_ALERT NID_pbeWithMD2AndRC2_CBC SSLEAY_DIR ERROR_NONE NID_pbeWithMD5AndCast5_CBC SSLEAY_PLATFORM ERROR_SSL NID_pbeWithMD5AndDES_CBC SSLEAY_VERSION ERROR_SYSCALL NID_pbeWithMD5AndRC2_CBC ST_ACCEPT ERROR_WANT_ACCEPT NID_pbeWithSHA1AndDES_CBC ST_BEFORE ERROR_WANT_CONNECT NID_pbeWithSHA1AndRC2_CBC ST_CONNECT ERROR_WANT_READ NID_pbe_WithSHA1And128BitRC2_CBC ST_INIT ERROR_WANT_WRITE NID_pbe_WithSHA1And128BitRC4 ST_OK ERROR_WANT_X509_LOOKUP NID_pbe_WithSHA1And2_Key_TripleDES_CBC ST_READ_BODY ERROR_ZERO_RETURN NID_pbe_WithSHA1And3_Key_TripleDES_CBC ST_READ_HEADER EVP_PKS_DSA NID_pbe_WithSHA1And40BitRC2_CBC TLS1_1_VERSION EVP_PKS_EC NID_pbe_WithSHA1And40BitRC4 TLS1_2_VERSION EVP_PKS_RSA NID_pbes2 TLS1_3_VERSION EVP_PKT_ENC NID_pbmac1 TLS1_VERSION EVP_PKT_EXCH NID_pkcs TLSEXT_STATUSTYPE_ocsp EVP_PKT_EXP NID_pkcs3 VERIFY_CLIENT_ONCE EVP_PKT_SIGN NID_pkcs7 VERIFY_FAIL_IF_NO_PEER_CERT EVP_PK_DH NID_pkcs7_data VERIFY_NONE EVP_PK_DSA NID_pkcs7_digest VERIFY_PEER EVP_PK_EC NID_pkcs7_encrypted VERIFY_POST_HANDSHAKE EVP_PK_RSA NID_pkcs7_enveloped V_OCSP_CERTSTATUS_GOOD FILETYPE_ASN1 NID_pkcs7_signed V_OCSP_CERTSTATUS_REVOKED FILETYPE_PEM NID_pkcs7_signedAndEnveloped V_OCSP_CERTSTATUS_UNKNOWN F_CLIENT_CERTIFICATE NID_pkcs8ShroudedKeyBag WRITING F_CLIENT_HELLO NID_pkcs9 X509_CHECK_FLAG_ALWAYS_CHECK_SUBJECT F_CLIENT_MASTER_KEY NID_pkcs9_challengePassword X509_CHECK_FLAG_MULTI_LABEL_WILDCARDS F_D2I_SSL_SESSION NID_pkcs9_contentType X509_CHECK_FLAG_NEVER_CHECK_SUBJECT F_GET_CLIENT_FINISHED NID_pkcs9_countersignature X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS F_GET_CLIENT_HELLO NID_pkcs9_emailAddress X509_CHECK_FLAG_NO_WILDCARDS F_GET_CLIENT_MASTER_KEY NID_pkcs9_extCertAttributes X509_CHECK_FLAG_SINGLE_LABEL_SUBDOMAINS F_GET_SERVER_FINISHED NID_pkcs9_messageDigest X509_FILETYPE_ASN1 F_GET_SERVER_HELLO NID_pkcs9_signingTime X509_FILETYPE_DEFAULT F_GET_SERVER_VERIFY NID_pkcs9_unstructuredAddress X509_FILETYPE_PEM F_I2D_SSL_SESSION NID_pkcs9_unstructuredName X509_LOOKUP F_READ_N NID_private_key_usage_period X509_PURPOSE_ANY F_REQUEST_CERTIFICATE NID_rc2_40_cbc X509_PURPOSE_CRL_SIGN F_SERVER_HELLO NID_rc2_64_cbc X509_PURPOSE_NS_SSL_SERVER F_SSL_CERT_NEW NID_rc2_cbc X509_PURPOSE_OCSP_HELPER F_SSL_GET_NEW_SESSION NID_rc2_cfb64 X509_PURPOSE_SMIME_ENCRYPT F_SSL_NEW NID_rc2_ecb X509_PURPOSE_SMIME_SIGN F_SSL_READ NID_rc2_ofb64 X509_PURPOSE_SSL_CLIENT F_SSL_RSA_PRIVATE_DECRYPT NID_rc4 X509_PURPOSE_SSL_SERVER F_SSL_RSA_PUBLIC_ENCRYPT NID_rc4_40 X509_PURPOSE_TIMESTAMP_SIGN F_SSL_SESSION_NEW NID_rc5_cbc X509_TRUST_COMPAT F_SSL_SESSION_PRINT_FP NID_rc5_cfb64 X509_TRUST_EMAIL F_SSL_SET_FD NID_rc5_ecb X509_TRUST_OBJECT_SIGN F_SSL_SET_RFD NID_rc5_ofb64 X509_TRUST_OCSP_REQUEST F_SSL_SET_WFD NID_ripemd160 X509_TRUST_OCSP_SIGN F_SSL_USE_CERTIFICATE NID_ripemd160WithRSA X509_TRUST_SSL_CLIENT F_SSL_USE_CERTIFICATE_ASN1 NID_rle_compression X509_TRUST_SSL_SERVER F_SSL_USE_CERTIFICATE_FILE NID_rsa X509_TRUST_TSA F_SSL_USE_PRIVATEKEY NID_rsaEncryption X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH F_SSL_USE_PRIVATEKEY_ASN1 NID_rsadsi X509_V_ERR_AKID_SKID_MISMATCH F_SSL_USE_PRIVATEKEY_FILE NID_safeContentsBag X509_V_ERR_APPLICATION_VERIFICATION F_SSL_USE_RSAPRIVATEKEY NID_sdsiCertificate X509_V_ERR_CA_KEY_TOO_SMALL F_SSL_USE_RSAPRIVATEKEY_ASN1 NID_secretBag X509_V_ERR_CA_MD_TOO_WEAK F_SSL_USE_RSAPRIVATEKEY_FILE NID_serialNumber X509_V_ERR_CERT_CHAIN_TOO_LONG F_WRITE_PENDING NID_server_auth X509_V_ERR_CERT_HAS_EXPIRED GEN_DIRNAME NID_sha X509_V_ERR_CERT_NOT_YET_VALID GEN_DNS NID_sha1 X509_V_ERR_CERT_REJECTED GEN_EDIPARTY NID_sha1WithRSA X509_V_ERR_CERT_REVOKED GEN_EMAIL NID_sha1WithRSAEncryption X509_V_ERR_CERT_SIGNATURE_FAILURE GEN_IPADD NID_shaWithRSAEncryption X509_V_ERR_CERT_UNTRUSTED GEN_OTHERNAME NID_stateOrProvinceName X509_V_ERR_CRL_HAS_EXPIRED GEN_RID NID_subject_alt_name X509_V_ERR_CRL_NOT_YET_VALID GEN_URI NID_subject_key_identifier X509_V_ERR_CRL_PATH_VALIDATION_ERROR GEN_X400 NID_surname X509_V_ERR_CRL_SIGNATURE_FAILURE LIBRESSL_VERSION_NUMBER NID_sxnet X509_V_ERR_DANE_NO_MATCH MBSTRING_ASC NID_time_stamp X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT MBSTRING_BMP NID_title X509_V_ERR_DIFFERENT_CRL_SCOPE MBSTRING_FLAG NID_undef X509_V_ERR_EE_KEY_TOO_SMALL MBSTRING_UNIV NID_uniqueIdentifier X509_V_ERR_EMAIL_MISMATCH MBSTRING_UTF8 NID_x509Certificate X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD MIN_RSA_MODULUS_LENGTH_IN_BYTES NID_x509Crl X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD MODE_ACCEPT_MOVING_WRITE_BUFFER NID_zlib_compression X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD MODE_AUTO_RETRY NOTHING X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD MODE_ENABLE_PARTIAL_WRITE OCSP_RESPONSE_STATUS_INTERNALERROR X509_V_ERR_EXCLUDED_VIOLATION MODE_RELEASE_BUFFERS OCSP_RESPONSE_STATUS_MALFORMEDREQUEST X509_V_ERR_HOSTNAME_MISMATCH NID_OCSP_sign OCSP_RESPONSE_STATUS_SIGREQUIRED X509_V_ERR_INVALID_CA NID_SMIMECapabilities OCSP_RESPONSE_STATUS_SUCCESSFUL X509_V_ERR_INVALID_CALL NID_X500 OCSP_RESPONSE_STATUS_TRYLATER X509_V_ERR_INVALID_EXTENSION NID_X509 OCSP_RESPONSE_STATUS_UNAUTHORIZED X509_V_ERR_INVALID_NON_CA NID_ad_OCSP OPENSSL_BUILT_ON X509_V_ERR_INVALID_POLICY_EXTENSION NID_ad_ca_issuers OPENSSL_CFLAGS X509_V_ERR_INVALID_PURPOSE NID_algorithm OPENSSL_DIR X509_V_ERR_IP_ADDRESS_MISMATCH NID_authority_key_identifier OPENSSL_ENGINES_DIR X509_V_ERR_KEYUSAGE_NO_CERTSIGN NID_basic_constraints OPENSSL_PLATFORM X509_V_ERR_KEYUSAGE_NO_CRL_SIGN NID_bf_cbc OPENSSL_VERSION X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE NID_bf_cfb64 OPENSSL_VERSION_NUMBER X509_V_ERR_NO_EXPLICIT_POLICY NID_bf_ecb OP_ALL X509_V_ERR_NO_VALID_SCTS NID_bf_ofb64 OP_ALLOW_NO_DHE_KEX X509_V_ERR_OCSP_CERT_UNKNOWN NID_cast5_cbc OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION X509_V_ERR_OCSP_VERIFY_FAILED NID_cast5_cfb64 OP_CIPHER_SERVER_PREFERENCE X509_V_ERR_OCSP_VERIFY_NEEDED NID_cast5_ecb OP_CISCO_ANYCONNECT X509_V_ERR_OUT_OF_MEM NID_cast5_ofb64 OP_COOKIE_EXCHANGE X509_V_ERR_PATH_LENGTH_EXCEEDED NID_certBag OP_CRYPTOPRO_TLSEXT_BUG X509_V_ERR_PATH_LOOP NID_certificate_policies OP_DONT_INSERT_EMPTY_FRAGMENTS X509_V_ERR_PERMITTED_VIOLATION NID_client_auth OP_ENABLE_MIDDLEBOX_COMPAT X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED NID_code_sign OP_EPHEMERAL_RSA X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED NID_commonName OP_LEGACY_SERVER_CONNECT X509_V_ERR_PROXY_SUBJECT_NAME_VIOLATION NID_countryName OP_MICROSOFT_BIG_SSLV3_BUFFER X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN NID_crlBag OP_MICROSOFT_SESS_ID_BUG X509_V_ERR_STORE_LOOKUP NID_crl_distribution_points OP_MSIE_SSLV2_RSA_PADDING X509_V_ERR_SUBJECT_ISSUER_MISMATCH NID_crl_number OP_NETSCAPE_CA_DN_BUG X509_V_ERR_SUBTREE_MINMAX NID_crl_reason OP_NETSCAPE_CHALLENGE_BUG X509_V_ERR_SUITE_B_CANNOT_SIGN_P_384_WITH_P_256 NID_delta_crl OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG X509_V_ERR_SUITE_B_INVALID_ALGORITHM NID_des_cbc OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG X509_V_ERR_SUITE_B_INVALID_CURVE NID_des_cfb64 OP_NON_EXPORT_FIRST X509_V_ERR_SUITE_B_INVALID_SIGNATURE_ALGORITHM NID_des_ecb OP_NO_ANTI_REPLAY X509_V_ERR_SUITE_B_INVALID_VERSION NID_des_ede OP_NO_CLIENT_RENEGOTIATION X509_V_ERR_SUITE_B_LOS_NOT_ALLOWED NID_des_ede3 OP_NO_COMPRESSION X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY NID_des_ede3_cbc OP_NO_ENCRYPT_THEN_MAC X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE NID_des_ede3_cfb64 OP_NO_QUERY_MTU X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE NID_des_ede3_ofb64 OP_NO_RENEGOTIATION X509_V_ERR_UNABLE_TO_GET_CRL NID_des_ede_cbc OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER NID_des_ede_cfb64 OP_NO_SSL_MASK X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT NID_des_ede_ofb64 OP_NO_SSLv2 X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY NID_des_ofb64 OP_NO_SSLv3 X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE NID_description OP_NO_TICKET X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION NID_desx_cbc OP_NO_TLSv1 X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION NID_dhKeyAgreement OP_NO_TLSv1_1 X509_V_ERR_UNNESTED_RESOURCE NID_dnQualifier OP_NO_TLSv1_2 X509_V_ERR_UNSPECIFIED NID_dsa OP_NO_TLSv1_3 X509_V_ERR_UNSUPPORTED_CONSTRAINT_SYNTAX NID_dsaWithSHA OP_PKCS1_CHECK_1 X509_V_ERR_UNSUPPORTED_CONSTRAINT_TYPE NID_dsaWithSHA1 OP_PKCS1_CHECK_2 X509_V_ERR_UNSUPPORTED_EXTENSION_FEATURE NID_dsaWithSHA1_2 OP_PRIORITIZE_CHACHA X509_V_ERR_UNSUPPORTED_NAME_SYNTAX NID_dsa_2 OP_SAFARI_ECDHE_ECDSA_BUG X509_V_FLAG_ALLOW_PROXY_CERTS NID_email_protect OP_SINGLE_DH_USE X509_V_FLAG_CB_ISSUER_CHECK NID_ext_key_usage OP_SINGLE_ECDH_USE X509_V_FLAG_CHECK_SS_SIGNATURE NID_ext_req OP_SSLEAY_080_CLIENT_DH_BUG X509_V_FLAG_CRL_CHECK NID_friendlyName OP_SSLREF2_REUSE_CERT_TYPE_BUG X509_V_FLAG_CRL_CHECK_ALL NID_givenName OP_TLSEXT_PADDING X509_V_FLAG_EXPLICIT_POLICY NID_hmacWithSHA1 OP_TLS_BLOCK_PADDING_BUG X509_V_FLAG_EXTENDED_CRL_SUPPORT NID_id_ad OP_TLS_D5_BUG X509_V_FLAG_IGNORE_CRITICAL NID_id_ce OP_TLS_ROLLBACK_BUG X509_V_FLAG_INHIBIT_ANY NID_id_kp READING X509_V_FLAG_INHIBIT_MAP NID_id_pbkdf2 RECEIVED_SHUTDOWN X509_V_FLAG_NOTIFY_POLICY NID_id_pe RSA_3 X509_V_FLAG_NO_ALT_CHAINS NID_id_pkix RSA_F4 X509_V_FLAG_NO_CHECK_TIME NID_id_qt_cps R_BAD_AUTHENTICATION_TYPE X509_V_FLAG_PARTIAL_CHAIN NID_id_qt_unotice R_BAD_CHECKSUM X509_V_FLAG_POLICY_CHECK NID_idea_cbc R_BAD_MAC_DECODE X509_V_FLAG_POLICY_MASK NID_idea_cfb64 R_BAD_RESPONSE_ARGUMENT X509_V_FLAG_SUITEB_128_LOS NID_idea_ecb R_BAD_SSL_FILETYPE X509_V_FLAG_SUITEB_128_LOS_ONLY NID_idea_ofb64 R_BAD_SSL_SESSION_ID_LENGTH X509_V_FLAG_SUITEB_192_LOS NID_info_access R_BAD_STATE X509_V_FLAG_TRUSTED_FIRST NID_initials R_BAD_WRITE_RETRY X509_V_FLAG_USE_CHECK_TIME NID_invalidity_date R_CHALLENGE_IS_DIFFERENT X509_V_FLAG_USE_DELTAS NID_issuer_alt_name R_CIPHER_TABLE_SRC_ERROR X509_V_FLAG_X509_STRICT NID_keyBag R_INVALID_CHALLENGE_LENGTH X509_V_OK NID_key_usage R_NO_CERTIFICATE_SET XN_FLAG_COMPAT NID_localKeyID R_NO_CERTIFICATE_SPECIFIED XN_FLAG_DN_REV NID_localityName R_NO_CIPHER_LIST XN_FLAG_DUMP_UNKNOWN_FIELDS NID_md2 R_NO_CIPHER_MATCH XN_FLAG_FN_ALIGN NID_md2WithRSAEncryption R_NO_PRIVATEKEY XN_FLAG_FN_LN NID_md5 R_NO_PUBLICKEY XN_FLAG_FN_MASK NID_md5WithRSA R_NULL_SSL_CTX XN_FLAG_FN_NONE NID_md5WithRSAEncryption R_PEER_DID_NOT_RETURN_A_CERTIFICATE XN_FLAG_FN_OID NID_md5_sha1 R_PEER_ERROR XN_FLAG_FN_SN NID_mdc2 R_PEER_ERROR_CERTIFICATE XN_FLAG_MULTILINE NID_mdc2WithRSA R_PEER_ERROR_NO_CIPHER XN_FLAG_ONELINE NID_ms_code_com R_PEER_ERROR_UNSUPPORTED_CERTIFICATE_TYPE XN_FLAG_RFC2253 NID_ms_code_ind R_PUBLIC_KEY_ENCRYPT_ERROR XN_FLAG_SEP_COMMA_PLUS NID_ms_ctl_sign R_PUBLIC_KEY_IS_NOT_RSA XN_FLAG_SEP_CPLUS_SPC NID_ms_efs R_READ_WRONG_PACKET_TYPE XN_FLAG_SEP_MASK NID_ms_ext_req R_SHORT_READ XN_FLAG_SEP_MULTILINE NID_ms_sgc R_SSL_SESSION_ID_IS_DIFFERENT XN_FLAG_SEP_SPLUS_SPC NID_name R_UNABLE_TO_EXTRACT_PUBLIC_KEY XN_FLAG_SPC_EQ =head2 INTERNAL ONLY functions (do not use these) The following functions are not intended for use from outside of L module. They might be removed, renamed or changed without prior notice in future version. Simply B! =over =item * hello =item * blength =item * constant =back =head1 EXAMPLES One very good example to look at is the implementation of C in the C file. The following is a simple SSLeay client (with too little error checking :-( #!/usr/bin/perl use Socket; use Net::SSLeay qw(die_now die_if_ssl_error) ; Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); ($dest_serv, $port, $msg) = @ARGV; # Read command line $port = getservbyname ($port, 'tcp') unless $port =~ /^\d+$/; $dest_ip = gethostbyname ($dest_serv); $dest_serv_params = sockaddr_in($port, $dest_ip); socket (S, &AF_INET, &SOCK_STREAM, 0) or die "socket: $!"; connect (S, $dest_serv_params) or die "connect: $!"; select (S); $| = 1; select (STDOUT); # Eliminate STDIO buffering # The network connection is now open, lets fire up SSL $ctx = Net::SSLeay::CTX_new() or die_now("Failed to create SSL_CTX $!"); Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL) or die_if_ssl_error("ssl ctx set options"); $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!"); Net::SSLeay::set_fd($ssl, fileno(S)); # Must use fileno $res = Net::SSLeay::connect($ssl) and die_if_ssl_error("ssl connect"); print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; # Exchange data $res = Net::SSLeay::write($ssl, $msg); # Perl knows how long $msg is die_if_ssl_error("ssl write"); CORE::shutdown S, 1; # Half close --> No more output, sends EOF to server $got = Net::SSLeay::read($ssl); # Perl returns undef on failure die_if_ssl_error("ssl read"); print $got; Net::SSLeay::free ($ssl); # Tear down connection Net::SSLeay::CTX_free ($ctx); close S; The following is a simple SSLeay echo server (non forking): #!/usr/bin/perl -w use Socket; use Net::SSLeay qw(die_now die_if_ssl_error); Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); $our_ip = "\0\0\0\0"; # Bind to all interfaces $port = 1235; $sockaddr_template = 'S n a4 x8'; $our_serv_params = pack ($sockaddr_template, &AF_INET, $port, $our_ip); socket (S, &AF_INET, &SOCK_STREAM, 0) or die "socket: $!"; bind (S, $our_serv_params) or die "bind: $!"; listen (S, 5) or die "listen: $!"; $ctx = Net::SSLeay::CTX_new () or die_now("CTX_new ($ctx): $!"); Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL) or die_if_ssl_error("ssl ctx set options"); # Following will ask password unless private key is not encrypted Net::SSLeay::CTX_use_RSAPrivateKey_file ($ctx, 'plain-rsa.pem', &Net::SSLeay::FILETYPE_PEM); die_if_ssl_error("private key"); Net::SSLeay::CTX_use_certificate_file ($ctx, 'plain-cert.pem', &Net::SSLeay::FILETYPE_PEM); die_if_ssl_error("certificate"); while (1) { print "Accepting connections...\n"; ($addr = accept (NS, S)) or die "accept: $!"; select (NS); $| = 1; select (STDOUT); # Piping hot! ($af,$client_port,$client_ip) = unpack($sockaddr_template,$addr); @inetaddr = unpack('C4',$client_ip); print "$af connection from " . join ('.', @inetaddr) . ":$client_port\n"; # We now have a network connection, lets fire up SSLeay... $ssl = Net::SSLeay::new($ctx) or die_now("SSL_new ($ssl): $!"); Net::SSLeay::set_fd($ssl, fileno(NS)); $err = Net::SSLeay::accept($ssl) and die_if_ssl_error('ssl accept'); print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; # Connected. Exchange some data. $got = Net::SSLeay::read($ssl); # Returns undef on fail die_if_ssl_error("ssl read"); print "Got `$got' (" . length ($got) . " chars)\n"; Net::SSLeay::write ($ssl, uc ($got)) or die "write: $!"; die_if_ssl_error("ssl write"); Net::SSLeay::free ($ssl); # Tear down connection close NS; } Yet another echo server. This one runs from C so it avoids all the socket code overhead. Only caveat is opening an rsa key file - it had better be without any encryption or else it will not know where to ask for the password. Note how C and C are wired to SSL. #!/usr/bin/perl # /etc/inetd.conf # ssltst stream tcp nowait root /path/to/server.pl server.pl # /etc/services # ssltst 1234/tcp use Net::SSLeay qw(die_now die_if_ssl_error); Net::SSLeay::load_error_strings(); Net::SSLeay::SSLeay_add_ssl_algorithms(); Net::SSLeay::randomize(); chdir '/key/dir' or die "chdir: $!"; $| = 1; # Piping hot! open LOG, ">>/dev/console" or die "Can't open log file $!"; select LOG; print "server.pl started\n"; $ctx = Net::SSLeay::CTX_new() or die_now "CTX_new ($ctx) ($!)"; $ssl = Net::SSLeay::new($ctx) or die_now "new ($ssl) ($!)"; Net::SSLeay::set_options($ssl, &Net::SSLeay::OP_ALL) and die_if_ssl_error("ssl set options"); # We get already open network connection from inetd, now we just # need to attach SSLeay to STDIN and STDOUT Net::SSLeay::set_rfd($ssl, fileno(STDIN)); Net::SSLeay::set_wfd($ssl, fileno(STDOUT)); Net::SSLeay::use_RSAPrivateKey_file ($ssl, 'plain-rsa.pem', Net::SSLeay::FILETYPE_PEM); die_if_ssl_error("private key"); Net::SSLeay::use_certificate_file ($ssl, 'plain-cert.pem', Net::SSLeay::FILETYPE_PEM); die_if_ssl_error("certificate"); Net::SSLeay::accept($ssl) and die_if_ssl_err("ssl accept: $!"); print "Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; $got = Net::SSLeay::read($ssl); die_if_ssl_error("ssl read"); print "Got `$got' (" . length ($got) . " chars)\n"; Net::SSLeay::write ($ssl, uc($got)) or die "write: $!"; die_if_ssl_error("ssl write"); Net::SSLeay::free ($ssl); # Tear down the connection Net::SSLeay::CTX_free ($ctx); close LOG; There are also a number of example/test programs in the examples directory: sslecho.pl - A simple server, not unlike the one above minicli.pl - Implements a client using low level SSLeay routines sslcat.pl - Demonstrates using high level sslcat utility function get_page.pl - Is a utility for getting html pages from secure servers callback.pl - Demonstrates certificate verification and callback usage stdio_bulk.pl - Does SSL over Unix pipes ssl-inetd-serv.pl - SSL server that can be invoked from inetd.conf httpd-proxy-snif.pl - Utility that allows you to see how a browser sends https request to given server and what reply it gets back (very educative :-) makecert.pl - Creates a self signed cert (does not use this module) =head1 INSTALLATION See README and README.* in the distribution directory for installation guidance on a variety of platforms. =head1 LIMITATIONS C uses an internal buffer of 32KB, thus no single read will return more. In practice one read returns much less, usually as much as fits in one network packet. To work around this, you should use a loop like this: $reply = ''; while ($got = Net::SSLeay::read($ssl)) { last if print_errs('SSL_read'); $reply .= $got; } Although there is no built-in limit in C, the network packet size limitation applies here as well, thus use: $written = 0; while ($written < length($message)) { $written += Net::SSLeay::write($ssl, substr($message, $written)); last if print_errs('SSL_write'); } Or alternatively you can just use the following convenience functions: Net::SSLeay::ssl_write_all($ssl, $message) or die "ssl write failure"; $got = Net::SSLeay::ssl_read_all($ssl) or die "ssl read failure"; =head1 KNOWN BUGS AND CAVEATS An OpenSSL bug CVE-2015-0290 "OpenSSL Multiblock Corrupted Pointer Issue" can cause POST requests of over 90kB to fail or crash. This bug is reported to be fixed in OpenSSL 1.0.2a. Autoloader emits a Argument "xxx" isn't numeric in entersub at blib/lib/Net/SSLeay.pm' warning if die_if_ssl_error is made autoloadable. If you figure out why, drop me a line. Callback set using C does not appear to work. This may well be an openssl problem (e.g. see C line 1029). Try using C instead and do not be surprised if even this stops working in future versions. Callback and certificate verification stuff is generally too little tested. Random numbers are not initialized randomly enough, especially if you do not have C and/or C (such as in Solaris platforms - but it's been suggested that cryptorand daemon from the SUNski package solves this). In this case you should investigate third party software that can emulate these devices, e.g. by way of a named pipe to some program. Another gotcha with random number initialization is randomness depletion. This phenomenon, which has been extensively discussed in OpenSSL, Apache-SSL, and Apache-mod_ssl forums, can cause your script to block if you use C or to operate insecurely if you use C. What happens is that when too much randomness is drawn from the operating system's randomness pool then randomness can temporarily be unavailable. C solves this problem by waiting until enough randomness can be gathered - and this can take a long time since blocking reduces activity in the machine and less activity provides less random events: a vicious circle. C solves this dilemma more pragmatically by simply returning predictable "random" numbers. SomeC< /dev/urandom> emulation software however actually seems to implement C semantics. Caveat emptor. I've been pointed to two such daemons by Mik Firestone who has used them on Solaris 8: =over =item 1 Entropy Gathering Daemon (EGD) at L =item 2 Pseudo-random number generating daemon (PRNGD) at L =back If you are using the low level API functions to communicate with other SSL implementations, you would do well to call Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL) or die_if_ssl_error("ssl ctx set options"); to cope with some well know bugs in some other SSL implementations. The high level API functions always set all known compatibility options. Sometimes C (and the high level HTTPS functions that build on it) is too fast in signaling the EOF to legacy HTTPS servers. This causes the server to return empty page. To work around this problem you can set the global variable $Net::SSLeay::slowly = 1; # Add sleep so broken servers can keep up HTTP/1.1 is not supported. Specifically this module does not know to issue or serve multiple http requests per connection. This is a serious shortcoming, but using the SSL session cache on your server helps to alleviate the CPU load somewhat. As of version 1.09 many newer OpenSSL auxiliary functions were added (from C onwards in C). Unfortunately I have not had any opportunity to test these. Some of them are trivial enough that I believe they "just work", but others have rather complex interfaces with function pointers and all. In these cases you should proceed wit great caution. This module defaults to using OpenSSL automatic protocol negotiation code for automatically detecting the version of the SSL/TLS protocol that the other end talks. With most web servers this works just fine, but once in a while I get complaints from people that the module does not work with some web servers. Usually this can be solved by explicitly setting the protocol version, e.g. $Net::SSLeay::ssl_version = 2; # Insist on SSLv2 $Net::SSLeay::ssl_version = 3; # Insist on SSLv3 $Net::SSLeay::ssl_version = 10; # Insist on TLSv1 $Net::SSLeay::ssl_version = 11; # Insist on TLSv1.1 $Net::SSLeay::ssl_version = 12; # Insist on TLSv1.2 $Net::SSLeay::ssl_version = 13; # Insist on TLSv1.3 Although the autonegotiation is nice to have, the SSL standards do not formally specify any such mechanism. Most of the world has accepted the SSLeay/OpenSSL way of doing it as the de facto standard. But for the few that think differently, you have to explicitly speak the correct version. This is not really a bug, but rather a deficiency in the standards. If a site refuses to respond or sends back some nonsensical error codes (at the SSL handshake level), try this option before mailing me. On some systems, OpenSSL may be compiled without support for SSLv2. If this is the case, Net::SSLeay will warn if ssl_version has been set to 2. The high level API returns the certificate of the peer, thus allowing one to check what certificate was supplied. However, you will only be able to check the certificate after the fact, i.e. you already sent your form data by the time you find out that you did not trust them, oops. So, while being able to know the certificate after the fact is surely useful, the security minded would still choose to do the connection and certificate verification first and only then exchange data with the site. Currently none of the high level API functions do this, thus you would have to program it using the low level API. A good place to start is to see how the C function is implemented. The high level API functions use a global file handle C internally. This really should not be a problem because there is no way to interleave the high level API functions, unless you use threads (but threads are not very well supported in perl anyway). However, you may run into problems if you call undocumented internal functions in an interleaved fashion. The best solution is to "require Net::SSLeay" in one thread after all the threads have been created. =head1 DIAGNOSTICS =over =item Random number generator not seeded!!! B<(W)> This warning indicates that C was not able to read C or C, possibly because your system does not have them or they are differently named. You can still use SSL, but the encryption will not be as strong. =item open_tcp_connection: destination host not found:`server' (port 123) ($!) Name lookup for host named C failed. =item open_tcp_connection: failed `server', 123 ($!) The name was resolved, but establishing the TCP connection failed. =item msg 123: 1 - error:140770F8:SSL routines:SSL23_GET_SERVER_HELLO:unknown proto SSLeay error string. The first number (123) is the PID, the second number (1) indicates the position of the error message in SSLeay error stack. You often see a pile of these messages as errors cascade. =item msg 123: 1 - error:02001002::lib(2) :func(1) :reason(2) The same as above, but you didn't call load_error_strings() so SSLeay couldn't verbosely explain the error. You can still find out what it means with this command: /usr/local/ssl/bin/ssleay errstr 02001002 =item Password is being asked for private key This is normal behaviour if your private key is encrypted. Either you have to supply the password or you have to use an unencrypted private key. Scan OpenSSL.org for the FAQ that explains how to do this (or just study examples/makecert.pl which is used during C to do just that). =back =head1 SECURITY You can mitigate some of the security vulnerabilities that might be present in your SSL/TLS application: =head2 BEAST Attack http://blogs.cisco.com/security/beat-the-beast-with-tls/ https://community.qualys.com/blogs/securitylabs/2011/10/17/mitigating-the-beast-attack-on-tls http://blog.zoller.lu/2011/09/beast-summary-tls-cbc-countermeasures.html The BEAST attack relies on a weakness in the way CBC mode is used in SSL/TLS. In OpenSSL versions 0.9.6d and later, the protocol-level mitigation is enabled by default, thus making it not vulnerable to the BEAST attack. Solutions: =over =item * Compile with OpenSSL versions 0.9.6d or later, which enables SSL_OP_ALL by default =item * Ensure SSL_OP_DONT_INSERT_EMPTY_FRAGMENTS is not enabled (its not enabled by default) =item * Don't support SSLv2, SSLv3 =item * Actively control the ciphers your server supports with set_cipher_list: =back Net::SSLeay::set_cipher_list($ssl, 'RC4-SHA:HIGH:!ADH'); =head2 Session Resumption http://www.openssl.org/docs/ssl/SSL_CTX_set_options.html The SSL Labs vulnerability test on your SSL server might report in red: Session resumption No (IDs assigned but not accepted) This report is not really bug or a vulnerability, since the server will not accept session resumption requests. However, you can prevent this noise in the report by disabling the session cache altogether: Net::SSLeay::CTX_set_session_cache_mode($ssl_ctx, Net::SSLeay::SESS_CACHE_OFF()); Use 0 if you don't have SESS_CACHE_OFF constant. =head2 Secure Renegotiation and DoS Attack https://community.qualys.com/blogs/securitylabs/2011/10/31/tls-renegotiation-and-denial-of-service-attacks This is not a "security flaw," it is more of a DoS vulnerability. Solutions: =over =item * Do not support SSLv2 =item * Do not set the SSL_OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION option =item * Compile with OpenSSL 0.9.8m or later =back =head1 BUGS If you encounter a problem with this module that you believe is a bug, please report it in one of the following ways: =over =item * L under the Net-SSLeay GitHub project at L; =item * L using the CPAN RT bug tracker's web interface at L; =item * send an email to the CPAN RT bug tracker at L. =back Please make sure your bug report includes the following information: =over =item * the code you are trying to run; =item * your operating system name and version; =item * the output of C; =item * the version of OpenSSL or LibreSSL you are using. =back =head1 AUTHOR Originally written by Sampo Kellomäki. Maintained by Florian Ragwitz between November 2005 and January 2010. Maintained by Mike McCauley between November 2005 and June 2018. Maintained by Chris Novakovic, Tuure Vartiainen and Heikki Vatiainen since June 2018. =head1 COPYRIGHT Copyright (c) 1996-2003 Sampo Kellomäki Copyright (c) 2005-2010 Florian Ragwitz Copyright (c) 2005-2018 Mike McCauley Copyright (c) 2018- Chris Novakovic Copyright (c) 2018- Tuure Vartiainen Copyright (c) 2018- Heikki Vatiainen All rights reserved. =head1 LICENSE This module is released under the terms of the Artistic License 2.0. For details, see the C file distributed with Net-SSLeay's source code. =head1 SEE ALSO Net::SSLeay::Handle - File handle interface ./examples - Example servers and a clients - OpenSSL source, documentation, etc openssl-users-request@openssl.org - General OpenSSL mailing list - TLS 1.0 specification - HTTP specifications - How to send password - Entropy Gathering Daemon (EGD) - pseudo-random number generating daemon (PRNGD) perl(1) perlref(1) perllol(1) perldoc ~openssl/doc/ssl/SSL_CTX_set_verify.pod IP/.packlist000064400000000163152344772430006702 0ustar00/usr/local/bin/ipcount /usr/local/bin/iptab /usr/local/share/man/man3/Net::IP.3pm /usr/local/share/perl5/Net/IP.pm DNS/.packlist000064400000017641152344772450007031 0ustar00/usr/local/share/man/man3/Net::DNS.3pm /usr/local/share/man/man3/Net::DNS::Domain.3pm /usr/local/share/man/man3/Net::DNS::DomainName.3pm /usr/local/share/man/man3/Net::DNS::FAQ.3pm /usr/local/share/man/man3/Net::DNS::Header.3pm /usr/local/share/man/man3/Net::DNS::Mailbox.3pm /usr/local/share/man/man3/Net::DNS::Nameserver.3pm /usr/local/share/man/man3/Net::DNS::Packet.3pm /usr/local/share/man/man3/Net::DNS::Parameters.3pm /usr/local/share/man/man3/Net::DNS::Question.3pm /usr/local/share/man/man3/Net::DNS::RR.3pm /usr/local/share/man/man3/Net::DNS::RR::A.3pm /usr/local/share/man/man3/Net::DNS::RR::AAAA.3pm /usr/local/share/man/man3/Net::DNS::RR::AFSDB.3pm /usr/local/share/man/man3/Net::DNS::RR::AMTRELAY.3pm /usr/local/share/man/man3/Net::DNS::RR::APL.3pm /usr/local/share/man/man3/Net::DNS::RR::CAA.3pm /usr/local/share/man/man3/Net::DNS::RR::CDNSKEY.3pm /usr/local/share/man/man3/Net::DNS::RR::CDS.3pm /usr/local/share/man/man3/Net::DNS::RR::CERT.3pm /usr/local/share/man/man3/Net::DNS::RR::CNAME.3pm /usr/local/share/man/man3/Net::DNS::RR::CSYNC.3pm /usr/local/share/man/man3/Net::DNS::RR::DELEG.3pm /usr/local/share/man/man3/Net::DNS::RR::DHCID.3pm /usr/local/share/man/man3/Net::DNS::RR::DNAME.3pm /usr/local/share/man/man3/Net::DNS::RR::DNSKEY.3pm /usr/local/share/man/man3/Net::DNS::RR::DS.3pm /usr/local/share/man/man3/Net::DNS::RR::DSYNC.3pm /usr/local/share/man/man3/Net::DNS::RR::EUI48.3pm /usr/local/share/man/man3/Net::DNS::RR::EUI64.3pm /usr/local/share/man/man3/Net::DNS::RR::GPOS.3pm /usr/local/share/man/man3/Net::DNS::RR::HINFO.3pm /usr/local/share/man/man3/Net::DNS::RR::HIP.3pm /usr/local/share/man/man3/Net::DNS::RR::HTTPS.3pm /usr/local/share/man/man3/Net::DNS::RR::IPSECKEY.3pm /usr/local/share/man/man3/Net::DNS::RR::ISDN.3pm /usr/local/share/man/man3/Net::DNS::RR::KEY.3pm /usr/local/share/man/man3/Net::DNS::RR::KX.3pm /usr/local/share/man/man3/Net::DNS::RR::L32.3pm /usr/local/share/man/man3/Net::DNS::RR::L64.3pm /usr/local/share/man/man3/Net::DNS::RR::LOC.3pm /usr/local/share/man/man3/Net::DNS::RR::LP.3pm /usr/local/share/man/man3/Net::DNS::RR::MB.3pm /usr/local/share/man/man3/Net::DNS::RR::MG.3pm /usr/local/share/man/man3/Net::DNS::RR::MINFO.3pm /usr/local/share/man/man3/Net::DNS::RR::MR.3pm /usr/local/share/man/man3/Net::DNS::RR::MX.3pm /usr/local/share/man/man3/Net::DNS::RR::NAPTR.3pm /usr/local/share/man/man3/Net::DNS::RR::NID.3pm /usr/local/share/man/man3/Net::DNS::RR::NS.3pm /usr/local/share/man/man3/Net::DNS::RR::NSEC.3pm /usr/local/share/man/man3/Net::DNS::RR::NSEC3.3pm /usr/local/share/man/man3/Net::DNS::RR::NSEC3PARAM.3pm /usr/local/share/man/man3/Net::DNS::RR::NULL.3pm /usr/local/share/man/man3/Net::DNS::RR::OPENPGPKEY.3pm /usr/local/share/man/man3/Net::DNS::RR::OPT.3pm /usr/local/share/man/man3/Net::DNS::RR::PTR.3pm /usr/local/share/man/man3/Net::DNS::RR::PX.3pm /usr/local/share/man/man3/Net::DNS::RR::RESINFO.3pm /usr/local/share/man/man3/Net::DNS::RR::RP.3pm /usr/local/share/man/man3/Net::DNS::RR::RRSIG.3pm /usr/local/share/man/man3/Net::DNS::RR::RT.3pm /usr/local/share/man/man3/Net::DNS::RR::SIG.3pm /usr/local/share/man/man3/Net::DNS::RR::SMIMEA.3pm /usr/local/share/man/man3/Net::DNS::RR::SOA.3pm /usr/local/share/man/man3/Net::DNS::RR::SPF.3pm /usr/local/share/man/man3/Net::DNS::RR::SRV.3pm /usr/local/share/man/man3/Net::DNS::RR::SSHFP.3pm /usr/local/share/man/man3/Net::DNS::RR::SVCB.3pm /usr/local/share/man/man3/Net::DNS::RR::TKEY.3pm /usr/local/share/man/man3/Net::DNS::RR::TLSA.3pm /usr/local/share/man/man3/Net::DNS::RR::TSIG.3pm /usr/local/share/man/man3/Net::DNS::RR::TXT.3pm /usr/local/share/man/man3/Net::DNS::RR::URI.3pm /usr/local/share/man/man3/Net::DNS::RR::X25.3pm /usr/local/share/man/man3/Net::DNS::RR::ZONEMD.3pm /usr/local/share/man/man3/Net::DNS::Resolver.3pm /usr/local/share/man/man3/Net::DNS::Resolver::Base.3pm /usr/local/share/man/man3/Net::DNS::Resolver::MSWin32.3pm /usr/local/share/man/man3/Net::DNS::Resolver::Recurse.3pm /usr/local/share/man/man3/Net::DNS::Resolver::UNIX.3pm /usr/local/share/man/man3/Net::DNS::Resolver::android.3pm /usr/local/share/man/man3/Net::DNS::Resolver::cygwin.3pm /usr/local/share/man/man3/Net::DNS::Resolver::os2.3pm /usr/local/share/man/man3/Net::DNS::Resolver::os390.3pm /usr/local/share/man/man3/Net::DNS::Text.3pm /usr/local/share/man/man3/Net::DNS::Update.3pm /usr/local/share/man/man3/Net::DNS::ZoneFile.3pm /usr/local/share/perl5/Net/DNS.pm /usr/local/share/perl5/Net/DNS/Domain.pm /usr/local/share/perl5/Net/DNS/DomainName.pm /usr/local/share/perl5/Net/DNS/FAQ.pod /usr/local/share/perl5/Net/DNS/Header.pm /usr/local/share/perl5/Net/DNS/Mailbox.pm /usr/local/share/perl5/Net/DNS/Nameserver.pm /usr/local/share/perl5/Net/DNS/Packet.pm /usr/local/share/perl5/Net/DNS/Parameters.pm /usr/local/share/perl5/Net/DNS/Question.pm /usr/local/share/perl5/Net/DNS/RR.pm /usr/local/share/perl5/Net/DNS/RR/A.pm /usr/local/share/perl5/Net/DNS/RR/AAAA.pm /usr/local/share/perl5/Net/DNS/RR/AFSDB.pm /usr/local/share/perl5/Net/DNS/RR/AMTRELAY.pm /usr/local/share/perl5/Net/DNS/RR/APL.pm /usr/local/share/perl5/Net/DNS/RR/CAA.pm /usr/local/share/perl5/Net/DNS/RR/CDNSKEY.pm /usr/local/share/perl5/Net/DNS/RR/CDS.pm /usr/local/share/perl5/Net/DNS/RR/CERT.pm /usr/local/share/perl5/Net/DNS/RR/CNAME.pm /usr/local/share/perl5/Net/DNS/RR/CSYNC.pm /usr/local/share/perl5/Net/DNS/RR/DELEG.pm /usr/local/share/perl5/Net/DNS/RR/DHCID.pm /usr/local/share/perl5/Net/DNS/RR/DNAME.pm /usr/local/share/perl5/Net/DNS/RR/DNSKEY.pm /usr/local/share/perl5/Net/DNS/RR/DS.pm /usr/local/share/perl5/Net/DNS/RR/DSYNC.pm /usr/local/share/perl5/Net/DNS/RR/EUI48.pm /usr/local/share/perl5/Net/DNS/RR/EUI64.pm /usr/local/share/perl5/Net/DNS/RR/GPOS.pm /usr/local/share/perl5/Net/DNS/RR/HINFO.pm /usr/local/share/perl5/Net/DNS/RR/HIP.pm /usr/local/share/perl5/Net/DNS/RR/HTTPS.pm /usr/local/share/perl5/Net/DNS/RR/IPSECKEY.pm /usr/local/share/perl5/Net/DNS/RR/ISDN.pm /usr/local/share/perl5/Net/DNS/RR/KEY.pm /usr/local/share/perl5/Net/DNS/RR/KX.pm /usr/local/share/perl5/Net/DNS/RR/L32.pm /usr/local/share/perl5/Net/DNS/RR/L64.pm /usr/local/share/perl5/Net/DNS/RR/LOC.pm /usr/local/share/perl5/Net/DNS/RR/LP.pm /usr/local/share/perl5/Net/DNS/RR/MB.pm /usr/local/share/perl5/Net/DNS/RR/MG.pm /usr/local/share/perl5/Net/DNS/RR/MINFO.pm /usr/local/share/perl5/Net/DNS/RR/MR.pm /usr/local/share/perl5/Net/DNS/RR/MX.pm /usr/local/share/perl5/Net/DNS/RR/NAPTR.pm /usr/local/share/perl5/Net/DNS/RR/NID.pm /usr/local/share/perl5/Net/DNS/RR/NS.pm /usr/local/share/perl5/Net/DNS/RR/NSEC.pm /usr/local/share/perl5/Net/DNS/RR/NSEC3.pm /usr/local/share/perl5/Net/DNS/RR/NSEC3PARAM.pm /usr/local/share/perl5/Net/DNS/RR/NULL.pm /usr/local/share/perl5/Net/DNS/RR/OPENPGPKEY.pm /usr/local/share/perl5/Net/DNS/RR/OPT.pm /usr/local/share/perl5/Net/DNS/RR/PTR.pm /usr/local/share/perl5/Net/DNS/RR/PX.pm /usr/local/share/perl5/Net/DNS/RR/RESINFO.pm /usr/local/share/perl5/Net/DNS/RR/RP.pm /usr/local/share/perl5/Net/DNS/RR/RRSIG.pm /usr/local/share/perl5/Net/DNS/RR/RT.pm /usr/local/share/perl5/Net/DNS/RR/SIG.pm /usr/local/share/perl5/Net/DNS/RR/SMIMEA.pm /usr/local/share/perl5/Net/DNS/RR/SOA.pm /usr/local/share/perl5/Net/DNS/RR/SPF.pm /usr/local/share/perl5/Net/DNS/RR/SRV.pm /usr/local/share/perl5/Net/DNS/RR/SSHFP.pm /usr/local/share/perl5/Net/DNS/RR/SVCB.pm /usr/local/share/perl5/Net/DNS/RR/TKEY.pm /usr/local/share/perl5/Net/DNS/RR/TLSA.pm /usr/local/share/perl5/Net/DNS/RR/TSIG.pm /usr/local/share/perl5/Net/DNS/RR/TXT.pm /usr/local/share/perl5/Net/DNS/RR/URI.pm /usr/local/share/perl5/Net/DNS/RR/X25.pm /usr/local/share/perl5/Net/DNS/RR/ZONEMD.pm /usr/local/share/perl5/Net/DNS/Resolver.pm /usr/local/share/perl5/Net/DNS/Resolver/Base.pm /usr/local/share/perl5/Net/DNS/Resolver/MSWin32.pm /usr/local/share/perl5/Net/DNS/Resolver/Recurse.pm /usr/local/share/perl5/Net/DNS/Resolver/UNIX.pm /usr/local/share/perl5/Net/DNS/Resolver/android.pm /usr/local/share/perl5/Net/DNS/Resolver/cygwin.pm /usr/local/share/perl5/Net/DNS/Resolver/os2.pm /usr/local/share/perl5/Net/DNS/Resolver/os390.pm /usr/local/share/perl5/Net/DNS/Text.pm /usr/local/share/perl5/Net/DNS/Update.pm /usr/local/share/perl5/Net/DNS/ZoneFile.pm DNS/Resolver/Mock/.packlist000064400000000147152344772520011512 0ustar00/usr/local/share/man/man3/Net::DNS::Resolver::Mock.3pm /usr/local/share/perl5/Net/DNS/Resolver/Mock.pm IDN/Encode/.packlist000064400000001275152344772520010206 0ustar00/usr/local/share/man/man3/Net::IDN::Encode.3pm /usr/local/share/man/man3/Net::IDN::Overview.3pm /usr/local/share/man/man3/Net::IDN::Punycode.3pm /usr/local/share/man/man3/Net::IDN::Punycode::PP.3pm /usr/local/share/man/man3/Net::IDN::Standards.3pm /usr/local/share/man/man3/Net::IDN::UTS46.3pm /usr/local/share/man/man3/Net::IDN::UTS46::_Mapping.3pm /usr/local/share/perl5/Net/IDN/Encode.pm /usr/local/share/perl5/Net/IDN/Overview.pod /usr/local/share/perl5/Net/IDN/Punycode.pm /usr/local/share/perl5/Net/IDN/Punycode.xs /usr/local/share/perl5/Net/IDN/Punycode/PP.pm /usr/local/share/perl5/Net/IDN/Standards.pod /usr/local/share/perl5/Net/IDN/UTS46.pm /usr/local/share/perl5/Net/IDN/UTS46/_Mapping.pm IP.pm000044400000220471152345050350005420 0ustar00# Copyright (c) 1999 - 2002 RIPE NCC # # All Rights Reserved # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, # provided that the above copyright notice appear in all copies and that # both that copyright notice and this permission notice appear in # supporting documentation, and that the name of the author not be # used in advertising or publicity pertaining to distribution of the # software without specific, written prior permission. # # THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING # ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL # AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY # DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN # AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF # OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. #------------------------------------------------------------------------------ # Module Header # Filename : IP.pm # Purpose : Provide functions to manipulate IPv4/v6 addresses # Author : Manuel Valente # Date : 19991124 # Description : # Language Version : Perl 5 # OSs Tested : BSDI 3.1 - Linux # Command Line : ipcount # Input Files : # Output Files : # External Programs : Math::BigInt.pm # Problems : # To Do : # Comments : Based on ipv4pack.pm (Monica) and iplib.pm (Lee) # Math::BigInt is only loaded if int functions are used # $Id: IP.pm,v 1.23 2003/02/18 16:13:01 manuel Exp $ #------------------------------------------------------------------------------ package Net::IP; use strict; use Math::BigInt; # Global Variables definition use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $ERROR $ERRNO %IPv4ranges %IPv6ranges $useBigInt $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL); $VERSION = '1.26'; require Exporter; @ISA = qw(Exporter); # Functions and variables exported in all cases @EXPORT = qw(&Error &Errno $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL ); # Functions exported on demand (with :PROC) @EXPORT_OK = qw(&Error &Errno &ip_iptobin &ip_bintoip &ip_bintoint &ip_inttobin &ip_get_version &ip_is_ipv4 &ip_is_ipv6 &ip_expand_address &ip_get_mask &ip_last_address_bin &ip_splitprefix &ip_prefix_to_range &ip_is_valid_mask &ip_bincomp &ip_binadd &ip_get_prefix_length &ip_range_to_prefix &ip_compress_address &ip_is_overlap &ip_get_embedded_ipv4 &ip_aggregate &ip_iptype &ip_check_prefix &ip_reverse &ip_normalize &ip_normal_range &ip_iplengths $IP_NO_OVERLAP $IP_PARTIAL_OVERLAP $IP_A_IN_B_OVERLAP $IP_B_IN_A_OVERLAP $IP_IDENTICAL ); %EXPORT_TAGS = (PROC => [@EXPORT_OK],); # Definition of the Ranges for IPv4 IPs %IPv4ranges = ( '00000000' => 'PRIVATE', # 0/8 '00001010' => 'PRIVATE', # 10/8 '0110010001' => 'SHARED', # 100.64/10 '01111111' => 'LOOPBACK', # 127.0/8 '1010100111111110' => 'LINK-LOCAL', # 169.254/16 '101011000001' => 'PRIVATE', # 172.16/12 '110000000000000000000000' => 'RESERVED', # 192.0.0/24 '110000000000000000000010' => 'TEST-NET', # 192.0.2/24 '110000000101100001100011' => '6TO4-RELAY', # 192.88.99.0/24 '1100000010101000' => 'PRIVATE', # 192.168/16 '110001100001001' => 'RESERVED', # 198.18/15 '110001100011001101100100' => 'TEST-NET', # 198.51.100/24 '110010110000000001110001' => 'TEST-NET', # 203.0.113/24 '1110' => 'MULTICAST', # 224/4 '1111' => 'RESERVED', # 240/4 '11111111111111111111111111111111' => 'BROADCAST', # 255.255.255.255/32 ); # Definition of the Ranges for Ipv6 IPs %IPv6ranges = ( '00000000' => 'RESERVED', # ::/8 ('0' x 128) => 'UNSPECIFIED', # ::/128 ('0' x 127) . '1' => 'LOOPBACK', # ::1/128 ('0' x 80) . ('1' x 16) => 'IPV4MAP', # ::FFFF:0:0/96 '00000001' => 'RESERVED', # 0100::/8 '0000000100000000' . ('0' x 48) => 'DISCARD', # 0100::/64 '0000001' => 'RESERVED', # 0200::/7 '000001' => 'RESERVED', # 0400::/6 '00001' => 'RESERVED', # 0800::/5 '0001' => 'RESERVED', # 1000::/4 '001' => 'GLOBAL-UNICAST', # 2000::/3 '0010000000000001' . ('0' x 16) => 'TEREDO', # 2001::/32 '00100000000000010000000000000010' . ('0' x 16) => 'BMWG', # 2001:0002::/48 '00100000000000010000110110111000' => 'DOCUMENTATION', # 2001:DB8::/32 '0010000000000001000000000001' => 'ORCHID', # 2001:10::/28 '0010000000000010' => '6TO4', # 2002::/16 '010' => 'RESERVED', # 4000::/3 '011' => 'RESERVED', # 6000::/3 '100' => 'RESERVED', # 8000::/3 '101' => 'RESERVED', # A000::/3 '110' => 'RESERVED', # C000::/3 '1110' => 'RESERVED', # E000::/4 '11110' => 'RESERVED', # F000::/5 '111110' => 'RESERVED', # F800::/6 '1111110' => 'UNIQUE-LOCAL-UNICAST', # FC00::/7 '111111100' => 'RESERVED', # FE00::/9 '1111111010' => 'LINK-LOCAL-UNICAST', # FE80::/10 '1111111011' => 'RESERVED', # FEC0::/10 '11111111' => 'MULTICAST', # FF00::/8 ); # Overlap constants $IP_NO_OVERLAP = 0; $IP_PARTIAL_OVERLAP = 1; $IP_A_IN_B_OVERLAP = -1; $IP_B_IN_A_OVERLAP = -2; $IP_IDENTICAL = -3; # ---------------------------------------------------------- # OVERLOADING use overload ( '+' => 'ip_add_num', 'bool' => sub { @_ }, ); #------------------------------------------------------------------------------ # Subroutine ip_num_add # Purpose : Add an integer to an IP # Params : Number to add # Returns : New object or undef # Note : Used by overloading - returns undef when # the end of the range is reached sub ip_add_num { my $self = shift; my ($value) = @_; my $ip = $self->intip + $value; my $last = $self->last_int; # Reached the end of the range ? if ($ip > $self->last_int) { return; } my $newb = ip_inttobin($ip, $self->version); $newb = ip_bintoip($newb, $self->version); my $newe = ip_inttobin($last, $self->version); $newe = ip_bintoip($newe, $self->version); my $new = new Net::IP("$newb - $newe"); return ($new); } # ----------------------------------------------------------------------------- #------------------------------------------------------------------------------ # Subroutine new # Purpose : Create an instance of an IP object # Params : Class, IP prefix, IP version # Returns : Object reference or undef # Note : New just allocates a new object - set() does all the work sub new { my ($class, $data, $ipversion) = (@_); # Allocate new object my $self = {}; bless($self, $class); # Pass everything to set() unless ($self->set($data, $ipversion)) { return; } return $self; } #------------------------------------------------------------------------------ # Subroutine set # Purpose : Set the IP for an IP object # Params : Data, IP type # Returns : 1 (success) or undef (failure) sub set { my $self = shift; my ($data, $ipversion) = @_; # Normalize data as received - this should return 2 IPs my ($begin, $end) = ip_normalize($data, $ipversion) or do { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; }; # Those variables are set when the object methods are called # We need to reset everything for ( qw(ipversion errno prefixlen binmask reverse_ip last_ip iptype binip error ip intformat hexformat mask last_bin last_int prefix is_prefix) ) { delete($self->{$_}); } # Determine IP version for this object return unless ($self->{ipversion} = $ipversion || ip_get_version($begin)); # Set begin IP address $self->{ip} = $begin; # Set Binary IP address return unless ($self->{binip} = ip_iptobin($self->ip(), $self->version())); $self->{is_prefix} = 0; # Set end IP address # If single IP: begin and end IPs are identical $end ||= $begin; $self->{last_ip} = $end; # Try to determine the IP version my $ver = ip_get_version($end) || return; # Check if begin and end addresses have the same version if ($ver != $self->version()) { $ERRNO = 201; $ERROR = "Begin and End addresses have different IP versions - $begin - $end"; $self->{errno} = $ERRNO; $self->{error} = $ERROR; return; } # Get last binary address return unless ($self->{last_bin} = ip_iptobin($self->last_ip(), $self->version())); # Check that End IP >= Begin IP unless (ip_bincomp($self->binip(), 'le', $self->last_bin())) { $ERRNO = 202; $ERROR = "Begin address is greater than End address $begin - $end"; $self->{errno} = $ERRNO; $self->{error} = $ERROR; return; } # Find all prefixes (eg:/24) in the current range my @prefixes = $self->find_prefixes() or return; # If there is only one prefix: if (scalar(@prefixes) == 1) { # Get length of prefix return unless ((undef, $self->{prefixlen}) = ip_splitprefix($prefixes[0])); # Set prefix boolean var # This value is 1 if the IP range only contains a single /nn prefix $self->{is_prefix} = 1; } # If the range is a single prefix: if ($self->{is_prefix}) { # Set mask property $self->{binmask} = ip_get_mask($self->prefixlen(), $self->version()); # Check that the mask is valid unless ( ip_check_prefix( $self->binip(), $self->prefixlen(), $self->version() ) ) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } } return ($self); } sub print { my $self = shift; if ($self->{is_prefix}) { return ($self->short() . '/' . $self->prefixlen()); } else { return (sprintf("%s - %s", $self->ip(), $self->last_ip())); } } #------------------------------------------------------------------------------ # Subroutine error # Purpose : Return the current error message # Returns : Error string sub error { my $self = shift; return $self->{error}; } #------------------------------------------------------------------------------ # Subroutine errno # Purpose : Return the current error number # Returns : Error number sub errno { my $self = shift; return $self->{errno}; } #------------------------------------------------------------------------------ # Subroutine binip # Purpose : Return the IP as a binary string # Returns : binary string sub binip { my $self = shift; return $self->{binip}; } #------------------------------------------------------------------------------ # Subroutine prefixlen # Purpose : Get the IP prefix length # Returns : prefix length sub prefixlen { my $self = shift; return $self->{prefixlen}; } #------------------------------------------------------------------------------ # Subroutine version # Purpose : Return the IP version # Returns : IP version sub version { my $self = shift; return $self->{ipversion}; } #------------------------------------------------------------------------------ # Subroutine version # Purpose : Return the IP in quad format # Returns : IP string sub ip { my $self = shift; return $self->{ip}; } #------------------------------------------------------------------------------ # Subroutine is_prefix # Purpose : Check if range of IPs is a prefix # Returns : boolean sub is_prefix { my $self = shift; return $self->{is_prefix}; } #------------------------------------------------------------------------------ # Subroutine binmask # Purpose : Return the binary mask of an IP prefix # Returns : Binary mask (as string) sub binmask { my $self = shift; return $self->{binmask}; } #------------------------------------------------------------------------------ # Subroutine size # Purpose : Return the number of addresses contained in an IP object # Returns : Number of addresses sub size { my $self = shift; my $size = new Math::BigInt($self->last_int); $size->badd(1); $size->bsub($self->intip); } # All the following functions work the same way: the method is just a frontend # to the real function. When the real function is called, the output is cached # so that next time the same function is called,the frontend function directly # returns the result. #------------------------------------------------------------------------------ # Subroutine intip # Purpose : Return the IP in integer format # Returns : Integer sub intip { my $self = shift; return ($self->{intformat}) if defined($self->{intformat}); my $int = ip_bintoint($self->binip()); if (!$int) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{intformat} = $int; return ($int); } #------------------------------------------------------------------------------ # Subroutine hexip # Purpose : Return the IP in hex format # Returns : hex string sub hexip { my $self = shift; return $self->{'hexformat'} if(defined($self->{'hexformat'})); $self->{'hexformat'} = $self->intip->as_hex(); return $self->{'hexformat'}; } #------------------------------------------------------------------------------ # Subroutine hexmask # Purpose : Return the mask back in hex # Returns : hex string sub hexmask { my $self = shift; return $self->{hexmask} if(defined($self->{hexmask})); my $intmask = ip_bintoint($self->binmask); $self->{'hexmask'} = $intmask->as_hex(); return ($self->{'hexmask'}); } #------------------------------------------------------------------------------ # Subroutine prefix # Purpose : Return the Prefix (n.n.n.n/s) # Returns : IP Prefix sub prefix { my $self = shift; if (not $self->is_prefix()) { $self->{error} = "IP range $self->{ip} is not a Prefix."; $self->{errno} = 209; return; } return ($self->{prefix}) if defined($self->{prefix}); my $prefix = $self->ip() . '/' . $self->prefixlen(); if (!$prefix) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{prefix} = $prefix; return ($prefix); } #------------------------------------------------------------------------------ # Subroutine mask # Purpose : Return the IP mask in quad format # Returns : Mask (string) sub mask { my $self = shift; if (not $self->is_prefix()) { $self->{error} = "IP range $self->{ip} is not a Prefix."; $self->{errno} = 209; return; } return ($self->{mask}) if defined($self->{mask}); my $mask = ip_bintoip($self->binmask(), $self->version()); if (!$mask) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{mask} = $mask; return ($mask); } #------------------------------------------------------------------------------ # Subroutine short # Purpose : Get the short format of an IP address or a Prefix # Returns : short format IP or undef sub short { my $self = shift; my $r; if ($self->version == 6) { $r = ip_compress_address($self->ip(), $self->version()); } else { $r = ip_compress_v4_prefix($self->ip(), $self->prefixlen()); } if (!defined($r)) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return ($r); } #------------------------------------------------------------------------------ # Subroutine iptype # Purpose : Return the type of an IP # Returns : Type or undef (failure) sub iptype { my ($self) = shift; return ($self->{iptype}) if defined($self->{iptype}); my $type = ip_iptype($self->binip(), $self->version()); if (!$type) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{iptype} = $type; return ($type); } #------------------------------------------------------------------------------ # Subroutine reverse_ip # Purpose : Return the Reverse IP # Returns : Reverse IP or undef(failure) sub reverse_ip { my ($self) = shift; if (not $self->is_prefix()) { $self->{error} = "IP range $self->{ip} is not a Prefix."; $self->{errno} = 209; return; } return ($self->{reverse_ip}) if defined($self->{reverse_ip}); my $rev = ip_reverse($self->ip(), $self->prefixlen(), $self->version()); if (!$rev) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{reverse_ip} = $rev; return ($rev); } #------------------------------------------------------------------------------ # Subroutine last_bin # Purpose : Get the last IP of a range in binary format # Returns : Last binary IP or undef (failure) sub last_bin { my ($self) = shift; return ($self->{last_bin}) if defined($self->{last_bin}); my $last; if ($self->is_prefix()) { $last = ip_last_address_bin($self->binip(), $self->prefixlen(), $self->version()); } else { $last = ip_iptobin($self->last_ip(), $self->version()); } if (!$last) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{last_bin} = $last; return ($last); } #------------------------------------------------------------------------------ # Subroutine last_int # Purpose : Get the last IP of a range in integer format # Returns : Last integer IP or undef (failure) sub last_int { my ($self) = shift; return ($self->{last_int}) if defined($self->{last_int}); my $last_bin = $self->last_bin() or return; my $last_int = ip_bintoint($last_bin, $self->version()) or return; $self->{last_int} = $last_int; return ($last_int); } #------------------------------------------------------------------------------ # Subroutine last_ip # Purpose : Get the last IP of a prefix in IP format # Returns : IP or undef (failure) sub last_ip { my ($self) = shift; return ($self->{last_ip}) if defined($self->{last_ip}); my $last = ip_bintoip($self->last_bin(), $self->version()); if (!$last) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{last_ip} = $last; return ($last); } #------------------------------------------------------------------------------ # Subroutine find_prefixes # Purpose : Get all prefixes in the range defined by two IPs # Params : IP # Returns : List of prefixes or undef (failure) sub find_prefixes { my ($self) = @_; my @list = ip_range_to_prefix($self->binip(), $self->last_bin(), $self->version()); if (!scalar(@list)) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return (@list); } #------------------------------------------------------------------------------ # Subroutine bincomp # Purpose : Compare two IPs # Params : Operation, IP to compare # Returns : 1 (True), 0 (False) or undef (problem) # Comments : Operation can be lt, le, gt, ge sub bincomp { my ($self, $op, $other) = @_; my $a = ip_bincomp($self->binip(), $op, $other->binip()); unless (defined $a) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return ($a); } #------------------------------------------------------------------------------ # Subroutine binadd # Purpose : Add two IPs # Params : IP to add # Returns : New IP object or undef (failure) sub binadd { my ($self, $other) = @_; my $ip = ip_binadd($self->binip(), $other->binip()); if (!$ip) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } my $new = new Net::IP(ip_bintoip($ip, $self->version())) or return; return ($new); } #------------------------------------------------------------------------------ # Subroutine aggregate # Purpose : Aggregate (append) two IPs # Params : IP to add # Returns : New IP object or undef (failure) sub aggregate { my ($self, $other) = @_; my $r = ip_aggregate( $self->binip(), $self->last_bin(), $other->binip(), $other->last_bin(), $self->version() ); if (!$r) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return (new Net::IP($r)); } #------------------------------------------------------------------------------ # Subroutine overlaps # Purpose : Check if two prefixes overlap # Params : Prefix to compare # Returns : $NO_OVERLAP (no overlap) # $IP_PARTIAL_OVERLAP (overlap) # $IP_A_IN_B_OVERLAP (range1 is included in range2) # $IP_B_IN_A_OVERLAP (range2 is included in range1) # $IP_IDENTICAL (range1 == range2) # or undef (problem) sub overlaps { my ($self, $other) = @_; my $r = ip_is_overlap( $self->binip(), $self->last_bin(), $other->binip(), $other->last_bin() ); if (!defined($r)) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } return ($r); } #------------------------------------------------------------------------------ # Subroutine auth # Purpose : Return Authority information from IP::Authority # Params : IP object # Returns : Authority Source sub auth { my ($self) = shift; return ($self->{auth}) if defined($self->{auth}); my $auth = ip_auth($self->ip, $self->version); if (!$auth) { $self->{error} = $ERROR; $self->{errno} = $ERRNO; return; } $self->{auth} = $auth; return ($self->{auth}); } #------------------------------ PROCEDURAL INTERFACE -------------------------- #------------------------------------------------------------------------------ # Subroutine Error # Purpose : Return the ERROR string # Returns : string sub Error { return ($ERROR); } #------------------------------------------------------------------------------ # Subroutine Error # Purpose : Return the ERRNO value # Returns : number sub Errno { return ($ERRNO); } #------------------------------------------------------------------------------ # Subroutine ip_iplengths # Purpose : Get the length in bits of an IP from its version # Params : IP version # Returns : Number of bits sub ip_iplengths { my ($version) = @_; if ($version == 4) { return (32); } elsif ($version == 6) { return (128); } else { return; } } #------------------------------------------------------------------------------ # Subroutine ip_iptobin # Purpose : Transform an IP address into a bit string # Params : IP address, IP version # Returns : bit string on success, undef otherwise sub ip_iptobin { my ($ip, $ipversion) = @_; # v4 -> return 32-bit array if ($ipversion == 4) { return unpack('B32', pack('C4C4C4C4', split(/\./, $ip))); } # Strip ':' $ip =~ s/://g; # Check size unless (length($ip) == 32) { $ERROR = "Bad IP address $ip"; $ERRNO = 102; return; } # v6 -> return 128-bit array return unpack('B128', pack('H32', $ip)); } #------------------------------------------------------------------------------ # Subroutine ip_bintoip # Purpose : Transform a bit string into an IP address # Params : bit string, IP version # Returns : IP address on success, undef otherwise sub ip_bintoip { my ($binip, $ip_version) = @_; # Define normal size for address my $len = ip_iplengths($ip_version); if ($len < length($binip)) { $ERROR = "Invalid IP length for binary IP $binip\n"; $ERRNO = 189; return; } # Prepend 0s if address is less than normal size $binip = '0' x ($len - length($binip)) . $binip; # IPv4 if ($ip_version == 4) { return join '.', unpack('C4C4C4C4', pack('B32', $binip)); } # IPv6 return join(':', unpack('H4H4H4H4H4H4H4H4', pack('B128', $binip))); } #------------------------------------------------------------------------------ # Subroutine ip_bintoint # Purpose : Transform a bit string into an Integer # Params : bit string # Returns : BigInt sub ip_bintoint { my $binip = shift; # $n is the increment, $dec is the returned value my ($n, $dec) = (Math::BigInt->new(1), Math::BigInt->new(0)); # Reverse the bit string foreach (reverse(split '', $binip)) { # If the nth bit is 1, add 2**n to $dec $_ and $dec += $n; $n *= 2; } # Strip leading + sign $dec =~ s/^\+//; return $dec; } #------------------------------------------------------------------------------ # Subroutine ip_inttobin # Purpose : Transform a BigInt into a bit string # Comments : sets warnings (-w) off. # This is necessary because Math::BigInt is not compliant # Params : BigInt, IP version # Returns : bit string sub ip_inttobin { my $dec = Math::BigInt->new(shift); # Find IP version my $ip_version = shift; unless ($ip_version) { $ERROR = "Cannot determine IP version for $dec"; $ERRNO = 101; return; } my $binip = $dec->as_bin(); $binip =~ s/^0b//; # Define normal size for address my $len = ip_iplengths($ip_version); # Prepend 0s if result is less than normal size $binip = '0' x ($len - length($binip)) . $binip; return $binip; } #------------------------------------------------------------------------------ # Subroutine ip_get_version # Purpose : Get an IP version # Params : IP address # Returns : 4, 6, 0(don't know) sub ip_get_version { my $ip = shift; # If the address does not contain any ':', maybe it's IPv4 $ip !~ /:/ and ip_is_ipv4($ip) and return '4'; # Is it IPv6 ? ip_is_ipv6($ip) and return '6'; return; } #------------------------------------------------------------------------------ # Subroutine ip_is_ipv4 # Purpose : Check if an IP address is version 4 # Params : IP address # Returns : 1 (yes) or 0 (no) sub ip_is_ipv4 { my $ip = shift; # Check for invalid chars unless ($ip =~ m/^[\d\.]+$/) { $ERROR = "Invalid chars in IP $ip"; $ERRNO = 107; return 0; } if ($ip =~ m/^\./) { $ERROR = "Invalid IP $ip - starts with a dot"; $ERRNO = 103; return 0; } if ($ip =~ m/\.$/) { $ERROR = "Invalid IP $ip - ends with a dot"; $ERRNO = 104; return 0; } # Single Numbers are considered to be IPv4 if ($ip =~ m/^(\d+)$/ and $1 < 256) { return 1 } # Count quads my $n = ($ip =~ tr/\./\./); # IPv4 must have from 1 to 4 quads unless ($n >= 0 and $n < 4) { $ERROR = "Invalid IP address $ip"; $ERRNO = 105; return 0; } # Check for empty quads if ($ip =~ m/\.\./) { $ERROR = "Empty quad in IP address $ip"; $ERRNO = 106; return 0; } foreach (split /\./, $ip) { # Check for invalid quads unless ($_ >= 0 and $_ < 256) { $ERROR = "Invalid quad in IP address $ip - $_"; $ERRNO = 107; return 0; } } return 1; } #------------------------------------------------------------------------------ # Subroutine ip_is_ipv6 # Purpose : Check if an IP address is version 6 # Params : IP address # Returns : 1 (yes) or 0 (no) sub ip_is_ipv6 { my $ip = shift; # Count octets my $n = ($ip =~ tr/:/:/); return 0 unless ($n > 0 and $n < 8); # $k is a counter my $k; foreach (split /:/, $ip) { $k++; # Empty octet ? next if ($_ eq ''); # Normal v6 octet ? next if (/^[a-f\d]{1,4}$/i); # Last octet - is it IPv4 ? if ( ($k == $n + 1) && ip_is_ipv4($_) ) { $n++; # ipv4 is two octets next; } $ERROR = "Invalid IP address $ip"; $ERRNO = 108; return 0; } # Does the IP address start with : ? if ($ip =~ m/^:[^:]/) { $ERROR = "Invalid address $ip (starts with :)"; $ERRNO = 109; return 0; } # Does the IP address finish with : ? if ($ip =~ m/[^:]:$/) { $ERROR = "Invalid address $ip (ends with :)"; $ERRNO = 110; return 0; } # Does the IP address have more than one '::' pattern ? if ($ip =~ s/:(?=:)/:/g > 1) { $ERROR = "Invalid address $ip (More than one :: pattern)"; $ERRNO = 111; return 0; } # number of octets if ($n != 7 && $ip !~ /::/) { $ERROR = "Invalid number of octets $ip"; $ERRNO = 112; return 0; } # valid IPv6 address return 1; } #------------------------------------------------------------------------------ # Subroutine ip_expand_address # Purpose : Expand an address from compact notation # Params : IP address, IP version # Returns : expanded IP address or undef on failure sub ip_expand_address { my ($ip, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; return; } # v4 : add .0 for missing quads if ($ip_version == 4) { my @quads = split /\./, $ip; # check number of quads if (scalar(@quads) > 4) { $ERROR = "Not a valid IPv address $ip"; $ERRNO = 102; return; } my @clean_quads = (0, 0, 0, 0); foreach my $q (reverse @quads) { #check quad data if ($q !~ m/^\d{1,3}$/) { $ERROR = "Not a valid IPv4 address $ip"; $ERRNO = 102; return; } # build clean ipv4 unshift(@clean_quads, $q + 1 - 1); } return (join '.', @clean_quads[ 0 .. 3 ]); } # Keep track of :: my $num_of_double_colon = ($ip =~ s/::/:!:/g); if ($num_of_double_colon > 1) { $ERROR = "Too many :: in ip"; $ERRNO = 102; return; } # IP as an array my @ip = split /:/, $ip; # Number of octets my $num = scalar(@ip); foreach (0 .. (scalar(@ip) - 1)) { # Embedded IPv4 if ($ip[$_] =~ /\./) { # Expand Ipv4 address # Convert into binary # Convert into hex # Keep the last two octets $ip[$_] = substr( ip_bintoip( ip_iptobin( ip_expand_address($ip[$_], 4), 4), 6), -9); # Has an error occured here ? return unless (defined($ip[$_])); # $num++ because we now have one more octet: # IPv4 address becomes two octets $num++; next; } # Add missing trailing 0s $ip[$_] = ('0' x (4 - length($ip[$_]))) . $ip[$_]; } # Now deal with '::' ('000!') foreach (0 .. (scalar(@ip) - 1)) { # Find the pattern next unless ($ip[$_] eq '000!'); # @empty is the IP address 0 my @empty = map { $_ = '0' x 4 } (0 .. 7); # Replace :: with $num '0000' octets $ip[$_] = join ':', @empty[ 0 .. 8 - $num ]; last; } return (lc(join ':', @ip)); } #------------------------------------------------------------------------------ # Subroutine ip_get_mask # Purpose : Get IP mask from prefix length. # Params : Prefix length, IP version # Returns : Binary Mask sub ip_get_mask { my ($len, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } my $size = ip_iplengths($ip_version); # mask is $len 1s plus the rest as 0s return (('1' x $len) . ('0' x ($size - $len))); } #------------------------------------------------------------------------------ # Subroutine ip_last_address_bin # Purpose : Return the last binary address of a range # Params : First binary IP, prefix length, IP version # Returns : Binary IP sub ip_last_address_bin { my ($binip, $len, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } my $size = ip_iplengths($ip_version); # Find the part of the IP address which will not be modified $binip = substr($binip, 0, $len); # Fill with 1s the variable part return ($binip . ('1' x ($size - length($binip)))); } #------------------------------------------------------------------------------ # Subroutine ip_splitprefix # Purpose : Split a prefix into IP and prefix length # Comments : If it was passed a simple IP, it just returns it # Params : Prefix # Returns : IP, optionnaly length of prefix sub ip_splitprefix { my $prefix = shift; # Find the '/' return unless ($prefix =~ m!^([^/]+?)(/\d+)?$!); my ($ip, $len) = ($1, $2); defined($len) and $len =~ s!/!!; return ($ip, $len); } #------------------------------------------------------------------------------ # Subroutine ip_prefix_to_range # Purpose : Get a range from a prefix # Params : IP, Prefix length, IP version # Returns : First IP, last IP sub ip_prefix_to_range { my ($ip, $len, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } # Expand the first IP address $ip = ip_expand_address($ip, $ip_version); # Turn into a binary # Get last address # Turn into an IP my $binip = ip_iptobin($ip, $ip_version) or return; return unless (ip_check_prefix($binip, $len, $ip_version)); my $lastip = ip_last_address_bin($binip, $len, $ip_version) or return; return unless ($lastip = ip_bintoip($lastip, $ip_version)); return ($ip, $lastip); } #------------------------------------------------------------------------------ # Subroutine ip_is_valid_mask # Purpose : Check the validity of an IP mask (11110000) # Params : Mask # Returns : 1 or undef (invalid) sub ip_is_valid_mask { my ($mask, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $mask"; $ERRNO = 101; return; } my $len = ip_iplengths($ip_version); if (length($mask) != $len) { $ERROR = "Invalid mask length for $mask"; $ERRNO = 150; return; } # The mask should be of the form 111110000000 unless ($mask =~ m/^1*0*$/) { $ERROR = "Invalid mask $mask"; $ERRNO = 151; return; } return 1; } #------------------------------------------------------------------------------ # Subroutine ip_bincomp # Purpose : Compare binary Ips with <, >, <=, >= # Comments : Operators are lt(<), le(<=), gt(>), and ge(>=) # Params : First binary IP, operator, Last binary Ip # Returns : 1 (yes), 0 (no), or undef (problem) sub ip_bincomp { my ($begin, $op, $end) = @_; my ($b, $e); if ($op =~ /^l[te]$/) # Operator is lt or le { ($b, $e) = ($end, $begin); } elsif ($op =~ /^g[te]$/) # Operator is gt or ge { ($b, $e) = ($begin, $end); } else { $ERROR = "Invalid Operator $op\n"; $ERRNO = 131; return; } # le or ge -> return 1 if IPs are identical return (1) if ($op =~ /e/ and ($begin eq $end)); # Check IP sizes unless (length($b) eq length($e)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } my $c; # Foreach bit for (0 .. length($b) - 1) { # substract the two bits $c = substr($b, $_, 1) - substr($e, $_, 1); # Check the result return (1) if ($c == 1); return (0) if ($c == -1); } # IPs are identical return 0; } #------------------------------------------------------------------------------ # Subroutine ip_binadd # Purpose : Add two binary IPs # Params : First binary IP, Last binary Ip # Returns : Binary sum or undef (problem) sub ip_binadd { my ($b, $e) = @_; # Check IP length unless (length($b) eq length($e)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } # Reverse the two IPs $b = scalar(reverse $b); $e = scalar(reverse $e); my ($carry, $result, $c) = (0); # Foreach bit (reversed) for (0 .. length($b) - 1) { # add the two bits plus the carry $c = substr($b, $_, 1) + substr($e, $_, 1) + $carry; $carry = 0; # sum = 0 => $c = 0, $carry = 0 # sum = 1 => $c = 1, $carry = 0 # sum = 2 => $c = 0, $carry = 1 # sum = 3 => $c = 1, $carry = 1 if ($c > 1) { $c -= 2; $carry = 1; } $result .= $c; } # Reverse result return scalar(reverse($result)); } #------------------------------------------------------------------------------ # Subroutine ip_get_prefix_length # Purpose : Get the prefix length for a given range of IPs # Params : First binary IP, Last binary IP # Returns : Length of prefix or undef (problem) sub ip_get_prefix_length { my ($bin1, $bin2) = @_; # Check length of IPs unless (length($bin1) eq length($bin2)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } # reverse IPs $bin1 = scalar(reverse $bin1); $bin2 = scalar(reverse $bin2); # foreach bit for (0 .. length($bin1) - 1) { # If bits are equal it means we have reached the longest prefix return ("$_") if (substr($bin1, $_, 1) eq substr($bin2, $_, 1)); } # Return 32 (IPv4) or 128 (IPv6) return length($bin1); } #------------------------------------------------------------------------------ # Subroutine ip_range_to_prefix # Purpose : Return all prefixes between two IPs # Params : First IP, Last IP, IP version # Returns : List of Prefixes or undef (problem) sub ip_range_to_prefix { my ($binip, $endbinip, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version"; $ERRNO = 101; return; } unless (length($binip) eq length($endbinip)) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } my ($len, $nbits, $current, $add, @prefix); # 1 in binary my $one = ('0' x (ip_iplengths($ip_version) - 1)) . '1'; # While we have not reached the last IP while (ip_bincomp($binip, 'le', $endbinip) == 1) { # Find all 0s at the end if ($binip =~ m/(0+)$/) { # nbits = nb of 0 bits $nbits = length($1); } else { $nbits = 0; } do { $current = $binip; $add = '1' x $nbits; # Replace $nbits 0s with 1s $current =~ s/0{$nbits}$/$add/; $nbits--; # Decrease $nbits if $current >= $endbinip } while (ip_bincomp($current, 'le', $endbinip) != 1); # Find Prefix length $len = (ip_iplengths($ip_version)) - ip_get_prefix_length($binip, $current); # Push prefix in list push(@prefix, ip_bintoip($binip, $ip_version) . "/$len"); # Add 1 to current IP $binip = ip_binadd($current, $one); # Exit if IP is 32/128 1s last if ($current =~ m/^1+$/); } return (@prefix); } #------------------------------------------------------------------------------ # Subroutine ip_compress_v4_prefix # Purpose : Compress an IPv4 Prefix # Params : IP, Prefix length # Returns : Compressed IP - ie: 194.5 sub ip_compress_v4_prefix { my ($ip, $len) = @_; my @quads = split /\./, $ip; my $qlen = int(($len - 1) / 8); $qlen = 0 if ($qlen < 0); my $newip = join '.', @quads[ 0 .. $qlen ]; return ($newip); } #------------------------------------------------------------------------------ # Subroutine ip_compress_address # Purpose : Compress an IPv6 address # Params : IP, IP version # Returns : Compressed IP or undef (problem) sub ip_compress_address { my ($ip, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; return; } # Just return if IP is IPv4 return ($ip) if ($ip_version == 4); # already compressed addresses must be expanded first $ip = ip_expand_address( $ip, $ip_version); # Remove leading 0s: 0034 -> 34; 0000 -> 0 $ip =~ s/ (^|:) # Find beginning or ':' -> $1 0+ # 1 or several 0s (?= # Look-ahead [a-fA-F\d]+ # One or several Hexs (?::|$)) # ':' or end /$1/gx; my $reg = ''; # Find the longuest :0:0: sequence while ( $ip =~ m/ ((?:^|:) # Find beginning or ':' -> $1 0(?::0)+ # 0 followed by 1 or several ':0' (?::|$)) # ':' or end /gx ) { $reg = $1 if (length($reg) < length($1)); } # Replace sequence by '::' $ip =~ s/$reg/::/ if ($reg ne ''); return $ip; } #------------------------------------------------------------------------------ # Subroutine ip_is_overlap # Purpose : Check if two ranges overlap # Params : Four binary IPs (begin of range 1,end1,begin2,end2) # Returns : $NO_OVERLAP (no overlap) # $IP_PARTIAL_OVERLAP (overlap) # $IP_A_IN_B_OVERLAP (range1 is included in range2) # $IP_B_IN_A_OVERLAP (range2 is included in range1) # $IP_IDENTICAL (range1 == range2) # or undef (problem) sub ip_is_overlap { my ($b1, $e1, $b2, $e2) = (@_); my $swap; $swap = 0; unless ((length($b1) eq length($e1)) and (length($b2) eq length($e2)) and (length($b1) eq length($b2))) { $ERROR = "IP addresses of different length\n"; $ERRNO = 130; return; } # begin1 <= end1 ? unless (ip_bincomp($b1, 'le', $e1) == 1) { $ERROR = "Invalid range $b1 - $e1"; $ERRNO = 140; return; } # begin2 <= end2 ? unless (ip_bincomp($b2, 'le', $e2) == 1) { $ERROR = "Invalid range $b2 - $e2"; $ERRNO = 140; return; } # b1 == b2 ? if ($b1 eq $b2) { # e1 == e2 return ($IP_IDENTICAL) if ($e1 eq $e2); # e1 < e2 ? return ( ip_bincomp($e1, 'lt', $e2) ? $IP_A_IN_B_OVERLAP : $IP_B_IN_A_OVERLAP ); } # e1 == e2 ? if ($e1 eq $e2) { # b1 < b2 return ( ip_bincomp($b1, 'lt', $b2) ? $IP_B_IN_A_OVERLAP : $IP_A_IN_B_OVERLAP ); } # b1 < b2 if ((ip_bincomp($b1, 'lt', $b2) == 1)) { # e1 < b2 return ($IP_NO_OVERLAP) if (ip_bincomp($e1, 'lt', $b2) == 1); # e1 < e2 ? return ( ip_bincomp($e1, 'lt', $e2) ? $IP_PARTIAL_OVERLAP : $IP_B_IN_A_OVERLAP ); } else # b1 > b2 { # e2 < b1 return ($IP_NO_OVERLAP) if (ip_bincomp($e2, 'lt', $b1) == 1); # e2 < e1 ? return ( ip_bincomp($e2, 'lt', $e1) ? $IP_PARTIAL_OVERLAP : $IP_A_IN_B_OVERLAP ); } } #------------------------------------------------------------------------------ # Subroutine get_embedded_ipv4 # Purpose : Get an IPv4 embedded in an IPv6 address # Params : IPv6 # Returns : IPv4 or undef (not found) sub ip_get_embedded_ipv4 { my $ipv6 = shift; my @ip = split /:/, $ipv6; # Bugfix by Norbert Koch return unless (@ip); # last octet should be ipv4 return ($ip[-1]) if (ip_is_ipv4($ip[-1])); return; } #------------------------------------------------------------------------------ # Subroutine aggregate # Purpose : Aggregate 2 ranges # Params : 1st range (1st IP, Last IP), last range (1st IP, last IP), # IP version # Returns : prefix or undef (invalid) sub ip_aggregate { my ($binbip1, $bineip1, $binbip2, $bineip2, $ip_version) = @_; unless ($ip_version) { $ERROR = "Cannot determine IP version for $binbip1"; $ERRNO = 101; return; } # Bin 1 my $one = (('0' x (ip_iplengths($ip_version) - 1)) . '1'); # $eip1 + 1 = $bip2 ? unless (ip_binadd($bineip1, $one) eq $binbip2) { $ERROR = "Ranges not contiguous - $bineip1 - $binbip2"; $ERRNO = 160; return; } # Get ranges my @prefix = ip_range_to_prefix($binbip1, $bineip2, $ip_version); # There should be only one range return if scalar(@prefix) < 1; if (scalar(@prefix) > 1) { $ERROR = "$binbip1 - $bineip2 is not a single prefix"; $ERRNO = 161; return; } return ($prefix[0]); } #------------------------------------------------------------------------------ # Subroutine ip_iptype # Purpose : Return the type of an IP (Public, Private, Reserved) # Params : IP to test, IP version # Returns : type or undef (invalid) sub ip_iptype { my ($ip, $ip_version) = @_; # handle known ip versions return ip_iptypev4($ip) if $ip_version == 4; return ip_iptypev6($ip) if $ip_version == 6; # unsupported ip version $ERROR = "IP version $ip not supported"; $ERRNO = 180; return; } #------------------------------------------------------------------------------ # Subroutine ip_iptypev4 # Purpose : Return the type of an IP (Public, Private, Reserved) # Params : IP to test, IP version # Returns : type or undef (invalid) sub ip_iptypev4 { my ($ip) = @_; # check ip if ($ip !~ m/^[01]{1,32}$/) { $ERROR = "$ip is not a binary IPv4 address $ip"; $ERRNO = 180; return; } # see if IP is listed foreach (sort { length($b) <=> length($a) } keys %IPv4ranges) { return ($IPv4ranges{$_}) if ($ip =~ m/^$_/); } # not listed means IP is public return 'PUBLIC'; } #------------------------------------------------------------------------------ # Subroutine ip_iptypev6 # Purpose : Return the type of an IP (Public, Private, Reserved) # Params : IP to test, IP version # Returns : type or undef (invalid) sub ip_iptypev6 { my ($ip) = @_; # check ip if ($ip !~ m/^[01]{1,128}$/) { $ERROR = "$ip is not a binary IPv6 address"; $ERRNO = 180; return; } foreach (sort { length($b) <=> length($a) } keys %IPv6ranges) { return ($IPv6ranges{$_}) if ($ip =~ m/^$_/); } # How did we get here? All IPv6 addresses should match $ERROR = "Cannot determine type for $ip"; $ERRNO = 180; return; } #------------------------------------------------------------------------------ # Subroutine ip_check_prefix # Purpose : Check the validity of a prefix # Params : binary IP, length of prefix, IP version # Returns : 1 or undef (invalid) sub ip_check_prefix { my ($binip, $len, $ipversion) = (@_); # Check if len is longer than IP if ($len > length($binip)) { $ERROR = "Prefix length $len is longer than IP address (" . length($binip) . ")"; $ERRNO = 170; return; } my $rest = substr($binip, $len); # Check if last part of the IP (len part) has only 0s unless ($rest =~ /^0*$/) { $ERROR = "Invalid prefix $binip/$len"; $ERRNO = 171; return; } # Check if prefix length is correct unless (length($rest) + $len == ip_iplengths($ipversion)) { $ERROR = "Invalid prefix length /$len"; $ERRNO = 172; return; } return 1; } #------------------------------------------------------------------------------ # Subroutine ip_reverse # Purpose : Get a reverse name from a prefix # Comments : From Lee's iplib.pm # Params : IP, length of prefix, IP version # Returns : Reverse name or undef (error) sub ip_reverse { my ($ip, $len, $ip_version) = (@_); $ip_version ||= ip_get_version($ip); unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; return; } if ($ip_version == 4) { my @quads = split /\./, $ip; my $no_quads = ($len / 8); my @reverse_quads = reverse @quads; while (@reverse_quads and $reverse_quads[0] == 0) { shift(@reverse_quads); } return join '.', @reverse_quads, 'in-addr', 'arpa.'; } elsif ($ip_version == 6) { my @rev_groups = reverse split /:/, ip_expand_address($ip, 6); my @result; foreach (@rev_groups) { my @revhex = reverse split //; push @result, @revhex; } # This takes the zone above if it's not exactly on a nibble my $first_nibble_index = $len ? 32 - (int($len / 4)) : 0; return join '.', @result[ $first_nibble_index .. $#result ], 'ip6', 'arpa.'; } } #------------------------------------------------------------------------------ # Subroutine ip_normalize # Purpose : Normalize data to a range of IP addresses # Params : IP or prefix or range # Returns : ip1, ip2 (if range) or undef (error) sub ip_normalize { my ($data) = shift; my $ipversion; my ($len, $ip, $ip2, $real_len, $first, $last, $curr_bin, $addcst, $clen); # Prefix if ($data =~ m!^(\S+?)(/\S+)$!) { ($ip, $len) = ($1, $2); return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); return unless ($curr_bin = ip_iptobin($ip, $ipversion)); my $one = '0' x (ip_iplengths($ipversion) - 1) . '1'; while ($len) { last unless ($len =~ s!^/(\d+)(\,|$)!!); $clen = $1; $addcst = length($2) > 0; return unless (ip_check_prefix($curr_bin, $clen, $ipversion)); return unless ($curr_bin = ip_last_address_bin($curr_bin, $clen, $ipversion)); if ($addcst) { return unless ($curr_bin = ip_binadd($curr_bin, $one)); } } return ($ip, ip_bintoip($curr_bin, $ipversion)); } # Range elsif ($data =~ /^(.+?)\s*\-\s*(.+)$/) { ($ip, $ip2) = ($1, $2); return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); return unless ($ip2 = ip_expand_address($ip2, $ipversion)); return ($ip, $ip2); } # IP + Number elsif ($data =~ /^(.+?)\s+\+\s+(.+)$/) { ($ip, $len) = ($1, $2); return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); my ($bin_ip); return unless ($bin_ip = ip_iptobin($ip, $ipversion)); return unless ($len = ip_inttobin($len, $ipversion)); return unless ($ip2 = ip_binadd($bin_ip, $len)); return unless ($ip2 = ip_bintoip($ip2, $ipversion)); return ($ip, $ip2); } # Single IP else { $ip = $data; return unless ($ipversion = ip_get_version($ip)); return unless ($ip = ip_expand_address($ip, $ipversion)); return $ip; } } #------------------------------------------------------------------------------ # Subroutine normal_range # Purpose : Return the normalized format of a range # Params : IP or prefix or range # Returns : "ip1 - ip2" or undef (error) sub ip_normal_range { my ($data) = shift; my ($ip1, $ip2) = ip_normalize($data); return unless ($ip1); $ip2 ||= $ip1; return ("$ip1 - $ip2"); } #------------------------------------------------------------------------------ # Subroutine ip_auth # Purpose : Get Authority information from IP::Authority Module # Comments : Requires IP::Authority # Params : IP, length of prefix # Returns : Reverse name or undef (error) sub ip_auth { my ($ip, $ip_version) = (@_); unless ($ip_version) { $ERROR = "Cannot determine IP version for $ip"; $ERRNO = 101; die; return; } if ($ip_version != 4) { $ERROR = "Cannot get auth information: Not an IPv4 address"; $ERRNO = 308; die; return; } require IP::Authority; my $reg = new IP::Authority; return ($reg->inet_atoauth($ip)); } 1; __END__ =encoding utf8 =head1 NAME Net::IP - Perl extension for manipulating IPv4/IPv6 addresses =head1 SYNOPSIS use Net::IP; my $ip = new Net::IP ('193.0.1/24') or die (Net::IP::Error()); print ("IP : ".$ip->ip()."\n"); print ("Sho : ".$ip->short()."\n"); print ("Bin : ".$ip->binip()."\n"); print ("Int : ".$ip->intip()."\n"); print ("Mask: ".$ip->mask()."\n"); print ("Last: ".$ip->last_ip()."\n"); print ("Len : ".$ip->prefixlen()."\n"); print ("Size: ".$ip->size()."\n"); print ("Type: ".$ip->iptype()."\n"); print ("Rev: ".$ip->reverse_ip()."\n"); =head1 DESCRIPTION This module provides functions to deal with B addresses. The module can be used as a class, allowing the user to instantiate IP objects, which can be single IP addresses, prefixes, or ranges of addresses. There is also a procedural way of accessing most of the functions. Most subroutines can take either B or B addresses transparently. =head1 OBJECT-ORIENTED INTERFACE =head2 Object Creation A Net::IP object can be created from a single IP address: $ip = new Net::IP ('193.0.1.46') || die ... Or from a Classless Prefix (a /24 prefix is equivalent to a C class): $ip = new Net::IP ('195.114.80/24') || die ... Or from a range of addresses: $ip = new Net::IP ('20.34.101.207 - 201.3.9.99') || die ... Or from a address plus a number: $ip = new Net::IP ('20.34.10.0 + 255') || die ... The new() function accepts IPv4 and IPv6 addresses: $ip = new Net::IP ('dead:beef::/32') || die ... Optionnaly, the function can be passed the version of the IP. Otherwise, it tries to guess what the version is (see B<_is_ipv4()> and B<_is_ipv6()>). $ip = new Net::IP ('195/8',4); # Class A =head1 OBJECT METHODS Most of these methods are front-ends for the real functions, which use a procedural interface. Most functions return undef on failure, and a true value on success. A detailed description of the procedural interface is provided below. =head2 set Set an IP address in an existing IP object. This method has the same functionality as the new() method, except that it reuses an existing object to store the new IP. C<$ip-Eset('130.23.1/24',4);> Like new(), set() takes two arguments - a string used to build an IP address, prefix, or range, and optionally, the IP version of the considered address. It returns an IP object on success, and undef on failure. =head2 error Return the current object error string. The error string is set whenever one of the methods produces an error. Also, a global, class-wide B function is avaliable. Cerror());> =head2 errno Return the current object error number. The error number is set whenever one of the methods produces an error. Also, a global B<$ERRNO> variable is set when an error is produced. Cerrno());> =head2 ip Return the IP address (or first IP of the prefix or range) in quad format, as a string. Cip());> =head2 binip Return the IP address as a binary string of 0s and 1s. Cbinip());> =head2 prefixlen Return the length in bits of the current prefix. Cprefixlen());> =head2 version Return the version of the current IP object (4 or 6). Cversion());> =head2 size Return the number of IP addresses in the current prefix or range. Use of this function requires Math::BigInt. Csize());> =head2 binmask Return the binary mask of the current prefix, if applicable. Cbinmask());> =head2 mask Return the mask in quad format of the current prefix. Cmask());> =head2 prefix Return the full prefix (ip+prefix length) in quad (standard) format. Cprefix());> =head2 print Print the IP object (IP/Prefix or First - Last) Cprint());> =head2 intip Convert the IP in integer format and return it as a Math::BigInt object. Cintip());> =head2 hexip Return the IP in hex format Chexip());> =head2 hexmask Return the mask in hex format Chexmask());> =head2 short Return the IP in short format: IPv4 addresses: 194.5/16 IPv6 addresses: ab32:f000:: Cshort());> =head2 iptype Return the IP Type - this describes the type of an IP (Public, Private, Reserved, etc.) See procedural interface ip_iptype for more details. Ciptype());> =head2 reverse_ip Return the reverse IP for a given IP address (in.addr. format). Creserve_ip());> =head2 last_ip Return the last IP of a prefix/range in quad format. Clast_ip());> =head2 last_bin Return the last IP of a prefix/range in binary format. Clast_bin());> =head2 last_int Return the last IP of a prefix/range in integer format. Clast_int());> =head2 find_prefixes This function finds all the prefixes that can be found between the two addresses of a range. The function returns a list of prefixes. C<@list = $ip-Efind_prefixes($other_ip));> =head2 bincomp Binary comparaison of two IP objects. The function takes an operation and an IP object as arguments. It returns a boolean value. The operation can be one of: lt: less than (smaller than) le: smaller or equal to gt: greater than ge: greater or equal to Cbincomp('lt',$ip2) {...}> =head2 binadd Binary addition of two IP objects. The value returned is an IP object. Cbinadd($ip2);> =head2 aggregate Aggregate 2 IPs - Append one range/prefix of IPs to another. The last address of the first range must be the one immediately preceding the first address of the second range. A new IP object is returned. Caggregate($ip2);> =head2 overlaps Check if two IP ranges/prefixes overlap each other. The value returned by the function should be one of: $IP_PARTIAL_OVERLAP (ranges overlap) $IP_NO_OVERLAP (no overlap) $IP_A_IN_B_OVERLAP (range2 contains range1) $IP_B_IN_A_OVERLAP (range1 contains range2) $IP_IDENTICAL (ranges are identical) undef (problem) Coverlaps($ip2)==$IP_A_IN_B_OVERLAP) {...};> =head2 looping The C<+> operator is overloaded in order to allow looping though a whole range of IP addresses: my $ip = new Net::IP ('195.45.6.7 - 195.45.6.19') || die; # Loop do { print $ip->ip(), "\n"; } while (++$ip); The ++ operator returns undef when the last address of the range is reached. =head2 auth Return IP authority information from the IP::Authority module C<$auth = ip->auth ();> Note: IPv4 only =head1 PROCEDURAL INTERFACE These functions do the real work in the module. Like the OO methods, most of these return undef on failure. In order to access error codes and strings, instead of using $ip-Eerror() and $ip-Eerrno(), use the global functions C and C. The functions of the procedural interface are not exported by default. In order to import these functions, you need to modify the use statement for the module: C =head2 Error Returns the error string corresponding to the last error generated in the module. This is also useful for the OO interface, as if the new() function fails, we cannot call $ip-Eerror() and so we have to use Error(). warn Error(); =head2 Errno Returns a numeric error code corresponding to the error string returned by Error. =head2 ip_iptobin Transform an IP address into a bit string. Params : IP address, IP version Returns : binary IP string on success, undef otherwise C<$binip = ip_iptobin ($ip,6);> =head2 ip_bintoip Transform a bit string into an IP address Params : binary IP, IP version Returns : IP address on success, undef otherwise C<$ip = ip_bintoip ($binip,6);> =head2 ip_bintoint Transform a bit string into a BigInt. Params : binary IP Returns : BigInt C<$bigint = new Math::BigInt (ip_bintoint($binip));> =head2 ip_inttobin Transform a BigInt into a bit string. I: sets warnings (C<-w>) off. This is necessary because Math::BigInt is not compliant. Params : BigInt, IP version Returns : binary IP C<$binip = ip_inttobin ($bigint);> =head2 ip_get_version Try to guess the IP version of an IP address. Params : IP address Returns : 4, 6, undef(unable to determine) C<$version = ip_get_version ($ip)> =head2 ip_is_ipv4 Check if an IP address is of type 4. Params : IP address Returns : 1 (yes) or 0 (no) C =head2 ip_is_ipv6 Check if an IP address is of type 6. Params : IP address Returns : 1 (yes) or 0 (no) C =head2 ip_expand_address Expand an IP address from compact notation. Params : IP address, IP version Returns : expanded IP address or undef on failure C<$ip = ip_expand_address ($ip,4);> =head2 ip_get_mask Get IP mask from prefix length. Params : Prefix length, IP version Returns : Binary Mask C<$mask = ip_get_mask ($len,6);> =head2 ip_last_address_bin Return the last binary address of a prefix. Params : First binary IP, prefix length, IP version Returns : Binary IP C<$lastbin = ip_last_address_bin ($ip,$len,6);> =head2 ip_splitprefix Split a prefix into IP and prefix length. If it was passed a simple IP, it just returns it. Params : Prefix Returns : IP, optionnaly length of prefix C<($ip,$len) = ip_splitprefix ($prefix)> =head2 ip_prefix_to_range Get a range of IPs from a prefix. Params : Prefix, IP version Returns : First IP, last IP C<($ip1,$ip2) = ip_prefix_to_range ($prefix,6);> =head2 ip_bincomp Compare binary Ips with <, >, <=, >=. Operators are lt(<), le(<=), gt(>), and ge(>=) Params : First binary IP, operator, Last binary IP Returns : 1 (yes), 0 (no), or undef (problem) C =head2 ip_binadd Add two binary IPs. Params : First binary IP, Last binary IP Returns : Binary sum or undef (problem) C<$binip = ip_binadd ($bin1,$bin2);> =head2 ip_get_prefix_length Get the prefix length for a given range of 2 IPs. Params : First binary IP, Last binary IP Returns : Length of prefix or undef (problem) C<$len = ip_get_prefix_length ($ip1,$ip2);> =head2 ip_range_to_prefix Return all prefixes between two IPs. Params : First IP (binary format), Last IP (binary format), IP version Returns : List of Prefixes or undef (problem) The prefixes returned have the form q.q.q.q/nn. C<@prefix = ip_range_to_prefix ($ip1,$ip2,6);> =head2 ip_compress_v4_prefix Compress an IPv4 Prefix. Params : IP, Prefix length Returns : Compressed Prefix C<$ip = ip_compress_v4_prefix ($ip, $len);> =head2 ip_compress_address Compress an IPv6 address. Just returns the IP if it is an IPv4. Params : IP, IP version Returns : Compressed IP or undef (problem) C<$ip = ip_compress_adress ($ip, $version);> =head2 ip_is_overlap Check if two ranges of IPs overlap. Params : Four binary IPs (begin of range 1,end1,begin2,end2), IP version $IP_PARTIAL_OVERLAP (ranges overlap) $IP_NO_OVERLAP (no overlap) $IP_A_IN_B_OVERLAP (range2 contains range1) $IP_B_IN_A_OVERLAP (range1 contains range2) $IP_IDENTICAL (ranges are identical) undef (problem) C<(ip_is_overlap($rb1,$re1,$rb2,$re2,4) eq $IP_A_IN_B_OVERLAP) and do {};> =head2 ip_get_embedded_ipv4 Get an IPv4 embedded in an IPv6 address Params : IPv6 Returns : IPv4 string or undef (not found) C<$ip4 = ip_get_embedded($ip6);> =head2 ip_check_mask Check the validity of a binary IP mask Params : Mask Returns : 1 or undef (invalid) C Checks if mask has only 1s followed by 0s. =head2 ip_aggregate Aggregate 2 ranges of binary IPs Params : 1st range (1st IP, Last IP), last range (1st IP, last IP), IP version Returns : prefix or undef (invalid) C<$prefix = ip_aggregate ($bip1,$eip1,$bip2,$eip2) || die ...> =head2 ip_iptypev4 Return the type of an IPv4 address. Params: binary IP Returns: type as of the following table or undef (invalid ip) See RFC 5735 and RFC 6598 S
S<-------------------------------------------------------------------> S<0.0.0.0/8 "This" Network RFC 1122 PRIVATE> S<10.0.0.0/8 Private-Use Networks RFC 1918 PRIVATE> S<100.64.0.0/10 CGN Shared Address Space RFC 6598 SHARED> S<127.0.0.0/8 Loopback RFC 1122 LOOPBACK> S<169.254.0.0/16 Link Local RFC 3927 LINK-LOCAL> S<172.16.0.0/12 Private-Use Networks RFC 1918 PRIVATE> S<192.0.0.0/24 IETF Protocol Assignments RFC 5736 RESERVED> S<192.0.2.0/24 TEST-NET-1 RFC 5737 TEST-NET> S<192.88.99.0/24 6to4 Relay Anycast RFC 3068 6TO4-RELAY> S<192.168.0.0/16 Private-Use Networks RFC 1918 PRIVATE> S<198.18.0.0/15 Network Interconnect> S< Device Benchmark Testing RFC 2544 RESERVED> S<198.51.100.0/24 TEST-NET-2 RFC 5737 TEST-NET> S<203.0.113.0/24 TEST-NET-3 RFC 5737 TEST-NET> S<224.0.0.0/4 Multicast RFC 3171 MULTICAST> S<240.0.0.0/4 Reserved for Future Use RFC 1112 RESERVED> S<255.255.255.255/32 Limited Broadcast RFC 919 BROADCAST> S< RFC 922> =head2 ip_iptypev6 Return the type of an IPv6 address. Params: binary ip Returns: type as of the following table or undef (invalid) See L and L S S<-------------------------------------------------------------> S<0000::/8 Reserved by IETF [RFC4291] RESERVED> S<0100::/8 Reserved by IETF [RFC4291] RESERVED> S<0200::/7 Reserved by IETF [RFC4048] RESERVED> S<0400::/6 Reserved by IETF [RFC4291] RESERVED> S<0800::/5 Reserved by IETF [RFC4291] RESERVED> S<1000::/4 Reserved by IETF [RFC4291] RESERVED> S<2000::/3 Global Unicast [RFC4291] GLOBAL-UNICAST> S<4000::/3 Reserved by IETF [RFC4291] RESERVED> S<6000::/3 Reserved by IETF [RFC4291] RESERVED> S<8000::/3 Reserved by IETF [RFC4291] RESERVED> S S S S S S S S S S S S<---------------------------------------------------------------------> S<::1/128 Loopback Address [RFC4291] UNSPECIFIED> S<::/128 Unspecified Address [RFC4291] LOOPBACK> S<::FFFF:0:0/96 IPv4-mapped Address [RFC4291] IPV4MAP> S<0100::/64 Discard-Only Prefix [RFC6666] DISCARD> S<2001:0000::/32 TEREDO [RFC4380] TEREDO> S<2001:0002::/48 BMWG [RFC5180] BMWG> S<2001:db8::/32 Documentation Prefix [RFC3849] DOCUMENTATION> S<2001:10::/28 ORCHID [RFC4843] ORCHID> S<2002::/16 6to4 [RFC3056] 6TO4> S S S =head2 ip_iptype Return the type of an IP (Public, Private, Reserved) Params : Binary IP to test, IP version (defaults to 6) Returns : type (see ip_iptypev4 and ip_iptypev6 for details) or undef (invalid) C<$type = ip_iptype ($ip);> =head2 ip_check_prefix Check the validity of a prefix Params : binary IP, length of prefix, IP version Returns : 1 or undef (invalid) Checks if the variant part of a prefix only has 0s, and the length is correct. C =head2 ip_reverse Get a reverse name from a prefix Params : IP, length of prefix, IP version Returns : Reverse name or undef (error) C<$reverse = ip_reverse ($ip);> =head2 ip_normalize Normalize data to a range/prefix of IP addresses Params : Data String (Single IP, Range, Prefix) Returns : ip1, ip2 (if range/prefix) or undef (error) C<($ip1,$ip2) = ip_normalize ($data);> =head2 ip_auth Return IP authority information from the IP::Authority module Params : IP, version Returns : Auth info (RI for RIPE, AR for ARIN, etc) C<$auth = ip_auth ($ip,4);> Note: IPv4 only =head1 BUGS The Math::BigInt library is needed for functions that use integers. These are ip_inttobin, ip_bintoint, and the size method. In a next version, Math::BigInt will become optionnal. =head1 AUTHORS Manuel Valente . Original IPv4 code by Monica Cortes Sack . Original IPv6 code by Lee Wilmot . =head1 BASED ON ipv4pack.pm, iplib.pm, iplibncc.pm. =head1 SEE ALSO perl(1), IP::Authority =cut DNS/Update.pm000044400000016573152345050350006764 0ustar00package Net::DNS::Update; use strict; use warnings; our $VERSION = (qw$Id: Update.pm 2003 2025-01-21 12:06:06Z willem $)[2]; =head1 NAME Net::DNS::Update - DNS dynamic update packet =head1 SYNOPSIS use Net::DNS; $update = Net::DNS::Update->new( 'example.com', 'IN' ); $update->push( prereq => nxrrset('host.example.com. AAAA') ); $update->push( update => rr_add('host.example.com. 86400 AAAA 2001::DB8::F00') ); =head1 DESCRIPTION Net::DNS::Update is a subclass of Net::DNS::Packet, to be used for making DNS dynamic updates. Programmers should refer to RFC2136 for dynamic update semantics. =cut use integer; use Carp; use base qw(Net::DNS::Packet); use Net::DNS::Resolver; =head1 METHODS =head2 new $update = Net::DNS::Update->new; $update = Net::DNS::Update->new( 'example.com' ); $update = Net::DNS::Update->new( 'example.com', 'IN' ); Returns a Net::DNS::Update object suitable for performing a DNS dynamic update. Specifically, it creates a packet with the header opcode set to UPDATE and the zone record type to SOA (per RFC 2136, Section 2.3). Programs must use the push() method to add RRs to the prerequisite and update sections before performing the update. Arguments are the zone name and the class. The zone and class may be undefined or omitted and default to the default domain from the resolver configuration and IN respectively. =cut sub new { my ( $class, $zone, @rrclass ) = @_; my ($domain) = grep { defined && length } ( $zone, Net::DNS::Resolver->searchlist ); my $self = __PACKAGE__->SUPER::new( $domain, 'SOA', @rrclass ); my $header = $self->header; $header->opcode('UPDATE'); $header->qr(0); $header->rd(0); return $self; } =head2 push $ancount = $update->push( prereq => $rr ); $nscount = $update->push( update => $rr ); $arcount = $update->push( additional => $rr ); $nscount = $update->push( update => $rr1, $rr2, $rr3 ); $nscount = $update->push( update => @rr ); Adds RRs to the specified section of the update packet. Returns the number of resource records in the specified section. Section names may be abbreviated to the first three characters. =cut sub push { my ( $self, $section, @rr ) = @_; my ($zone) = $self->zone; my $zclass = $zone->zclass; for (@rr) { $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ) } return $self->SUPER::push( $section, @rr ); } =head2 unique_push $ancount = $update->unique_push( prereq => $rr ); $nscount = $update->unique_push( update => $rr ); $arcount = $update->unique_push( additional => $rr ); $nscount = $update->unique_push( update => $rr1, $rr2, $rr3 ); $nscount = $update->unique_push( update => @rr ); Adds RRs to the specified section of the update packet provided that the RRs are not already present in the same section. Returns the number of resource records in the specified section. Section names may be abbreviated to the first three characters. =cut sub unique_push { my ( $self, $section, @rr ) = @_; my ($zone) = $self->zone; my $zclass = $zone->zclass; for (@rr) { $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ) } return $self->SUPER::unique_push( $section, @rr ); } 1; __END__ =head1 EXAMPLES The first example below shows a complete program. Subsequent examples show only the creation of the update packet. Although the examples are presented using the string form of RRs, the corresponding ( name => value ) form may also be used. =head2 Add a new host #!/usr/bin/perl use Net::DNS; # Create the update packet. my $update = Net::DNS::Update->new('example.com'); # Prerequisite is that no address records exist for the name. $update->push( pre => nxrrset('host.example.com. A') ); $update->push( pre => nxrrset('host.example.com. AAAA') ); # Add two address records for the name. $update->push( update => rr_add('host.example.com. 86400 A 192.0.2.1') ); $update->push( update => rr_add('host.example.com. 86400 AAAA 2001:DB8::1') ); # Send the update to the zone's primary nameserver. my $resolver = Net::DNS::Resolver->new(); $resolver->nameservers('DNSprimary.example.com'); my $reply = $resolver->send($update); # Did it work? if ($reply) { print 'Update RCODE: ', $reply->header->rcode, "\n"; } else { print 'Update failed: ', $resolver->errorstring, "\n"; } =head2 Add an MX record for a name that already exists my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => yxdomain('example.com') ); $update->push( update => rr_add('example.com MX 10 mailhost.example.com') ); =head2 Add a TXT record for a name that does not exist my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => nxdomain('info.example.com') ); $update->push( update => rr_add('info.example.com TXT "yabba dabba doo"') ); =head2 Delete all A records for a name my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => yxrrset('host.example.com A') ); $update->push( update => rr_del('host.example.com A') ); =head2 Delete all RRs for a name my $update = Net::DNS::Update->new('example.com'); $update->push( prereq => yxdomain('byebye.example.com') ); $update->push( update => rr_del('byebye.example.com') ); =head2 Perform DNS update signed using a key generated by BIND tsig-keygen my $update = Net::DNS::Update->new('example.com'); $update->push( update => rr_add('host.example.com AAAA 2001:DB8::1') ); $update->sign_tsig( $key_file ); my $reply = $resolver->send( $update ); $reply->verify( $update ) || die $reply->verifyerr; =head2 Signing the DNS update using a customised TSIG record $update->sign_tsig( $key_file, fudge => 60 ); =head2 Signing the DNS update using private key generated by BIND dnssec-keygen $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.private" ); =head2 Signing the DNS update using public key generated by BIND dnssec-keygen $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.key" ); =head2 Another way to sign a DNS update use Net::DNS::RR::TSIG; my $tsig = create Net::DNS::RR::TSIG( $key_file ); $tsig->fudge(60); my $update = Net::DNS::Update->new('example.com'); $update->push( update => rr_add('host.example.com AAAA 2001:DB8::1') ); $update->push( additional => $tsig ); =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2015 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L =cut DNS/Domain.pm000044400000024010152345050350006732 0ustar00package Net::DNS::Domain; use strict; use warnings; our $VERSION = (qw$Id: Domain.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Domain - DNS domains =head1 SYNOPSIS use Net::DNS::Domain; $domain = Net::DNS::Domain->new('example.com'); $name = $domain->name; =head1 DESCRIPTION The Net::DNS::Domain module implements a class of abstract DNS domain objects with associated class and instance methods. Each domain object instance represents a single DNS domain which has a fixed identity throughout its lifetime. Internally, the primary representation is a (possibly empty) list of ASCII domain name labels, and optional link to an origin domain object topologically closer to the DNS root. The computational expense of Unicode character-set conversion is partially mitigated by use of caches. =cut use integer; use Carp; use constant ASCII => ref eval { require Encode; Encode::find_encoding('ascii'); }; use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6] Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; use constant LIBIDN2 => defined eval { require Net::LibIDN2 }; use constant IDN2FLAG => LIBIDN2 ? &Net::LibIDN2::IDN2_NFC_INPUT + &Net::LibIDN2::IDN2_NONTRANSITIONAL : 0; use constant LIBIDN => LIBIDN2 ? undef : defined eval { require Net::LibIDN }; # perlcc: address of encoding objects must be determined at runtime my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law: my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't. =head1 METHODS =head2 new $object = Net::DNS::Domain->new('example.com'); Creates a domain object which represents the DNS domain specified by the character string argument. The argument consists of a sequence of labels delimited by dots. A character preceded by \ represents itself, without any special interpretation. Arbitrary 8-bit codes can be represented by \ followed by exactly three decimal digits. Character code points are ASCII, irrespective of the character coding scheme employed by the underlying platform. Argument string literals should be delimited by single quotes to avoid escape sequences being interpreted as octal character codes by the Perl compiler. The character string presentation format follows the conventions for zone files described in RFC1035. Users should be aware that non-ASCII domain names will be transcoded to NFC before encoding, which is an irreversible process. =cut my ( %escape, %unescape ); ## precalculated ASCII escape tables our $ORIGIN; my ( $cache1, $cache2, $limit ) = ( {}, {}, 100 ); sub new { my ( $class, $s ) = @_; croak 'domain identifier undefined' unless defined $s; my $index = join '', $s, $class, $ORIGIN || ''; # cache key my $cache = $$cache1{$index} ||= $$cache2{$index}; # two layer cache return $cache if defined $cache; ( $cache1, $cache2, $limit ) = ( {}, $cache1, 500 ) unless $limit--; # recycle cache my $self = bless {}, $class; $s =~ s/\\\\/\\092/g; # disguise escaped escape $s =~ s/\\\./\\046/g; # disguise escaped dot my $label = $self->{label} = ( $s eq '@' ) ? [] : [split /\056/, _encode_utf8($s)]; foreach (@$label) { croak qq(empty label in "$s") unless length; if ( LIBIDN2 && UTF8 && /[^\000-\177]/ ) { my $rc = 0; $_ = Net::LibIDN2::idn2_to_ascii_8( $_, IDN2FLAG, $rc ); croak Net::LibIDN2::idn2_strerror($rc) unless $_; } if ( LIBIDN && UTF8 && /[^\000-\177]/ ) { $_ = Net::LibIDN::idn_to_ascii( $_, 'utf-8' ); croak 'name contains disallowed character' unless $_; } s/\134([\060-\071]{3})/$unescape{$1}/eg; # restore numeric escapes s/\134([^\134])/$1/g; # restore character escapes s/\134(\134)/$1/g; # restore escaped escapes croak qq(label too long in "$s") if length > 63; } $$cache1{$index} = $self; # cache object reference return $self if $s =~ /\.$/; # fully qualified name $self->{origin} = $ORIGIN || return $self; # dynamically scoped $ORIGIN return $self; } =head2 name $name = $domain->name; Returns the domain name as a character string corresponding to the "common interpretation" to which RFC1034, 3.1, paragraph 9 alludes. Character escape sequences are used to represent a dot inside a domain name label and the escape character itself. Any non-printable code point is represented using the appropriate numerical escape sequence. =cut sub name { my ($self) = @_; return $self->{name} if defined $self->{name}; return unless defined wantarray; my @label = shift->_wire; return $self->{name} = '.' unless scalar @label; for (@label) { s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; } return $self->{name} = _decode_ascii( join chr(46), @label ); } =head2 fqdn $fqdn = $domain->fqdn; Returns a character string containing the fully qualified domain name, including the trailing dot. =cut sub fqdn { my $name = &name; return $name =~ /[.]$/ ? $name : "$name."; # append trailing dot } =head2 xname $xname = $domain->xname; Interprets an extended name containing Unicode domain name labels encoded as Punycode A-labels. If decoding is not possible, the ACE encoded name is returned. =cut sub xname { my $name = &name; if ( LIBIDN2 && UTF8 && $name =~ /xn--/i ) { my $self = shift; return $self->{xname} if defined $self->{xname}; my $u8 = Net::LibIDN2::idn2_to_unicode_88($name); return $self->{xname} = $u8 ? $utf8->decode($u8) : $name; } if ( LIBIDN && UTF8 && $name =~ /xn--/i ) { my $self = shift; return $self->{xname} if defined $self->{xname}; return $self->{xname} = $utf8->decode( Net::LibIDN::idn_to_unicode $name, 'utf-8' ); } return $name; } =head2 label @label = $domain->label; Identifies the domain by means of a list of domain labels. =cut sub label { my @label = shift->_wire; for (@label) { s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; _decode_ascii($_); } return @label; } =head2 string $string = $object->string; Returns a character string containing the fully qualified domain name as it appears in a zone file. Characters which are recognised by RFC1035 zone file syntax are represented by the appropriate escape sequence. =cut sub string { return &fqdn } =head2 origin $create = Net::DNS::Domain->origin( $ORIGIN ); $result = &$create( sub{ Net::DNS::RR->new( 'mx MX 10 a' ); } ); $expect = Net::DNS::RR->new( "mx.$ORIGIN. MX 10 a.$ORIGIN." ); Class method which returns a reference to a subroutine wrapper which executes a given constructor in a dynamically scoped context where relative names become descendents of the specified $ORIGIN. =cut my $placebo = sub { my $constructor = shift; &$constructor; }; sub origin { my ( $class, $name ) = @_; my $domain = defined $name ? __PACKAGE__->new($name) : return $placebo; return sub { # closure w.r.t. $domain my $constructor = shift; local $ORIGIN = $domain; # dynamically scoped $ORIGIN &$constructor; } } ######################################## sub _decode_ascii { ## ASCII to perl internal encoding local $_ = shift; # partial transliteration for non-ASCII character encodings tr [\040-\176\000-\377] [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( $ascii->decode($_), $z ) : $_; } sub _encode_utf8 { ## perl internal encoding to UTF8 local $_ = shift; # partial transliteration for non-ASCII character encodings tr [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~\000-\377] [\040-\176\077] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; } sub _wire { my $self = shift; my $label = $self->{label}; my $origin = $self->{origin}; return ( @$label, $origin ? $origin->_wire : () ); } %escape = eval { ## precalculated ASCII escape table my %table = map { ( chr($_) => chr($_) ) } ( 0 .. 127 ); foreach my $n ( 0 .. 32, 34, 92, 127 .. 255 ) { # \ddd my $codepoint = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $codepoint =~ tr [0-9] [\060-\071]; $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint; } foreach my $n ( 40, 41, 46, 59 ) { # character escape $table{chr($n)} = pack( 'C2', 92, $n ); } return %table; }; %unescape = eval { ## precalculated numeric escape table my %table; foreach my $n ( 0 .. 255 ) { my $key = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $key =~ tr [0-9] [\060-\071]; $table{$key} = pack 'C', $n; } $table{"\060\071\062"} = pack 'C2', 92, 92; # escaped escape return %table; }; 1; __END__ ######################################## =head1 BUGS Coding strategy is intended to avoid creating unnecessary argument lists and stack frames. This improves efficiency at the expense of code readability. Platform specific character coding features are conditionally compiled into the code. =head1 COPYRIGHT Copyright (c)2009-2011,2017 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut DNS/Mailbox.pm000044400000007724152345050350007133 0ustar00package Net::DNS::Mailbox; use strict; use warnings; our $VERSION = (qw$Id: Mailbox.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Mailbox - DNS mailbox representation =head1 SYNOPSIS use Net::DNS::Mailbox; $mailbox = Net::DNS::Mailbox->new('user@example.com'); $address = $mailbox->address; =head1 DESCRIPTION The Net::DNS::Mailbox module implements a subclass of DNS domain name objects representing the DNS coded form of RFC822 mailbox address. The Net::DNS::Mailbox1035 and Net::DNS::Mailbox2535 packages implement mailbox representation subtypes which provide the name compression and canonicalisation specified by RFC1035 and RFC2535. These are necessary to meet the backward compatibility requirements introduced by RFC3597. =cut use integer; use Carp; use base qw(Net::DNS::DomainName); =head1 METHODS =head2 new $mailbox = Net::DNS::Mailbox->new('John Doe '); $mailbox = Net::DNS::Mailbox->new('john.doe@example.com'); $mailbox = Net::DNS::Mailbox->new('john\.doe.example.com'); Creates a mailbox object representing the RFC822 mail address specified by the character string argument. An encoded domain name is also accepted for backward compatibility with Net::DNS 0.68 and earlier. The argument string consists of printable characters from the 7-bit ASCII repertoire. =cut sub new { my $class = shift; local $_ = shift; croak 'undefined mail address' unless defined $_; s/^.*.*$//g; # strip excess on right s/^\@.+://; # strip deprecated source route s/\\\./\\046/g; # disguise escaped dots my ( $localpart, @domain ) = split /[@.]([^@;:"]*$)/; # split on rightmost @ s/\./\\046/g for $localpart ||= ''; # escape dots in local part return bless __PACKAGE__->SUPER::new( join '.', $localpart, @domain ), $class; } =head2 address $address = $mailbox->address; Returns a character string containing the RFC822 mailbox address corresponding to the encoded domain name representation described in RFC1035 section 8. =cut sub address { return unless defined wantarray; my @label = shift->label; local $_ = shift(@label) || return '<>'; s/\\\\//g; # delete escaped \ s/^\\034(.*)\\034$/"$1"/; # unescape enclosing quotes s/\\\d\d\d//g; # delete non-printable s/\\\./\./g; # unescape dots s/\\//g; # delete escapes return $_ unless scalar(@label); return join '@', $_, join '.', @label; } ######################################## package Net::DNS::Mailbox1035; ## no critic ProhibitMultiplePackages our @ISA = qw(Net::DNS::Mailbox); sub encode { return &Net::DNS::DomainName1035::encode; } package Net::DNS::Mailbox2535; ## no critic ProhibitMultiplePackages our @ISA = qw(Net::DNS::Mailbox); sub encode { return &Net::DNS::DomainName2535::encode; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)2009,2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/Nameserver.pm000044400000053653152345050350007651 0ustar00package Net::DNS::Nameserver; use strict; use warnings; our $VERSION = (qw$Id: Nameserver.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Nameserver - DNS server class =head1 SYNOPSIS use Net::DNS::Nameserver; my $nameserver = Net::DNS::Nameserver->new( LocalAddr => ['::1', '127.0.0.1'], LocalPort => 15353, ZoneFile => 'filename' ); my $nameserver = Net::DNS::Nameserver->new( LocalAddr => '10.1.2.3', LocalPort => 15353, ReplyHandler => \&reply_handler ); $nameserver->start_server($timeout); $nameserver->stop_server; =head1 DESCRIPTION Net::DNS::Nameserver offers a simple mechanism for instantiation of customised DNS server objects intended to provide test responses to queries emanating from a client resolver. It is not, nor will it ever be, a general-purpose DNS nameserver implementation. See L below for further details. =cut use integer; use Carp; use Net::DNS; use Net::DNS::ZoneFile; use IO::Select; use IO::Socket::IP; use IO::Socket; use Socket; use constant SOCKOPT => eval { my @sockopt; push @sockopt, eval '[SOL_SOCKET, SO_REUSEADDR]'; ## no critic push @sockopt, eval '[SOL_SOCKET, SO_REUSEPORT]'; ## no critic my $filter = sub { # check that options safe to use return eval { IO::Socket::IP->new( Proto => "udp", Sockopts => [shift], Type => SOCK_DGRAM ) } }; return grep { &$filter($_) } @sockopt; # without any guarantee that they work! }; use constant DEFAULT_ADDR => qw(::1 127.0.0.1); use constant DEFAULT_PORT => 15353; use constant POSIX => defined eval 'use POSIX ":sys_wait_h"; 1'; ## no critic use constant MSWin => scalar( $^O =~ /MSWin/i ); #------------------------------------------------------------------------------ # Constructor. #------------------------------------------------------------------------------ sub new { my ( $class, %config ) = @_; my %self = ( LocalAddr => [DEFAULT_ADDR], LocalPort => [DEFAULT_PORT], Truncate => 1, %config ); my $self = bless \%self, $class; $self->_ReadZoneFile( $self{ZoneFile} ) if exists $self{ZoneFile}; croak 'No reply handler!' unless ref( $self{ReplyHandler} ) eq "CODE"; # local server addresses need to be accepted by a resolver my $LocalAddr = $self{LocalAddr}; my $resolver = Net::DNS::Resolver->new( nameservers => $LocalAddr ); $resolver->force_v4( $self{Force_IPv4} ); $resolver->force_v6( $self{Force_IPv6} ); $self{LocalAddr} = [$resolver->nameservers]; return $self; } #------------------------------------------------------------------------------ # _ReadZoneFile - Read zone file used by default reply handler #------------------------------------------------------------------------------ sub _ReadZoneFile { my ( $self, $file ) = @_; my $zonefile = Net::DNS::ZoneFile->new($file); my $RRhash = $self->{index} = {}; my $RRlist = []; my @zonelist; while ( my $rr = $zonefile->read ) { push @{$RRhash->{lc $rr->owner}}, $rr; # Warning: Nasty trick abusing SOA to reference zone RR list if ( $rr->type eq 'SOA' ) { $RRlist = $rr->{RRlist} = []; push @zonelist, lc $rr->owner; } else { push @$RRlist, $rr; } } $self->{namelist} = [sort { length($b) <=> length($a) } keys %$RRhash]; $self->{zonelist} = [sort { length($b) <=> length($a) } @zonelist]; $self->{ReplyHandler} = sub { $self->_ReplyHandler(@_) }; return; } #------------------------------------------------------------------------------ # _ReplyHandler - Default reply handler serving RRs from zone file #------------------------------------------------------------------------------ sub _ReplyHandler { my ( $self, $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; my $RRhash = $self->{index}; my $rcode; my %headermask; my @ans; my @auth; if ( $qtype eq 'AXFR' ) { my $RRlist = $RRhash->{lc $qname} || []; my ($soa) = grep { $_->type eq 'SOA' } @$RRlist; if ($soa) { $rcode = 'NOERROR'; push @ans, $soa, @{$soa->{RRlist}}, $soa; } else { $rcode = 'NOTAUTH'; } return ( $rcode, \@ans, [], [], {}, {} ); } my @RRname = @{$self->{namelist}}; # pre-sorted, longest first { my $RRlist = $RRhash->{lc $qname} || []; # hash, then linear search my @match = @$RRlist; # assume $qclass always 'IN' if ( scalar(@match) ) { # exact match $rcode = 'NOERROR'; } elsif ( grep {/\.$qname$/i} @RRname ) { # empty non-terminal $rcode = 'NOERROR'; # [NODATA] } else { $rcode = 'NXDOMAIN'; foreach ( grep {/^[*][.]/} @RRname ) { my $wildcard = $_; # match wildcard per RFC4592 s/^\*//; # delete leading asterisk s/([.?*+])/\\$1/g; # escape dots and regex quantifiers next unless $qname =~ /[.]?([^.]+$_)$/i; my $cover = $1; # check for name covering wildcard next if grep {/[.]?$cover$/i} @RRname; my ($q) = $query->question; # synthesise RR at qname foreach my $rr ( @{$RRhash->{$wildcard}} ) { my $clone = bless( {%$rr}, ref($rr) ); $clone->{owner} = $q->{qname}; push @match, $clone; } $rcode = 'NOERROR'; last; } } push @ans, my @cname = grep { $_->type eq 'CNAME' } @match; $qname = $_->cname for @cname; redo if @cname; push @ans, @match if $qtype eq 'ANY'; # traditional, now out of favour push @ans, grep { $_->type eq $qtype } @match; unless (@ans) { foreach ( @{$self->{zonelist}} ) { my $RRlist = $RRhash->{lc $_}; s/([.?*+])/\\$1/g; # escape dots and regex quantifiers next unless $qname =~ /[^.]+[.]$_[.]?$/i; push @auth, grep { $_->type eq 'SOA' } @$RRlist; last; } } $headermask{aa} = 1; } return ( $rcode, \@ans, \@auth, [], \%headermask, {} ); } #------------------------------------------------------------------------------ # _make_reply - Make a reply packet. #------------------------------------------------------------------------------ sub _make_reply { my ( $self, $query, $sock ) = @_; my $verbose = $self->{Verbose}; unless ($query) { my $empty = Net::DNS::Packet->new(); # create empty reply packet my $reply = $empty->reply(); $reply->header->rcode("FORMERR"); return $reply; } if ( $query->header->qr() ) { print "ERROR: invalid packet (qr set), dropping\n" if $verbose; return; } my $reply = $query->reply(); my $header = $reply->header; my $headermask; my $optionmask; my $opcode = $query->header->opcode; my $qdcount = $query->header->qdcount; unless ($qdcount) { $header->rcode("NOERROR"); } elsif ( $qdcount > 1 ) { $header->rcode("FORMERR"); } else { my ($qr) = $query->question; my $qname = $qr->qname; my $qtype = $qr->qtype; my $qclass = $qr->qclass; print $qr->string, "\n" if $verbose; my $conn = { peerhost => my $peer = $sock->peerhost, peerport => $sock->peerport, protocol => $sock->protocol, sockhost => $sock->sockhost, sockport => $sock->sockport }; my ( $rcode, $ans, $auth, $add ); my @arglist = ( $qname, $qclass, $qtype, $peer, $query, $conn ); if ( $opcode eq "QUERY" ) { ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = &{$self->{ReplyHandler}}(@arglist); } elsif ( $opcode eq "NOTIFY" ) { #RFC1996 if ( ref $self->{NotifyHandler} eq "CODE" ) { ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = &{$self->{NotifyHandler}}(@arglist); } else { $rcode = "NOTIMP"; } } elsif ( $opcode eq "UPDATE" ) { #RFC2136 if ( ref $self->{UpdateHandler} eq "CODE" ) { ( $rcode, $ans, $auth, $add, $headermask, $optionmask ) = &{$self->{UpdateHandler}}(@arglist); } else { $rcode = "NOTIMP"; } } else { print "ERROR: opcode $opcode unsupported\n" if $verbose; $rcode = "FORMERR"; } if ( !defined($rcode) ) { print "remaining silent\n" if $verbose; return; } $header->rcode($rcode); push @{$reply->{answer}}, @$ans if $ans; push @{$reply->{authority}}, @$auth if $auth; push @{$reply->{additional}}, @$add if $add; } while ( my ( $key, $value ) = each %{$headermask || {}} ) { $header->$key($value); } while ( my ( $option, $value ) = each %{$optionmask || {}} ) { $reply->edns->option( $option, $value ); } $header->print if $verbose && ( $headermask || $optionmask ); return $reply; } #------------------------------------------------------------------------------ # _TCP_connection - Handle a TCP connection. #------------------------------------------------------------------------------ sub _TCP_connection { my ( $self, $socket, $buffer ) = @_; my $verbose = $self->{Verbose}; my $query = Net::DNS::Packet->new( \$buffer ); if ($@) { print "Error decoding query packet: $@\n" if $verbose; undef $query; ## force FORMERR reply } my $reply = $self->_make_reply( $query, $socket ); die 'Failed to create reply' unless defined $reply; my $segment = $reply->data; my $length = length $segment; if ($verbose) { print "TCP response (2 + $length octets) - "; print $socket->send( pack 'na*', $length, $segment ) ? "sent" : "failed: $!", "\n"; } else { $socket->send( pack 'na*', $length, $segment ); } return; } sub _read_tcp { my ( $socket, $verbose ) = @_; my $header = ''; local $! = 0; my $n = sysread( $socket, $header, 2 ); unless ( defined $n ) { redo if $!{EINTR}; ## retry if aborted by signal die "sysread: $!"; } return '' if $n == 0; return '' if length($header) < 2; my $msglen = unpack 'n', $header; my $buffer = ''; while ( $msglen > ( my $len = length $buffer ) ) { local $! = 0; my $n = sysread( $socket, $buffer, ( $msglen - $len ), $len ); unless ( defined $n ) { redo if $!{EINTR}; ## retry if aborted by signal die "sysread: $!"; } last if $n == 0; ## client closed (or lied) per RT#151240 } if ($verbose) { my $peer = $socket->peerhost; my $port = $socket->peerport; my $size = length $buffer; print "Received $size octets from [$peer] port $port\n"; } return $buffer; } #------------------------------------------------------------------------------ # _UDP_connection - Handle a UDP connection. #------------------------------------------------------------------------------ sub _UDP_connection { my ( $self, $socket, $buffer ) = @_; my $verbose = $self->{Verbose}; my $query = Net::DNS::Packet->new( \$buffer ); if ($@) { print "Error decoding query packet: $@\n" if $verbose; undef $query; ## force FORMERR reply } my $reply = $self->_make_reply( $query, $socket ); die 'Failed to create reply' unless defined $reply; my @UDPsize = ( $query && $self->{Truncate} ) ? $query->edns->UDPsize || 512 : (); if ($verbose) { my $response = $reply->data(@UDPsize); print 'UDP response (', length($response), ' octets) - '; print $socket->send($response) ? "sent" : "failed: $!", "\n"; } else { $socket->send( $reply->data(@UDPsize) ); } return; } sub _read_udp { my ( $socket, $verbose ) = @_; my $buffer = ''; $socket->recv( $buffer, 9000 ); ## payload limit for Ethernet "Jumbo" packet if ($verbose) { my $peer = $socket->peerhost; my $port = $socket->peerport; my $size = length $buffer; print "Received $size octets from [$peer] port $port\n"; } return $buffer; } #------------------------------------------------------------------------------ # Socket mechanics. #------------------------------------------------------------------------------ use constant DEBUG => $ENV{DEBUG} ? 1 : 0; sub _logmsg { warn( join '', "$0 $$: @_ at ", scalar localtime(), "\n" ); return } sub _TCP_socket { my ( $ip, $port ) = @_; my $socket = IO::Socket::IP->new( LocalAddr => $ip, LocalPort => $port, Sockopt => [SOCKOPT], Proto => "tcp", Listen => SOMAXCONN, Type => SOCK_STREAM ) or die "can't setup TCP socket: $!"; _logmsg "TCP server [$ip] port $port" if DEBUG; return $socket; } sub _TCP_server { my ( $self, $ip, $port, $timeout ) = @_; my $listen = _TCP_socket( $ip, $port ); my $select = IO::Select->new($listen); my $expired; my $terminate = sub { $expired++ }; local $SIG{ALRM} = $terminate; local $SIG{TERM} = $terminate; alarm $timeout; until ($expired) { local $! = 0; scalar( my @ready = $select->can_read(2) ) or do { redo if $!{EINTR}; ## retry if aborted by signal last if $!; }; foreach my $socket (@ready) { if ( $socket == $listen ) { $select->add( $listen->accept ); next; } if ( my $buffer = _read_tcp( $socket, $self->{Verbose} ) ) { _spawn( sub { $self->_TCP_connection( $socket, $buffer ) } ); } else { close($socket); $select->remove($socket); } } sleep(0) if MSWin; } return; } sub _UDP_socket { my ( $ip, $port ) = @_; my $socket = IO::Socket::IP->new( LocalAddr => $ip, LocalPort => $port, Sockopt => [SOCKOPT], Proto => "udp", Type => SOCK_DGRAM ) or die "can't setup UDP socket: $!"; _logmsg "UDP server [$ip] port $port" if DEBUG; return $socket; } sub _UDP_server { my ( $self, $ip, $port, $timeout ) = @_; my $socket = _UDP_socket( $ip, $port ); my $select = IO::Select->new($socket); my $expired; my $terminate = sub { $expired++ }; local $SIG{ALRM} = $terminate; local $SIG{TERM} = $terminate; alarm $timeout; until ($expired) { local $! = 0; scalar( my @ready = $select->can_read(2) ) or do { redo if $!{EINTR}; ## retry if aborted by signal last if $!; }; foreach my $client (@ready) { my $buffer = _read_udp( $client, $self->{Verbose} ); _spawn( sub { $self->_UDP_connection( $client, $buffer ) } ); } sleep(0) if MSWin; } return; } #------------------------------------------------------------------------------ # Process mechanics. #------------------------------------------------------------------------------ my $noop = sub { }; sub _spawn { my $coderef = shift; unless ( defined( my $pid = fork() ) ) { die "cannot fork: $!"; } elsif ($pid) { _logmsg "begat $pid" if DEBUG; return $pid; ## parent } # else ... local $SIG{TERM} = $noop; local $SIG{CHLD} = \&_reaper; $coderef->(); ## child exit; } sub _reaper { local ( $!, $? ); ## protect error and exit status $SIG{CHLD} = \&_reaper; ## no critic sysV semantics while ( abs( my $pid = waitpid( -1, POSIX ? WNOHANG : 0 ) ) > 1 ) { _logmsg "reaped $pid" if DEBUG; } return; } our @pid; my $pid = $$; sub start_server { my ( $self, $timeout ) = @_; $timeout ||= 600; croak 'Attempt to start ', ref($self), ' in a subprocess' unless $$ == $pid; _logmsg('start server') if DEBUG; foreach my $ip ( @{$self->{LocalAddr}} ) { my $port = $self->{LocalPort}; push @pid, _spawn sub { $self->_TCP_server( $ip, $port, $timeout ) }; push @pid, _spawn sub { $self->_UDP_server( $ip, $port, $timeout ) }; } return; } sub stop_server { _logmsg('stop server') if DEBUG; kill 'TERM', @pid; return; } END { local ( $!, $? ); ## protect error and exit status while ( abs( my $pid = waitpid( -1, 0 ) ) > 1 ) { _logmsg "reaped $pid" if DEBUG; } _logmsg "terminated" if DEBUG; } 1; __END__ =head1 METHODS =head2 new $nameserver = Net::DNS::Nameserver->new( LocalAddr => ['::1', '127.0.0.1'], LocalPort => 15353, ZoneFile => "filename" ); $nameserver = Net::DNS::Nameserver->new( LocalAddr => '10.1.2.3', LocalPort => 15353, ReplyHandler => \&reply_handler, Verbose => 1, Truncate => 0 ); Instantiates a Net::DNS::Nameserver object. An exception is raised if the object could not be created. Each instance is configured using the following optional arguments: =over 4 =item LocalAddr IP address on which to listen. Defaults to the local loopback address. =item LocalPort Port on which to listen. =item ZoneFile Name of file containing RRs accessed using the internal reply-handling subroutine. =item ReplyHandler Reference to customised reply-handling subroutine. =item NotifyHandler Reference to reply-handling subroutine for queries with opcode NOTIFY (RFC1996). =item UpdateHandler Reference to reply-handling subroutine for queries with opcode UPDATE (RFC2136). =item Verbose Report internal activity. Defaults to 0 (off). =item Truncate Truncates UDP packets that are too big for the reply. Defaults to 1 (on). =back The LocalAddr attribute may alternatively be specified as an array of IP addresses to listen to. The ReplyHandler subroutine is passed the query name, query class, query type, peerhost, query record, and connection descriptor. It must either return the response code and references to the answer, authority, and additional sections of the response, or undef to leave the query unanswered. Common response codes are: =over 4 =item NOERROR No error =item FORMERR Format error =item SERVFAIL Server failure =item NXDOMAIN Non-existent domain (name doesn't exist) =item NOTIMP Not implemented =item REFUSED Query refused =back For advanced usage it may also contain a headermask containing an hashref with the settings for the C, C, and C header bits. The argument is of the form: {ad => 1, aa => 0, ra => 1} EDNS options may be specified in a similar manner using the optionmask: {$optioncode => $value, $optionname => $value} See RFC1035 and IANA DNS parameters file for more information: The nameserver will listen for both UDP and TCP connections. On linux and other Unix-like systems, unprivileged users are denied access to ports below 1024. UDP reply truncation functionality was introduced in Net::DNS 0.66. The size limit is determined by the EDNS0 size advertised in the query, otherwise 512 is used. If you want to do packet truncation yourself you should set Truncate=>0 and truncate the reply packet in the code of the ReplyHandler. =head2 start_server $ns->start_server( ); Starts a server process for each of the specified UDP and TCP sockets which continuously responds to user connections. The timeout parameter specifies the time the server is to remain active. If called with no parameter a default timeout of 10 minutes is applied. =head2 stop_server $ns->stop_server(); Terminates all server processes in an orderly fashion. =head1 EXAMPLES =head2 Example 1: Test script with embedded nameserver The following example is a self-contained test script which queries DNS zonefile data served by an embedded Net::DNS::Nameserver instance. use strict; use warnings; use Test::More; plan skip_all => 'Net::DNS::Nameserver not available' unless eval { require Net::DNS::Nameserver } and Net::DNS::Nameserver->can('start_server'); plan tests => 2; my $resolver = Net::DNS::Resolver->new( nameserver => ['::1', '127.0.0.1'], port => 15353 ); my $ns = Net::DNS::Nameserver->new( LocalAddr => [$resolver->nameserver], LocalPort => $resolver->port, Verbose => 0, ZoneFile => \*DATA ) or die "couldn't create nameserver object"; $ns->start_server(10); my $reply = $resolver->send(qw(example.com SOA)); is( ref($reply), 'Net::DNS::Packet', 'received reply packet' ); my ($rr) = $reply->answer; is( $rr->type, 'SOA', 'answer contains SOA record' ); $ns->stop_server(); exit; __DATA__ $ORIGIN example.com. @ IN SOA mname rname 2023 2h 1h 2w 1h www IN A 93.184.216.34 =head2 Example 2: Free-standing customised DNS nameserver The following example will listen on port 15353 and respond to all queries for A records with the IP address 10.1.2.3. All other queries will be answered with NXDOMAIN. Authority and additional sections are left empty. The $peerhost variable catches the IP address of the peer host, so that additional filtering on a per-host basis may be applied. use strict; use warnings; use Net::DNS::Nameserver; sub reply_handler { my ( $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; my ( $rcode, @ans, @auth, @add ); print "Received query from $peerhost to " . $conn->{sockhost} . "\n"; $query->print; if ( $qtype eq "A" && $qname eq "foo.example.com" ) { my ( $ttl, $rdata ) = ( 3600, "10.1.2.3" ); my $rr = Net::DNS::RR->new("$qname $ttl $qclass $qtype $rdata"); push @ans, $rr; $rcode = "NOERROR"; } elsif ( $qname eq "foo.example.com" ) { $rcode = "NOERROR"; } else { $rcode = "NXDOMAIN"; } # mark the answer as authoritative (by setting the 'aa' flag) my $headermask = {aa => 1}; # specify EDNS options { option => value } my $optionmask = {}; return ( $rcode, \@ans, \@auth, \@add, $headermask, $optionmask ); } my $ns = Net::DNS::Nameserver->new( LocalPort => 15353, ReplyHandler => \&reply_handler, Verbose => 1 ) or die "couldn't create nameserver object"; $ns->start_server(60); exit; # leaving nameserver processes running for 60 seconds =head1 BUGS Limitations in perl make it impossible to guarantee that replies to UDP queries from Net::DNS::Nameserver are sent from the IP-address to which the query was directed, the source address being chosen by the operating system based upon its notion of "closest address". This limitation is mitigated to some extent by creating a separate socket and subprocess for each IP address. =head1 COPYRIGHT Copyright (c)2000 Michael Fuhr. Portions Copyright (c)2002-2004 Chris Reinhardt. Portions Copyright (c)2005 Robert Martin-Legene. Portions Copyright (c)2005-2009 O.M.Kolkman, RIPE NCC. Portions Copyright (c)2017-2024 R.W.Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L =cut __END__ DNS/ZoneFile.pm000044400000041375152345050350007253 0ustar00package Net::DNS::ZoneFile; use strict; use warnings; our $VERSION = (qw$Id: ZoneFile.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::ZoneFile - DNS zone file =head1 SYNOPSIS use Net::DNS::ZoneFile; $zonefile = Net::DNS::ZoneFile->new( 'named.example' ); while ( $rr = $zonefile->read ) { $rr->print; } @zone = $zonefile->read; =head1 DESCRIPTION Each Net::DNS::ZoneFile object instance represents a zone file together with any subordinate files introduced by the $INCLUDE directive. Zone file syntax is defined by RFC1035. A program may have multiple zone file objects, each maintaining its own independent parser state information. The parser supports both the $TTL directive defined by RFC2308 and the BIND $GENERATE syntax extension. All RRs in a zone file must have the same class, which may be specified for the first RR encountered and is then propagated automatically to all subsequent records. =cut use integer; use Carp; use base qw(Exporter); our @EXPORT = qw(parse read readfh); use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6] require Encode; Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; require IO::File; require PerlIO; require Net::DNS::Domain; require Net::DNS::RR; =head1 METHODS =head2 new $zonefile = Net::DNS::ZoneFile->new( 'filename', ['example.com'] ); $handle = IO::File->new( 'filename', '<:encoding(ISO8859-7)' ); $zonefile = Net::DNS::ZoneFile->new( $handle, ['example.com'] ); The new() constructor returns a Net::DNS::ZoneFile object which represents the zone file specified in the argument list. The specified file or file handle is open for reading and closed when exhausted or all references to the ZoneFile object cease to exist. The optional second argument specifies $ORIGIN for the zone file. Zone files are presumed to be UTF-8 encoded where that is supported. Alternative character encodings may be specified indirectly by creating a file handle with the desired encoding layer, which is then passed as an argument to new(). The specified encoding is propagated to files introduced by $INCLUDE directives. =cut sub new { my ( $class, $filename, $origin ) = @_; my $self = bless {fileopen => {}}, $class; $self->_origin($origin); if ( ref($filename) ) { $self->{filehandle} = $self->{filename} = $filename; return $self if ref($filename) =~ /IO::File|FileHandle|GLOB|Text/; croak 'argument not a file handle'; } croak 'filename argument undefined' unless $filename; my $discipline = UTF8 ? '<:encoding(UTF-8)' : '<'; $self->{filehandle} = IO::File->new( $filename, $discipline ) or croak "$filename: $!"; $self->{fileopen}->{$filename}++; $self->{filename} = $filename; return $self; } =head2 read $rr = $zonefile->read; @rr = $zonefile->read; When invoked in scalar context, read() returns a Net::DNS::RR object representing the next resource record encountered in the zone file, or undefined if end of data has been reached. When invoked in list context, read() returns the list of Net::DNS::RR objects in the order that they appear in the zone file. Comments and blank lines are silently disregarded. $INCLUDE, $ORIGIN, $TTL and $GENERATE directives are processed transparently. =cut sub read { my ($self) = @_; return &_read unless ref $self; # compatibility interface if (wantarray) { my @zone; # return entire zone eval { local $SIG{__DIE__}; while ( my $rr = $self->_getRR ) { push( @zone, $rr ); } }; croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; return @zone; } my $rr = eval { local $SIG{__DIE__}; $self->_getRR; # return single RR }; croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; return $rr; } =head2 name $filename = $zonefile->name; Returns the name of the current zone file. Embedded $INCLUDE directives will cause this to differ from the filename argument supplied when the object was created. =cut sub name { return shift->{filename}; } =head2 line $line = $zonefile->line; Returns the number of the last line read from the current zone file. =cut sub line { my $self = shift; return $self->{eom} if defined $self->{eom}; return $self->{filehandle}->input_line_number; } =head2 origin $origin = $zonefile->origin; Returns the fully qualified name of the current origin within the zone file. =cut sub origin { my $context = shift->{context}; return &$context( sub { Net::DNS::Domain->new('@') } )->string; } =head2 ttl $ttl = $zonefile->ttl; Returns the default TTL as specified by the $TTL directive. =cut sub ttl { return shift->{TTL}; } =head1 COMPATIBILITY WITH Net::DNS::ZoneFile 1.04 Applications which depended on the defunct Net::DNS::ZoneFile 1.04 CPAN distribution will continue to operate with minimal change using the compatibility interface described below. New application code should use the object-oriented interface. use Net::DNS::ZoneFile; $listref = Net::DNS::ZoneFile->read( $filename ); $listref = Net::DNS::ZoneFile->read( $filename, $include_dir ); $listref = Net::DNS::ZoneFile->readfh( $filehandle ); $listref = Net::DNS::ZoneFile->readfh( $filehandle, $include_dir ); $listref = Net::DNS::ZoneFile->parse( $string ); $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); $listref = Net::DNS::ZoneFile->parse( \$string ); $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir ); $_->print for @$listref; The optional second argument specifies the default path for filenames. The current working directory is used by default. Although not available in the original implementation, the RR list can be obtained directly by calling any of these methods in list context. @rr = Net::DNS::ZoneFile->read( $filename, $include_dir ); The partial result is returned if an error is encountered by the parser. =head2 read $listref = Net::DNS::ZoneFile->read( $filename ); $listref = Net::DNS::ZoneFile->read( $filename, $include_dir ); read() parses the contents of the specified file and returns a reference to the list of Net::DNS::RR objects. The return value is undefined if an error is encountered by the parser. =cut our $include_dir; ## dynamically scoped sub _filename { ## rebase unqualified filename my $name = shift; return $name if ref($name); ## file handle return $name unless $include_dir; require File::Spec; return $name if File::Spec->file_name_is_absolute($name); return $name if -f $name; ## file in current directory return File::Spec->catfile( $include_dir, $name ); } sub _read { my ($arg1) = @_; shift if !ref($arg1) && $arg1 eq __PACKAGE__; my $filename = shift; local $include_dir = shift; my $zonefile = Net::DNS::ZoneFile->new( _filename($filename) ); my @zone; eval { local $SIG{__DIE__}; my $rr; push( @zone, $rr ) while $rr = $zonefile->_getRR; }; return wantarray ? @zone : \@zone unless $@; carp $@; return wantarray ? @zone : undef; } { package Net::DNS::ZoneFile::Text; ## no critic ProhibitMultiplePackages use overload ( '<>' => 'readline' ); sub new { my ( $class, $data ) = @_; my $self = bless {}, $class; $self->{data} = [split /\n/, ref($data) ? $$data : $data]; return $self; } sub readline { my $self = shift; $self->{line}++; return shift( @{$self->{data}} ); } sub close { shift->{data} = []; return 1; } sub input_line_number { return shift->{line}; } } =head2 readfh $listref = Net::DNS::ZoneFile->readfh( $filehandle ); $listref = Net::DNS::ZoneFile->readfh( $filehandle, $include_dir ); readfh() parses data from the specified file handle and returns a reference to the list of Net::DNS::RR objects. The return value is undefined if an error is encountered by the parser. =cut sub readfh { return &_read; } =head2 parse $listref = Net::DNS::ZoneFile->parse( $string ); $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); $listref = Net::DNS::ZoneFile->parse( \$string ); $listref = Net::DNS::ZoneFile->parse( \$string, $include_dir ); parse() interprets the text in the argument string and returns a reference to the list of Net::DNS::RR objects. The return value is undefined if an error is encountered by the parser. =cut sub parse { my ($arg1) = @_; shift if $arg1 eq __PACKAGE__; my $string = shift; my @include = grep {defined} shift; return &readfh( Net::DNS::ZoneFile::Text->new($string), @include ); } ######################################## { package Net::DNS::ZoneFile::Generator; ## no critic ProhibitMultiplePackages use overload ( '<>' => 'readline' ); sub new { my ( $class, $range, $template, $line ) = @_; my $self = bless {}, $class; my ( $bound, $step ) = split m#[/]#, $range; # initial iterator state my ( $first, $last ) = split m#[-]#, $bound; $first ||= 0; $last ||= $first; $step ||= 1; # coerce step to match range $step = ( $last < $first ) ? -abs($step) : abs($step); $self->{count} = int( ( $last - $first ) / $step ) + 1; for ($template) { s/\\\$/\\036/g; # disguise escaped dollar s/\$\$/\\036/g; # disguise escaped dollar s/^"(.*)"$/$1/s; # unwrap BIND's quoted template @{$self}{qw(instant step template line)} = ( $first, $step, $_, $line ); } return $self; } sub readline { my $self = shift; return unless $self->{count}-- > 0; # EOF my $instant = $self->{instant}; # update iterator state $self->{instant} += $self->{step}; local $_ = $self->{template}; # copy template while (/\$\{(.*)\}/) { # interpolate ${...} my $s = _format( $instant, split /\,/, $1 ); s/\$\{$1\}/$s/eg; } s/\$/$instant/eg; # interpolate $ s/\\036/\$/g; # reinstate escaped $ return $_; } sub close { shift->{count} = 0; # suppress iterator return 1; } sub input_line_number { return shift->{line}; # fixed: identifies $GENERATE } sub _format { ## convert $GENERATE iteration number to specified format my $number = shift; # per ISC BIND 9.7 my $offset = shift || 0; my $length = shift || 0; my $format = shift || 'd'; my $value = $number + $offset; my $digit = $length || 1; return substr sprintf( "%01.$digit$format", $value ), -$length if $format =~ /[doxX]/; my $nibble = join( '.', split //, sprintf ".%32.32lx", $value ); return reverse lc( substr $nibble, -$length ) if $format =~ /[n]/; return reverse uc( substr $nibble, -$length ) if $format =~ /[N]/; die "unknown $format format"; } } sub _generate { ## expand $GENERATE into input stream my ( $self, $range, $template ) = @_; my $handle = Net::DNS::ZoneFile::Generator->new( $range, $template, $self->line ); $self->{parent} = bless {%$self}, ref($self); # save state, create link delete $self->{latest}; # forget current domain name return $self->{filehandle} = $handle; } my $LEX_REGEX = q/("[^"]*"|"[^"]*$)|;[^\n]*|([()])|[ \t\n\r\f]+/; sub _getline { ## get line from current source my $self = shift; my $fh = $self->{filehandle}; while (<$fh>) { next if /^\s*;/; # discard comment line next unless /\S/; # discard blank line if (/["(]/) { s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon my @token = grep { defined && length } split /(^\s)|$LEX_REGEX/o; while ( $token[-1] =~ /^"[^"]*$/ ) { # multiline quoted string $_ = pop(@token) . <$fh>; # reparse fragments s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon push @token, grep { defined && length } split /$LEX_REGEX/o; $_ = join ' ', @token; # reconstitute RR string } if ( grep { $_ eq '(' } @token ) { # concatenate multiline RR until ( grep { $_ eq ')' } @token ) { $_ = pop(@token) . <$fh>; s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon push @token, grep { defined && length } split /$LEX_REGEX/o; chomp $token[-1] unless $token[-1] =~ /^"[^"]*$/; } $_ = join ' ', @token; # reconstitute RR string } } return $_ unless /^[\$]/; # RR string my @token = grep { defined && length } split /$LEX_REGEX/o; if (/^\$INCLUDE/) { # directive my ( $keyword, @argument ) = @token; die '$INCLUDE incomplete' unless @argument; $fh = $self->_include(@argument); } elsif (/^\$GENERATE/) { # directive my ( $keyword, $range, @template ) = @token; die '$GENERATE incomplete' unless @template; $fh = $self->_generate( $range, "@template" ); } elsif (/^\$ORIGIN/) { # directive my ( $keyword, $origin ) = @token; die '$ORIGIN incomplete' unless defined $origin; $self->_origin($origin); } elsif (/^\$TTL/) { # directive my ( $keyword, $ttl ) = @token; die '$TTL incomplete' unless defined $ttl; $self->{TTL} = Net::DNS::RR::ttl( {}, $ttl ); } else { # unrecognised my ($keyword) = @token; die qq[unknown "$keyword" directive]; } } $self->{eom} = $self->line; # end of file $fh->close(); my $link = $self->{parent} || return; # end of zone %$self = %$link; # end $INCLUDE return $self->_getline; # resume input } sub _getRR { ## get RR from current source my $self = shift; local $_; $self->_getline || return; # line already in $_ my $noname = s/^\s/\@\t/; # placeholder for empty RR name # construct RR object with context specific dynamically scoped $ORIGIN my $context = $self->{context}; my $rr = &$context( sub { Net::DNS::RR->_new_string($_) } ); my $latest = $self->{latest}; # overwrite placeholder $rr->{owner} = $latest->{owner} if $noname && $latest; $self->{class} = $rr->class unless $self->{class}; # propagate RR class $rr->class( $self->{class} ); unless ( defined $self->{TTL} ) { $self->{TTL} = $rr->minimum if $rr->type eq 'SOA'; # default TTL } $rr->{ttl} = $self->{TTL} unless defined $rr->{ttl}; return $self->{latest} = $rr; } sub _include { ## open $INCLUDE file my ( $self, $include, $origin ) = @_; my $filename = _filename($include); die qq(\$INCLUDE $filename: Unexpected recursion) if $self->{fileopen}->{$filename}++; my $discipline = join( ':', '<', PerlIO::get_layers $self->{filehandle} ); my $filehandle = IO::File->new( $filename, $discipline ) or die qq(\$INCLUDE $filename: $!); $self->{parent} = bless {%$self}, ref($self); # save state, create link delete $self->{latest}; # forget current domain name $self->_origin($origin) if $origin; $self->{filename} = $filename; return $self->{filehandle} = $filehandle; } sub _origin { ## change $ORIGIN (scope: current file) my ( $self, $name ) = @_; my $context = $self->{context}; $context = Net::DNS::Domain->origin(undef) unless $context; $self->{context} = &$context( sub { Net::DNS::Domain->origin($name) } ); delete $self->{latest}; # forget previous owner return; } 1; __END__ =head1 ACKNOWLEDGEMENTS This package is designed as an improved and compatible replacement for Net::DNS::ZoneFile 1.04 which was created by Luis Munoz in 2002 as a separate CPAN module. The present implementation is the result of an agreement to merge our two different approaches into one package integrated into Net::DNS. The contribution of Luis Munoz is gratefully acknowledged. Thanks are also due to Willem Toorop for his constructive criticism of the initial version and invaluable assistance during testing. =head1 COPYRIGHT Copyright (c)2011-2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut DNS/Resolver/UNIX.pm000044400000004240152345050350010112 0ustar00package Net::DNS::Resolver::UNIX; use strict; use warnings; our $VERSION = (qw$Id: UNIX.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::UNIX - Unix resolver class =cut my @config_file = grep { -f $_ && -r $_ } '/etc/resolv.conf'; my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; my $path = $ENV{PATH}; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $path; my $uname = eval {`uname -n 2>/dev/null`} || ''; chomp $uname; my ( $host, @domain ) = split /\./, $uname, 2; sub _init { my $defaults = shift->_defaults; $defaults->domain(@domain); $defaults->_read_config_file($_) foreach @config_file; %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2003 Chris Reinhardt. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut DNS/Resolver/os390.pm000044400000010732152345050350010207 0ustar00package Net::DNS::Resolver::os390; use strict; use warnings; our $VERSION = (qw$Id: os390.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::os390 - IBM OS/390 resolver class =cut use IO::File; my $path = $ENV{PATH}; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $path; my $sysname = eval {`sysvar SYSNAME 2>/dev/null`} || ''; chomp $sysname; my %RESOLVER_SETUP; ## placeholders for unimplemented search list elements my @dataset = ( ## plausible places to seek resolver configuration $RESOLVER_SETUP{GLOBALTCPIPDATA}, $ENV{RESOLVER_CONFIG}, # MVS dataset or Unix file name "/etc/resolv.conf", $RESOLVER_SETUP{SYSTCPD}, "//TCPIP.DATA", # .TCPIP.DATA "//'${sysname}.TCPPARMS(TCPDATA)'", "//'SYS1.TCPPARMS(TCPDATA)'", $RESOLVER_SETUP{DEFAULTTCPIPDATA}, "//'TCPIP.TCPIP.DATA'" ); my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; my %option = ( ## map MVS config option names NSPORTADDR => 'port', RESOLVERTIMEOUT => 'retrans', RESOLVERUDPRETRIES => 'retry', SORTLIST => 'sortlist', ); sub _init { my $defaults = shift->_defaults; my %stop; local $ENV{PATH} = join ':', grep {$_} qw(/bin /usr/bin), $path; foreach my $dataset ( Net::DNS::Resolver::Base::_untaint( grep {$_} @dataset ) ) { eval { local $_; my @nameserver; my @searchlist; my $handle = IO::File->new( qq[cat "$dataset" 2>/dev/null], '-|' ) or die "$dataset: $!"; # "cat" able to read MVS datasets while (<$handle>) { s/[;#].*$//; # strip comment s/^\s+//; # strip leading white space next unless $_; # skip empty line next if m/^\w+:/ && !m/^$sysname:/oi; s/^\w+:\s*//; # discard qualifier m/^(NSINTERADDR|nameserver)/i && do { my ( $keyword, @ip ) = grep {defined} split; push @nameserver, @ip; next; }; m/^(DOMAINORIGIN|domain)/i && do { my ( $keyword, @domain ) = grep {defined} split; $defaults->domain(@domain) unless $stop{domain}++; next; }; m/^search/i && do { my ( $keyword, @domain ) = grep {defined} split; push @searchlist, @domain; next; }; m/^option/i && do { my ( $keyword, @option ) = grep {defined} split; foreach (@option) { my ( $attribute, @value ) = split m/:/; $defaults->_option( $attribute, @value ) unless $stop{$attribute}++; } next; }; m/^RESOLVEVIA/i && do { my ( $keyword, $value ) = grep {defined} split; $defaults->_option( 'usevc', $value eq 'TCP' ) unless $stop{usevc}++; next; }; m/^\w+\s*/ && do { my ( $keyword, @value ) = grep {defined} split; my $attribute = $option{uc $keyword} || next; $defaults->_option( $attribute, @value ) unless $stop{$attribute}++; }; } close($handle); $defaults->nameserver(@nameserver) if @nameserver && !$stop{nameserver}++; $defaults->searchlist(@searchlist) if @searchlist && !$stop{search}++; }; warn $@ if $@; } %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2017 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut DNS/Resolver/android.pm000044400000004347152345050350010757 0ustar00package Net::DNS::Resolver::android; use strict; use warnings; our $VERSION = (qw$Id: android.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::android - Android resolver class =cut my $config_file = 'resolv.conf'; my @config_path = ( $ENV{ANDROID_ROOT} || '/system' ); my @config_file = grep { -f $_ && -r $_ } map {"$_/etc/$config_file"} @config_path; my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; sub _init { my $defaults = shift->_defaults; my @nameserver; for ( 1 .. 4 ) { my $ret = `getprop net.dns$_` || next; chomp $ret; push @nameserver, $ret || next; } $defaults->nameserver(@nameserver) if @nameserver; $defaults->_read_config_file($_) foreach @config_file; %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2014 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut DNS/Resolver/os2.pm000044400000004014152345050350010031 0ustar00package Net::DNS::Resolver::os2; use strict; use warnings; our $VERSION = (qw$Id: os2.pm 2007 2025-02-08 16:45:23Z willem $)[2]; =head1 NAME Net::DNS::Resolver::os2 - OS2 resolver class =cut my $config_file = 'resolv'; my @config_path = ( $ENV{ETC} || '/etc' ); my @config_file = grep { -f $_ && -r $_ } map {"$_/$config_file"} @config_path; my $homedir = $ENV{HOME}; my $dotfile = '.resolv.conf'; my @dotfile = grep { -f $_ && -o $_ } map {"$_/$dotfile"} grep {$_} $homedir, '.'; sub _init { my $defaults = shift->_defaults; $defaults->_read_config_file($_) foreach @config_file; %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_config_file($_) foreach @dotfile; $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut DNS/Resolver/Recurse.pm000044400000014032152345050350010737 0ustar00package Net::DNS::Resolver::Recurse; use strict; use warnings; our $VERSION = (qw$Id: Recurse.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Resolver::Recurse - DNS recursive resolver =head1 SYNOPSIS use Net::DNS::Resolver::Recurse; my $resolver = new Net::DNS::Resolver::Recurse(); $resolver->hints('198.41.0.4'); # A.ROOT-SERVER.NET. my $packet = $resolver->send( 'www.rob.com.au.', 'A' ); =head1 DESCRIPTION This module resolves queries by following the delegation path from the DNS root. =cut use base qw(Net::DNS::Resolver::Base); =head1 METHODS This module inherits almost all the methods from Net::DNS::Resolver. Additional module-specific methods are described below. =head2 hints This method specifies a list of the IP addresses of nameservers to be used to discover the addresses of the root nameservers. $resolver->hints(@ip); If no hints are passed, the priming query is directed to nameservers drawn from a built-in list of IP addresses. =cut my @hints; my $root; sub hints { my ( undef, @argument ) = @_; return @hints unless scalar @argument; undef $root; return @hints = @argument; } =head2 query, search, send The query(), search() and send() methods produce the same result as their counterparts in Net::DNS::Resolver. $packet = $resolver->send( 'www.example.com.', 'A' ); Server-side recursion is suppressed by clearing the recurse flag in query packets and recursive name resolution is performed explicitly. The query() and search() methods are inherited from Net::DNS::Resolver and invoke send() indirectly. =cut sub send { my ( $self, @q ) = @_; my @conf = ( recurse => 0, udppacketsize => 1232 ); return bless( {persistent => {'.' => $root}, %$self, @conf}, ref($self) )->_send(@q); } sub query_dorecursion { ## historical my ($self) = @_; # uncoverable pod $self->_deprecate('prefer $resolver->send(...)'); return &send; } sub _send { my ( $self, @q ) = @_; my $query = $self->_make_query_packet(@q); unless ($root) { $self->_diag('resolver priming query'); $self->nameservers( scalar(@hints) ? @hints : $self->_hints ); $self->_referral( $self->SUPER::send(qw(. NS)) ); $root = $self->{persistent}->{'.'}; } return $self->_recurse( $query, '.' ); } sub _recurse { my ( $self, $query, $apex ) = @_; $self->_diag("using cached nameservers for $apex"); my $cache = $self->{persistent}->{$apex}; my @nslist = keys %$cache; my @glue = grep { $$cache{$_} } @nslist; my @noglue = grep { !$$cache{$_} } @nslist; my $reply; foreach my $ns ( @glue, @noglue ) { if ( my $iplist = $$cache{$ns} ) { $self->nameservers(@$iplist); } else { $self->_diag("recover missing glue for $ns"); next if substr( lc($ns), -length($apex) ) eq $apex; my @ip = $self->nameservers($ns); $$cache{$ns} = \@ip; } $query->header->id(undef); last if $reply = $self->SUPER::send($query); $$cache{$ns} = undef; # park non-responder } $self->_callback($reply); return unless $reply; my $zone = $self->_referral($reply) || return $reply; die '_recurse exceeded depth limit' if $self->{recurse_depth}++ > 50; my $qname = lc( ( $query->question )[0]->qname ); my $suffix = substr( $qname, -length($zone) ); return $zone eq $suffix ? $self->_recurse( $query, $zone ) : undef; } sub _referral { my ( $self, $packet ) = @_; return unless $packet; my @ans = $packet->answer; my @auth = grep { $_->type eq 'NS' } $packet->authority, @ans; return unless scalar(@auth); my $owner = lc( $auth[0]->owner ); my $cache = $self->{persistent}->{$owner}; return scalar(@ans) ? undef : $owner if $cache; $self->_diag("caching nameservers for $owner"); my %addr; my @addr = grep { $_->can('address') } $packet->additional; push @{$addr{lc $_->owner}}, $_->address foreach @addr; my %cache; foreach my $ns ( map { lc( $_->nsdname ) } @auth ) { $cache{$ns} = $addr{$ns}; } $self->{persistent}->{$owner} = \%cache; return scalar(@ans) ? undef : $owner; } =head2 callback This method specifies a code reference to a subroutine, which is then invoked at each stage of the recursive lookup. For example to emulate dig's C<+trace> function: my $coderef = sub { my $packet = shift; printf ";; Received %d bytes from %s\n\n", $packet->answersize, $packet->answerfrom; }; $resolver->callback($coderef); The callback subroutine is not called for queries for missing glue records. =cut sub callback { my ( $self, @argument ) = @_; for ( grep { ref($_) eq 'CODE' } @argument ) { $self->{callback} = $_; } return; } sub _callback { my ( $self, @argument ) = @_; my $callback = $self->{callback}; $callback->(@argument) if $callback; return; } sub recursion_callback { ## historical my ($self) = @_; # uncoverable pod $self->_deprecate('prefer $resolver->callback(...)'); &callback; return; } 1; __END__ =head1 ACKNOWLEDGEMENT This package is an improved and compatible reimplementation of the Net::DNS::Resolver::Recurse.pm created by Rob Brown in 2002, whose contribution is gratefully acknowledged. =head1 COPYRIGHT Copyright (c)2014,2019 Dick Franks. Portions Copyright (c)2002 Rob Brown. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L =cut DNS/Resolver/cygwin.pm000044400000011454152345050350010634 0ustar00package Net::DNS::Resolver::cygwin; use strict; use warnings; our $VERSION = (qw$Id: cygwin.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Resolver::cygwin - Cygwin resolver class =cut use IO::File; sub _getregkey { my @key = @_; my $handle = IO::File->new( join( '/', @key ), '<' ) or return ''; my $value = <$handle> || ''; close($handle); $value =~ s/\0+$//; return $value; } sub _init { my $defaults = shift->_defaults; my $dirhandle; my $root = '/proc/registry/HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Services/Tcpip/Parameters'; unless ( -d $root ) { # Doesn't exist, maybe we are on 95/98/Me? $root = '/proc/registry/HKEY_LOCAL_MACHINE/SYSTEM/CurrentControlSet/Services/VxD/MSTCP'; -d $root || Carp::croak "can't read registry: $!"; } # Best effort to find a useful domain name for the current host # if domain ends up blank, we're probably (?) not connected anywhere # a DNS server is interesting either... my $domain = _getregkey( $root, 'Domain' ) || _getregkey( $root, 'DhcpDomain' ); # If nothing else, the searchlist should probably contain our own domain # also see below for domain name devolution if so configured # (also remove any duplicates later) my $devolution = _getregkey( $root, 'UseDomainNameDevolution' ); my $searchlist = _getregkey( $root, 'SearchList' ); my @searchlist = ( $domain, split m/[\s,]+/, $searchlist ); # This is (probably) adequate on NT4 my @nt4nameservers; foreach ( grep {length} _getregkey( $root, 'NameServer' ), _getregkey( $root, 'DhcpNameServer' ) ) { push @nt4nameservers, split m/[\s,]+/; last; } # but on W2K/XP the registry layout is more advanced due to dynamically # appearing connections. So we attempt to handle them, too... # opt to silently fail if something isn't ok (maybe we're on NT4) # If this doesn't fail override any NT4 style result we found, as it # may be there but is not valid. # drop any duplicates later my @nameservers; my $dnsadapters = join '/', $root, 'DNSRegisteredAdapters'; if ( opendir( $dirhandle, $dnsadapters ) ) { my @adapters = grep { !/^\.\.?$/ } readdir($dirhandle); closedir($dirhandle); foreach my $adapter (@adapters) { my $ns = _getregkey( $dnsadapters, $adapter, 'DNSServerAddresses' ); until ( length($ns) < 4 ) { push @nameservers, join '.', unpack( 'C4', $ns ); substr( $ns, 0, 4 ) = ''; } } } my $interfaces = join '/', $root, 'Interfaces'; if ( opendir( $dirhandle, $interfaces ) ) { my @ifacelist = grep { !/^\.\.?$/ } readdir($dirhandle); closedir($dirhandle); foreach my $iface (@ifacelist) { my $ip = _getregkey( $interfaces, $iface, 'DhcpIPAddress' ) || _getregkey( $interfaces, $iface, 'IPAddress' ); next unless $ip; next if $ip eq '0.0.0.0'; foreach ( grep {length} _getregkey( $interfaces, $iface, 'NameServer' ), _getregkey( $interfaces, $iface, 'DhcpNameServer' ) ) { push @nameservers, split m/[\s,]+/; last; } } } @nameservers = @nt4nameservers unless @nameservers; $defaults->nameservers(@nameservers); # fix devolution if configured, and simultaneously # eliminate duplicate entries (but keep the order) my @list; my %seen; foreach (@searchlist) { s/\.+$//; push( @list, $_ ) unless $seen{lc $_}++; next unless $devolution; # while there are more than two labels, cut while (s#^[^.]+\.(.+\..+)$#$1#) { push( @list, $_ ) unless $seen{lc $_}++; } } $defaults->searchlist(@list); %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2003 Sidney Markowitz. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut DNS/Resolver/Mock.pm000044400000012156152345050350010225 0ustar00package Net::DNS::Resolver::Mock; use strict; use warnings; our $VERSION = '1.20230216'; # VERSION use base 'Net::DNS::Resolver'; use Net::DNS::Packet; use Net::DNS::Question; use Net::DNS::ZoneFile; my $die_on = {}; { my @_debug_output; sub enable_debug { my ( $self ) = @_; $self->{_mock_debug} = 1; $self->_add_debug( "Net::DNS::Resolver::Mock Debugging enabled" ); return; } sub disable_debug { my ( $self ) = @_; $self->clear_debug(); delete $self->{_mock_debug}; return; } sub _add_debug { my ( $self, $debug ) = @_; push @_debug_output, $debug; warn $debug; return; } sub clear_debug { my ( $self ) = @_; @_debug_output = (); return; } sub get_debug { my ( $self ) = @_; return @_debug_output; } } sub die_on { my ( $self, $name, $type, $error ) = @_; $die_on->{ "$name $type" } = $error; return; } sub build_cache { my ( $self ) = @_; my $cache = {}; my $FakeZone = $self->{ 'zonefile' }; foreach my $Item ( @$FakeZone ) { my $itemname = lc $Item->name(); my $itemtype = lc $Item->type(); my $key = join( ':', $itemname, $itemtype ); if ( ! exists $cache->{$key} ) { $cache->{$key} = []; } push @{ $cache->{$key} }, $Item; } $self->{ 'zonefile_cache' } = $cache; return; } sub zonefile_read { my ( $self, $zonefile ) = @_; $self->{ 'zonefile' } = Net::DNS::ZoneFile->read( $zonefile ); $self->build_cache(); return; } sub zonefile_parse { my ( $self, $zonefile ) = @_; $self->{ 'zonefile' } = Net::DNS::ZoneFile->parse( $zonefile ); $self->build_cache(); return; } sub send { my ( $self, $name, $type ) = @_; $self->_add_debug( "DNS Lookup '$name' '$type'" ) if $self->{_mock_debug}; if ( exists ( $die_on->{ "$name $type" } ) ) { die $die_on->{ "$name $type" }; } $name =~ s/\.$// unless $name eq '.'; my $origname = $name; if ( lc $type eq 'ptr' ) { if ( index( lc $name, '.in-addr.arpa' ) == -1 ) { if ( $name =~ /^\d+\.\d+\.\d+\.\d+$/ ) { $name = join( '.', reverse( split( /\./, $name ) ) ); $name .= '.in-addr.arpa'; } } } my $Packet = Net::DNS::Packet->new(); $Packet->push( 'question' => Net::DNS::Question->new( $origname, $type, 'IN' ) ); my $key = join( ':', lc $name, lc $type ); my $cname_key = join( ':', lc $name, 'cname' ); if ( exists( $self->{ 'zonefile_cache' }->{ $cname_key } ) ) { $Packet->push( 'answer' => @{ $self->{ 'zonefile_cache' }->{ $cname_key } } ); } elsif ( exists( $self->{ 'zonefile_cache' }->{ $key } ) ) { $Packet->push( 'answer' => @{ $self->{ 'zonefile_cache' }->{ $key } } ); } $Packet->{ 'answerfrom' } = '127.0.0.1'; $Packet->{ 'status' } = 33152; return $Packet; } 1; __END__ =head1 NAME Net::DNS::Resolver::Mock - Mock a DNS Resolver object for testing =head1 DESCRIPTION A subclass of Net::DNS::Resolver which parses a zonefile for it's data source. Primarily for use in testing. =for markdown [![Code on GitHub](https://img.shields.io/badge/github-repo-blue.svg)](https://github.com/marcbradshaw/Net-DNS-Resolver-Mock) =for markdown [![Build Status](https://travis-ci.org/marcbradshaw/Net-DNS-Resolver-Mock.svg?branch=master)](https://travis-ci.org/marcbradshaw/Net-DNS-Resolver-Mock) =for markdown [![Open Issues](https://img.shields.io/github/issues/marcbradshaw/Net-DNS-Resolver-Mock.svg)](https://github.com/marcbradshaw/Net-DNS-Resolver-Mock/issues) =for markdown [![Dist on CPAN](https://img.shields.io/cpan/v/Net-DNS-Resolver-Mock.svg)](https://metacpan.org/release/Net-DNS-Resolver-Mock) =for markdown [![CPANTS](https://img.shields.io/badge/cpants-kwalitee-blue.svg)](http://cpants.cpanauthors.org/dist/Net-DNS-Resolver-Mock) =head1 SYNOPSIS use Net::DNS::Resolver::Mock; my $Resolver = Net::DNS::Resolver::Mock-new(); $Resolver->zonefile_read( $FileName ); # or $Resolver->zonefile_parse( $String ); =head1 PUBLIC METHODS =over =item zonefile_read ( $FileName ) Reads specified file for zone data =item zonefile_parse ( $String ) Reads the zone data from the supplied string =item die_on ( $Name, $Type, $Error ) Die with $Error for a query of $Name and $Type =item enable_debug () Once set, the resolver will write any lookups received to STDERR and will be available via the following methods =item disble_debug () Disable debugging =item clear_debug () Clear the debugging list =item get_debug () Returns a list of debugging entries =back =head1 DEPENDENCIES Net::DNS::Resolver Net::DNS::Packet Net::DNS::Question Net::DNS::ZoneFile =head1 BUGS Please report bugs via the github tracker. https://github.com/marcbradshaw/Net-DNS-Resolver-Mock/issues =head1 AUTHORS Marc Bradshaw, Emarc@marcbradshaw.netE =head1 COPYRIGHT Copyright (c) 2017, Marc Bradshaw. =head1 LICENCE This library is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =cut DNS/Resolver/Base.pm000044400000077105152345050350010213 0ustar00package Net::DNS::Resolver::Base; use strict; use warnings; our $VERSION = (qw$Id: Base.pm 2011 2025-02-11 15:18:03Z willem $)[2]; # # Implementation notes wrt IPv6 support when using perl before 5.20.0. # # In general we try to be gracious to those stacks that do not have IPv6 support. # The socket code is conditionally compiled depending upon the availability of # the IO::Socket::IP package. # # We have chosen not to use mapped IPv4 addresses, there seem to be issues # with this; as a result we use separate sockets for each family type. # # inet_pton is not available on WIN32, so we only use the getaddrinfo # call to translate IP addresses to socketaddress. # # The configuration options force_v4, force_v6, prefer_v4 and prefer_v6 # are provided to control IPv6 behaviour for test purposes. # # Olaf Kolkman, RIPE NCC, December 2003. # [Revised March 2016, June 2018] use constant OS_SPEC => "Net::DNS::Resolver::$^O"; use constant OS_UNIX => "Net::DNS::Resolver::UNIX"; use constant OS_CONF => grep eval "require $_", OS_SPEC, OS_UNIX; ## no critic use base (OS_CONF)[0]; use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.38; 1;'; ## no critic require IO::Socket::INET unless USE_SOCKET_IP; use constant IPv6 => USE_SOCKET_IP; # If SOCKSified Perl, use TCP instead of UDP and keep the socket open. use constant SOCKS => scalar eval { require Config; $Config::Config{usesocks}; }; # Allow taint tests to be optimised away when appropriate. use constant TAINT => eval { ${^TAINT} }; use constant TESTS => TAINT && defined eval { require Scalar::Util; }; use integer; use Carp; use IO::File; use IO::Select; use IO::Socket; use Socket; { no strict 'subs'; ## no critic ProhibitNoStrict use constant AI_NUMERICHOST => Socket::AI_NUMERICHOST; use constant IPPROTO_UDP => Socket::IPPROTO_UDP; } use Net::DNS::RR; use Net::DNS::Packet; use constant PACKETSZ => 512; # # Set up a closure to be our class data. # { my $defaults = bless { nameservers => [qw(::1 127.0.0.1)], nameserver4 => ['127.0.0.1'], nameserver6 => ['::1'], port => 53, srcaddr4 => '0.0.0.0', srcaddr6 => '::', srcport => 0, searchlist => [], retrans => 5, retry => 4, usevc => ( SOCKS ? 1 : 0 ), igntc => 0, recurse => 1, defnames => 1, dnsrch => 1, ndots => 1, debug => 0, tcp_timeout => 120, udp_timeout => 30, persistent_tcp => ( SOCKS ? 1 : 0 ), persistent_udp => 0, dnssec => 0, adflag => 0, # see RFC6840, 5.7 cdflag => 0, # see RFC6840, 5.9 udppacketsize => 0, # value bounded below by PACKETSZ force_v4 => 0, force_v6 => 0, prefer_v4 => 0, prefer_v6 => 0, }, __PACKAGE__; sub _defaults { return $defaults; } } my %warned; sub _deprecate { my ( undef, @note ) = @_; carp join ' ', 'deprecated method;', "@note" unless $warned{"@note"}++; return; } sub _untaint { ## no critic # recurses into user list arguments return TAINT ? map { ref($_) ? [_untaint(@$_)] : do { /^(.*)$/; $1 } } @_ : @_; } # These are the attributes that the user may specify in the new() constructor. my %public_attr = ( map { $_ => $_ } keys %{&_defaults}, qw(domain nameserver srcaddr), map { $_ => 0 } qw(nameserver4 nameserver6 srcaddr4 srcaddr6), ); my $initial; sub new { my ( $class, %args ) = @_; my $self; my $base = $class->_defaults; my $init = $initial; $initial ||= [%$base]; if ( my $file = $args{config_file} ) { my $conf = bless {@$initial}, $class; $conf->_read_config_file($file); # user specified config $self = bless {_untaint(%$conf)}, $class; %$base = %$self unless $init; # define default configuration } elsif ($init) { $self = bless {%$base}, $class; } else { $class->_init(); # define default configuration $self = bless {%$base}, $class; } while ( my ( $attr, $value ) = each %args ) { next unless $public_attr{$attr}; my $ref = ref($value); croak "usage: $class->new( $attr => [...] )" if $ref && ( $ref ne 'ARRAY' ); $self->$attr( $ref ? @$value : $value ); } return $self; } my %resolv_conf = ( ## map traditional resolv.conf option names attempts => 'retry', inet6 => 'prefer_v6', timeout => 'retrans', ); my %res_option = ( ## any resolver attribute plus those listed above %public_attr, %resolv_conf, ); sub _option { my ( $self, $name, @value ) = @_; my $attribute = $res_option{lc $name} || return; push @value, 1 unless scalar @value; return $self->$attribute(@value); } sub _read_env { ## read resolver config environment variables my $self = shift; $self->searchlist( map {split} $ENV{LOCALDOMAIN} ) if defined $ENV{LOCALDOMAIN}; $self->nameservers( map {split} $ENV{RES_NAMESERVERS} ) if defined $ENV{RES_NAMESERVERS}; $self->searchlist( map {split} $ENV{RES_SEARCHLIST} ) if defined $ENV{RES_SEARCHLIST}; foreach ( map {split} $ENV{RES_OPTIONS} || '' ) { $self->_option( split m/:/ ); } return; } sub _read_config_file { ## read resolver config file my ( $self, $file ) = @_; my $filehandle = IO::File->new( $file, '<' ) or croak "$file: $!"; my @nameserver; my @searchlist; local $_; while (<$filehandle>) { s/[;#].*$//; # strip comments /^nameserver/ && do { my ( $keyword, @ip ) = grep {defined} split; push @nameserver, @ip; next; }; /^domain/ && do { my ( $keyword, $domain ) = grep {defined} split; $self->domain($domain); next; }; /^search/ && do { my ( $keyword, @domain ) = grep {defined} split; push @searchlist, @domain; next; }; /^option/ && do { my ( $keyword, @option ) = grep {defined} split; foreach (@option) { $self->_option( split m/:/ ); } }; } close($filehandle); $self->nameservers(@nameserver) if @nameserver; $self->searchlist(@searchlist) if @searchlist; return; } sub string { my $self = shift; $self = $self->_defaults unless ref($self); my @nslist = $self->nameservers(); my ($force) = ( grep( { $self->{$_} } qw(force_v6 force_v4) ), 'force_v4' ); my ($prefer) = ( grep( { $self->{$_} } qw(prefer_v6 prefer_v4) ), 'prefer_v4' ); return <{searchlist}} ;; defnames = $self->{defnames} dnsrch = $self->{dnsrch} ;; igntc = $self->{igntc} usevc = $self->{usevc} ;; recurse = $self->{recurse} port = $self->{port} ;; retrans = $self->{retrans} retry = $self->{retry} ;; tcp_timeout = $self->{tcp_timeout} persistent_tcp = $self->{persistent_tcp} ;; udp_timeout = $self->{udp_timeout} persistent_udp = $self->{persistent_udp} ;; ${prefer} = $self->{$prefer} ${force} = $self->{$force} ;; debug = $self->{debug} ndots = $self->{ndots} END } sub print { return print shift->string; } sub searchlist { my ( $self, @domain ) = @_; $self = $self->_defaults unless ref($self); foreach (@domain) { $_ = Net::DNS::Domain->new($_)->name } $self->{searchlist} = \@domain if scalar(@domain); return @{$self->{searchlist}}; } sub domain { return (&searchlist)[0]; } sub nameservers { my ( $self, @ns ) = @_; $self = $self->_defaults unless ref($self); my @ip; foreach my $ns ( grep {defined} @ns ) { if ( _ipv4($ns) || _ipv6($ns) ) { push @ip, $ns; } else { my $defres = ref($self)->new( debug => $self->{debug} ); $defres->{persistent} = $self->{persistent}; my $names = {}; my $packet = $defres->send( $ns, 'A' ); my @iplist = _cname_addr( $packet, $names ); if (IPv6) { $packet = $defres->send( $ns, 'AAAA' ); push @iplist, _cname_addr( $packet, $names ); } my %unique = map { $_ => $_ } @iplist; my @address = values(%unique); # tainted carp "unresolvable name: $ns" unless scalar @address; push @ip, @address; } } if ( scalar(@ns) || !defined(wantarray) ) { my @ipv4 = grep { _ipv4($_) } @ip; my @ipv6 = grep { _ipv6($_) } @ip; my @map4 = map {"::FFFF:$_"} @ipv4; $self->{nameservers} = \@ip; $self->{nameserver4} = \@ipv4; $self->{nameserver6} = \@ipv6; $self->{mapped_IPv4} = \@map4; } my @IPv4 = @{$self->{nameserver4}}; my @IPv6 = IPv6 ? @{$self->{nameserver6}} : (); my @IPlist = @IPv6 ? @{$self->{nameservers}} : @IPv4; @IPlist = ( @IPv6, @IPv4 ) if $self->{prefer_v6}; @IPlist = ( @IPv4, @IPv6 ) if $self->{prefer_v4}; @IPlist = @IPv6 if $self->{force_v6}; @IPlist = @IPv4 if $self->{force_v4}; $self->errorstring('no nameservers') unless @IPlist; return @IPlist; } sub nameserver { return &nameservers; } sub _cname_addr { # TODO 20081217 # This code does not follow CNAME chains, it only looks inside the packet. # Out of bailiwick will fail. my @null; my $packet = shift || return @null; my $names = shift; $names->{lc( $_->qname )}++ foreach $packet->question; $names->{lc( $_->cname )}++ foreach grep { $_->can('cname') } $packet->answer; my @addr = grep { $_->can('address') } $packet->answer; return map { $_->address } grep { $names->{lc( $_->name )} } @addr; } sub replyfrom { return shift->{replyfrom}; } sub answerfrom { return &replyfrom; } # uncoverable pod sub _reset_errorstring { shift->{errorstring} = ''; return; } sub errorstring { my ( $self, $text ) = @_; $self->_diag( 'errorstring:', $self->{errorstring} = $text ) if $text; return $self->{errorstring}; } sub query { my ( $self, @argument ) = @_; my $name = shift(@argument) || '.'; my @sfix = $self->{defnames} && ( $name !~ m/[.:]/ ) ? $self->domain : (); my $fqdn = join '.', $name, @sfix; $self->_diag( 'query(', $fqdn, @argument, ')' ); my $packet = $self->send( $fqdn, @argument ) || return; return $packet->header->ancount ? $packet : undef; } sub search { my ( $self, @argument ) = @_; return $self->query(@argument) unless $self->{dnsrch}; my $name = shift(@argument) || '.'; my $dots = $name =~ tr/././; my @sfix = ( $dots < $self->{ndots} ) ? @{$self->{searchlist}} : (); my ( $one, @more ) = ( $name =~ m/:|\.\d*$/ ) ? () : ( $dots ? ( undef, @sfix ) : @sfix ); foreach my $suffix ( $one, @more ) { my $fqname = $suffix ? join( '.', $name, $suffix ) : $name; $self->_diag( 'search(', $fqname, @argument, ')' ); my $packet = $self->send( $fqname, @argument ) || next; return $packet if $packet->header->ancount; } return; } sub send { my ( $self, @argument ) = @_; my $packet = $self->_make_query_packet(@argument); my $packet_data = $packet->encode; $self->_reset_errorstring; return $self->_send_tcp( $packet, $packet_data ) if $self->{usevc} || length $packet_data > $self->_packetsz; my $reply = $self->_send_udp( $packet, $packet_data ) || return; return $reply if $self->{igntc}; return $reply unless $reply->header->tc; $self->_diag('packet truncated: retrying using TCP'); return $self->_send_tcp( $packet, $packet_data ); } sub _send_tcp { my ( $self, $query, $query_data ) = @_; my $tcp_packet = pack 'n a*', length($query_data), $query_data; my @ns = $self->nameservers(); my $fallback; my $timeout = $self->{tcp_timeout}; foreach my $ip (@ns) { $self->_diag( 'tcp send', "[$ip]" ); my $connection = $self->_create_tcp_socket($ip); $self->errorstring($!); my $select = IO::Select->new( $connection || next ); $connection->send($tcp_packet); $self->errorstring($!); my @ready = $select->can_read($timeout); next unless @ready; # uncoverable branch true my $socket = shift @ready; my $buffer = _read_tcp($socket); $self->{replyfrom} = $ip; $self->_diag( 'packet from', "[$ip]", length($buffer), 'octets' ); my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); next unless $self->_accept_reply( $reply, $query ); $reply->from( $socket->peerhost ); if ( $self->{tsig_rr} && !$reply->verify($query) ) { $self->errorstring( $reply->verifyerr ); next; } my $rcode = $reply->header->rcode; return $reply if $rcode eq 'NOERROR'; return $reply if $rcode eq 'NXDOMAIN'; $fallback = $reply; } $self->errorstring( $fallback->header->rcode ) if $fallback; $self->errorstring('query timed out') unless $self->errorstring; return $fallback; } sub _send_udp { my ( $self, $query, $query_data ) = @_; my @ns = $self->nameservers; my $port = $self->{port}; my $retrans = $self->{retrans} || 1; my $retry = $self->{retry} || 1; my $servers = scalar(@ns); my $timeout = $servers ? do { no integer; $retrans / $servers } : 0; my $fallback; # Perform each round of retries. RETRY: for ( 1 .. $retry ) { # assumed to be a small number # Try each nameserver. my $select = IO::Select->new(); NAMESERVER: foreach my $ns (@ns) { # state vector replaces corresponding element of @ns array unless ( ref $ns ) { my $sockaddr = $self->_create_dst_sockaddr( $ns, $port ); my $socket = $self->_create_udp_socket($ns) || next; $ns = [$socket, $ns, $sockaddr]; } my ( $socket, $ip, $sockaddr, $failed ) = @$ns; next if $failed; $self->_diag( 'udp send', "[$ip]:$port" ); $select->add($socket); $socket->send( $query_data, 0, $sockaddr ); $self->errorstring( $$ns[3] = $! ); # handle failure to detect taint inside socket->send() die 'Insecure dependency while running with -T switch' if TESTS && Scalar::Util::tainted($sockaddr); my $reply; while ( my @ready = $select->can_read($timeout) ) { my $socket = shift @ready; my $buffer = _read_udp($socket); $self->{replyfrom} = $ip; $self->_diag( 'packet from', "[$ip]", length($buffer), 'octets' ); my $packet = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); next unless $self->_accept_reply( $packet, $query ); $packet->from( $socket->peerhost ); $reply = $packet; last; } #SELECT LOOP next unless $reply; if ( $self->{tsig_rr} && !$reply->verify($query) ) { $self->errorstring( $$ns[3] = $reply->verifyerr ); next; } my $rcode = $reply->header->rcode; return $reply if $rcode eq 'NOERROR'; return $reply if $rcode eq 'NXDOMAIN'; $fallback = $reply; $$ns[3] = $rcode; } #NAMESERVER LOOP no integer; $timeout += $timeout; } #RETRY LOOP $self->errorstring( $fallback->header->rcode ) if $fallback; $self->errorstring('query timed out') unless $self->errorstring; return $fallback; } sub bgsend { my ( $self, @argument ) = @_; my $packet = $self->_make_query_packet(@argument); my $packet_data = $packet->encode; $self->_reset_errorstring; return $self->_bgsend_tcp( $packet, $packet_data ) if $self->{usevc} || length $packet_data > $self->_packetsz; return $self->_bgsend_udp( $packet, $packet_data ); } sub _bgsend_tcp { my ( $self, $packet, $packet_data ) = @_; my $tcp_packet = pack 'n a*', length($packet_data), $packet_data; foreach my $ip ( $self->nameservers ) { $self->_diag( 'bgsend', "[$ip]" ); my $socket = $self->_create_tcp_socket($ip); $self->errorstring($!); next unless $socket; $socket->blocking(0); $socket->send($tcp_packet); $self->errorstring($!); $socket->blocking(1); my $expire = time() + $self->{tcp_timeout}; ${*$socket}{net_dns_bg} = [$expire, $packet]; return $socket; } return; } sub _bgsend_udp { my ( $self, $packet, $packet_data ) = @_; my $port = $self->{port}; foreach my $ip ( $self->nameservers ) { my $sockaddr = $self->_create_dst_sockaddr( $ip, $port ); my $socket = $self->_create_udp_socket($ip) || next; $self->_diag( 'bgsend', "[$ip]:$port" ); $socket->send( $packet_data, 0, $sockaddr ); $self->errorstring($!); # handle failure to detect taint inside $socket->send() die 'Insecure dependency while running with -T switch' if TESTS && Scalar::Util::tainted($sockaddr); my $expire = time() + $self->{udp_timeout}; ${*$socket}{net_dns_bg} = [$expire, $packet]; return $socket; } return; } sub bgbusy { ## no critic # overwrites user UDP handle my ( $self, $handle ) = @_; return unless $handle; my $appendix = ${*$handle}{net_dns_bg} ||= [time() + $self->{udp_timeout}]; my ( $expire, $query, $read ) = @$appendix; return if ref($read); return time() < $expire unless IO::Select->new($handle)->can_read(0.02); # limit CPU burn return unless $query; # SpamAssassin 3.4.1 workaround return unless $handle->socktype() == SOCK_DGRAM; my $ans = $self->_bgread($handle); $$appendix[0] = time(); $$appendix[2] = [$ans]; return unless $ans; return if $self->{igntc}; return unless $ans->header->tc; $self->_diag('packet truncated: retrying using TCP'); my $tcp = $self->_bgsend_tcp( $query, $query->encode ) || return; return defined( $_[1] = $tcp ); # caller's UDP handle now TCP } sub bgisready { ## historical __PACKAGE__->_deprecate('prefer ! bgbusy(...)'); # uncoverable pod return !&bgbusy; } sub bgread { 1 while &bgbusy; ## side effect: TCP retry if TC flag set return &_bgread; } sub _bgread { my ( $self, $handle ) = @_; return unless $handle; my $appendix = ${*$handle}{net_dns_bg}; my ( $expire, $query, $read ) = @$appendix; return shift(@$read) if ref($read); return unless IO::Select->new($handle)->can_read(0.2); my $dgram = $handle->socktype() == SOCK_DGRAM; my $buffer = $dgram ? _read_udp($handle) : _read_tcp($handle); my $peerhost = $self->{replyfrom} = $handle->peerhost; $self->_diag( "packet from [$peerhost]", length($buffer), 'octets' ); my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); $self->errorstring($@); return unless $self->_accept_reply( $reply, $query ); $reply->from($peerhost); return $reply unless $self->{tsig_rr} && !$reply->verify($query); $self->errorstring( $reply->verifyerr ); return; } sub _accept_reply { my ( $self, $reply, $query ) = @_; return unless $reply; my $header = $reply->header; return unless $header->qr; return if $query && ( $header->id != $query->header->id ); return $self->errorstring( $header->rcode ); # historical quirk } sub axfr { ## zone transfer my ( $self, @argument ) = @_; my $zone = scalar(@argument) ? shift @argument : $self->domain; my @class = @argument; my $request = $self->_make_query_packet( $zone, 'AXFR', @class ); return eval { $self->_diag("axfr( $zone @class )"); my ( $select, $verify, @rr, $soa ) = $self->_axfr_start($request); my $iterator = sub { ## iterate over RRs my $rr = shift(@rr); if ( ref($rr) eq 'Net::DNS::RR::SOA' ) { if ($soa) { $select = undef; return if $rr->canonical eq $soa->canonical; croak $self->errorstring('mismatched final SOA'); } $soa = $rr; } unless ( scalar @rr ) { my $reply; # refill @rr ( $reply, $verify ) = $self->_axfr_next( $select, $verify ); @rr = $reply->answer if $reply; } return $rr; }; return $iterator unless wantarray; my @zone; ## subvert iterator to assemble entire zone while ( my $rr = $iterator->() ) { push @zone, $rr, @rr; # copy RRs en bloc @rr = pop(@zone); # leave last one in @rr } return @zone; }; } sub axfr_start { ## historical my ( $self, @argument ) = @_; # uncoverable pod $self->_deprecate('prefer $iterator = $self->axfr(...)'); my $iterator = $self->axfr(@argument); ( $self->{axfr_iter} ) = grep {defined} ( $iterator, sub { } ); return defined($iterator); } sub axfr_next { ## historical my $self = shift; # uncoverable pod $self->_deprecate('prefer $iterator->()'); return $self->{axfr_iter}->(); } sub _axfr_start { my ( $self, $request ) = @_; my $content = $request->encode; my $TCP_msg = pack 'n a*', length($content), $content; my ( $select, $reply, $rcode ); foreach my $ns ( $self->nameservers ) { $self->_diag("axfr send [$ns]"); local $self->{persistent_tcp}; my $socket = $self->_create_tcp_socket($ns); $self->errorstring($!); $select = IO::Select->new( $socket || next ); $socket->send($TCP_msg); $self->errorstring($!); ($reply) = $self->_axfr_next($select); last if ( $rcode = $reply->header->rcode ) eq 'NOERROR'; } croak $self->errorstring unless $reply; $self->errorstring($rcode); # historical quirk my $verify = $request->sigrr ? $request : undef; unless ($verify) { croak $self->errorstring unless $rcode eq 'NOERROR'; return ( $select, $verify, $reply->answer ); } my $verifyok = $reply->verify($verify); croak $self->errorstring( $reply->verifyerr ) unless $verifyok; croak $self->errorstring if $rcode ne 'NOERROR'; return ( $select, $verifyok, $reply->answer ); } sub _axfr_next { my $self = shift; my $select = shift || return; my $verify = shift; my ($socket) = $select->can_read( $self->{tcp_timeout} ); croak $self->errorstring('timed out') unless $socket; my $buffer = _read_tcp($socket); my $packet = Net::DNS::Packet->decode( \$buffer ); croak $@, $self->errorstring('corrupt packet') if $@; return ( $packet, $verify ) unless $verify; my $verifyok = $packet->verify($verify); croak $self->errorstring( $packet->verifyerr ) unless $verifyok; return ( $packet, $verifyok ); } # # Usage: $data = _read_tcp($socket); # sub _read_socket { my ( $socket, $size ) = @_; my $buffer = ''; $socket->recv( $buffer, $size ) if $size; return $buffer; } sub _read_tcp { my $socket = shift; my $buffer = ''; my $header = _read_socket( $socket, 2 ); $header .= _read_socket( $socket, 2 - length $header ); return $buffer if length($header) < 2; # uncoverable branch true my $size = unpack 'n', $header; while ( my $fragment = _read_socket( $socket, $size - length $buffer ) ) { $buffer .= $fragment; } return $buffer; } # # Usage: $data = _read_udp($socket); # sub _read_udp { return _read_socket( shift(), 9000 ); ## payload limit for Ethernet "Jumbo" packet } sub _create_tcp_socket { my ( $self, $ip, @sockopt ) = @_; my $socket; my $sock_key = "TCP[$ip]"; if ( $socket = $self->{persistent}{$sock_key} ) { $self->_diag( 'using persistent socket', $sock_key ); return $socket if $socket->connected; $self->_diag('socket disconnected (trying to connect)'); } my $ip6_addr = IPv6 && _ipv6($ip); $socket = IO::Socket::IP->new( LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, LocalPort => $self->{srcport}, PeerAddr => $ip, PeerPort => $self->{port}, Proto => 'tcp', Timeout => $self->{tcp_timeout}, GetAddrInfoFlags => AI_NUMERICHOST, @sockopt ) if USE_SOCKET_IP; unless ( USE_SOCKET_IP or $ip6_addr ) { $socket = IO::Socket::INET->new( LocalAddr => $self->{srcaddr4}, LocalPort => $self->{srcport} || undef, PeerAddr => $ip, PeerPort => $self->{port}, Proto => 'tcp', Timeout => $self->{tcp_timeout}, @sockopt ); } $self->{persistent}{$sock_key} = $socket if $self->{persistent_tcp}; return $socket; } sub _create_udp_socket { my ( $self, $ip, @sockopt ) = @_; my $socket; my $sock_key = "UDP[$ip]"; return $socket if $socket = $self->{persistent}{$sock_key}; my $ip6_addr = IPv6 && _ipv6($ip); $socket = IO::Socket::IP->new( LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, LocalPort => $self->{srcport}, Proto => 'udp', Type => SOCK_DGRAM, GetAddrInfoFlags => AI_NUMERICHOST, @sockopt ) if USE_SOCKET_IP; unless ( USE_SOCKET_IP or $ip6_addr ) { $socket = IO::Socket::INET->new( LocalAddr => $self->{srcaddr4}, LocalPort => $self->{srcport} || undef, Proto => 'udp', Type => SOCK_DGRAM, @sockopt ); } $self->{persistent}{$sock_key} = $socket if $self->{persistent_udp}; return $socket; } my $ip4 = { family => AF_INET, flags => AI_NUMERICHOST, protocol => IPPROTO_UDP, socktype => SOCK_DGRAM }; my $ip6 = { family => AF_INET6, flags => AI_NUMERICHOST, protocol => IPPROTO_UDP, socktype => SOCK_DGRAM }; sub _create_dst_sockaddr { ## create UDP destination sockaddr structure my ( $self, $ip, $port ) = @_; unless (USE_SOCKET_IP) { # NB: errors raised in socket->send return _ipv6($ip) ? undef : sockaddr_in( $port, inet_aton($ip) ); } my @addrinfo = Socket::getaddrinfo( $ip, $port, _ipv6($ip) ? $ip6 : $ip4 ); return ( grep {ref} @addrinfo, {} )[0]->{addr}; } # Lightweight versions of subroutines from Net::IP module, recoded to fix RT#96812 sub _ipv4 { for (shift) { last if m/[^.0-9]/; # dots and digits only return m/\.\d+\./; # dots separated by digits } return; } sub _ipv6 { for (shift) { last unless m/:.*:/; # must contain two colons return 1 unless m/[^:0-9A-Fa-f]/; # colons and hexdigits only return 1 if m/^[:.0-9A-Fa-f]+\%.+$/; # RFC4007 scoped address return m/^[:0-9A-Fa-f]+:[.0-9]+$/; # prefix : dotted digits } return; } sub _make_query_packet { my ( $self, @argument ) = @_; my ($packet) = @argument; unless ( ref($packet) ) { $packet = Net::DNS::Packet->new(@argument); $packet->edns->udpsize( $self->{udppacketsize} ); my $header = $packet->header; $header->ad( $self->{adflag} ); # RFC6840, 5.7 $header->cd( $self->{cdflag} ); # RFC6840, 5.9 $header->do(1) if $self->{dnssec}; $header->rd( $self->{recurse} ); } if ( $self->{tsig_rr} ) { $packet->sign_tsig( $self->{tsig_rr} ) unless $packet->sigrr; } return $packet; } sub dnssec { my ( $self, @argument ) = @_; for (@argument) { $self->udppacketsize(1232); $self->{dnssec} = $_; } return $self->{dnssec}; } sub force_v6 { my ( $self, @value ) = @_; for (@value) { $self->{force_v4} = 0 if $self->{force_v6} = $_ } return $self->{force_v6} ? 1 : 0; } sub force_v4 { my ( $self, @value ) = @_; for (@value) { $self->{force_v6} = 0 if $self->{force_v4} = $_ } return $self->{force_v4} ? 1 : 0; } sub prefer_v6 { my ( $self, @value ) = @_; for (@value) { $self->{prefer_v4} = 0 if $self->{prefer_v6} = $_ } return $self->{prefer_v6} ? 1 : 0; } sub prefer_v4 { my ( $self, @value ) = @_; for (@value) { $self->{prefer_v6} = 0 if $self->{prefer_v4} = $_ } return $self->{prefer_v4} ? 1 : 0; } sub srcaddr { my ( $self, @value ) = @_; for (@value) { my $hashkey = _ipv6($_) ? 'srcaddr6' : 'srcaddr4'; $self->{$hashkey} = $_; } return shift @value; } sub tsig { my ( $self, $arg, @etc ) = @_; return $arg unless $arg; return $arg if ref($arg) eq 'Net::DNS::RR::TSIG'; $self->{tsig_rr} = eval { local $SIG{__DIE__}; require Net::DNS::RR::TSIG; Net::DNS::RR::TSIG->create( $arg, @etc ); }; croak "${@}unable to create TSIG record" if $@; return; } # if ($self->{udppacketsize} > PACKETSZ # then we use EDNS and $self->{udppacketsize} # should be taken as the maximum packet_data length sub _packetsz { my $udpsize = shift->{udppacketsize} || 0; return $udpsize > PACKETSZ ? $udpsize : PACKETSZ; } sub udppacketsize { my ( $self, @value ) = @_; for (@value) { $self->{udppacketsize} = $_ } return $self->_packetsz; } # # Keep this method around. Folk depend on it although it is neither documented nor exported. # sub make_query_packet { ## historical __PACKAGE__->_deprecate('see RT#37104'); # uncoverable pod return &_make_query_packet; } sub _diag { ## debug output return unless shift->{debug}; return print "\n;; @_\n"; } { my $parse_dig = sub { require Net::DNS::ZoneFile; my $dug = Net::DNS::ZoneFile->new( \*DATA ); my @rr = $dug->read; my @auth = grep { $_->type eq 'NS' } @rr; my %auth = map { lc $_->nsdname => 1 } @auth; my %glue; my @glue = grep { $auth{lc $_->name} } @rr; foreach ( grep { $_->can('address') } @glue ) { push @{$glue{lc $_->name}}, $_->address; } return map {@$_} values %glue; }; my @ip; sub _hints { ## default hints @ip = &$parse_dig unless scalar @ip; # once only, on demand splice @ip, 0, 0, splice( @ip, int( rand scalar @ip ) ); # cut deck return @ip; } } sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) sub AUTOLOAD { ## Default method my ($self) = @_; no strict 'refs'; ## no critic ProhibitNoStrict our $AUTOLOAD; my $name = $AUTOLOAD; $name =~ s/.*://; croak qq[unknown method "$name"] unless $public_attr{$name}; *{$AUTOLOAD} = sub { my $self = shift; $self = $self->_defaults unless ref($self); $self->{$name} = shift || 0 if scalar @_; return $self->{$name}; }; return &$AUTOLOAD; } 1; =head1 NAME Net::DNS::Resolver::Base - DNS resolver base class =head1 SYNOPSIS use base qw(Net::DNS::Resolver::Base); =head1 DESCRIPTION This class is the common base class for the different platform sub-classes of L. No user serviceable parts inside, see L for all your resolving needs. =head1 METHODS =head2 new, domain, searchlist, nameserver, nameservers, =head2 search, query, send, bgsend, bgbusy, bgread, axfr, =head2 force_v4, force_v6, prefer_v4, prefer_v6, =head2 dnssec, srcaddr, tsig, udppacketsize, =head2 print, string, errorstring, replyfrom See L. =head1 COPYRIGHT Copyright (c)2003,2004 Chris Reinhardt. Portions Copyright (c)2005 Olaf Kolkman. Portions Copyright (c)2014-2017 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L =cut ######################################## __DATA__ ## DEFAULT HINTS ; <<>> DiG 9.18.20 <<>> @b.root-servers.net . -t NS ; (2 servers found) ;; global options: +cmd ;; Got answer: ;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 938 ;; flags: qr aa rd; QUERY: 1, ANSWER: 13, AUTHORITY: 0, ADDITIONAL: 27 ;; WARNING: recursion requested but not available ;; OPT PSEUDOSECTION: ; EDNS: version: 0, flags:; udp: 1232 ;; QUESTION SECTION: ;. IN NS ;; ANSWER SECTION: . 518400 IN NS a.root-servers.net. . 518400 IN NS b.root-servers.net. . 518400 IN NS c.root-servers.net. . 518400 IN NS d.root-servers.net. . 518400 IN NS e.root-servers.net. . 518400 IN NS f.root-servers.net. . 518400 IN NS g.root-servers.net. . 518400 IN NS h.root-servers.net. . 518400 IN NS i.root-servers.net. . 518400 IN NS j.root-servers.net. . 518400 IN NS k.root-servers.net. . 518400 IN NS l.root-servers.net. . 518400 IN NS m.root-servers.net. ;; ADDITIONAL SECTION: a.root-servers.net. 518400 IN A 198.41.0.4 a.root-servers.net. 518400 IN AAAA 2001:503:ba3e::2:30 b.root-servers.net. 518400 IN A 170.247.170.2 b.root-servers.net. 518400 IN AAAA 2801:1b8:10::b c.root-servers.net. 518400 IN A 192.33.4.12 c.root-servers.net. 518400 IN AAAA 2001:500:2::c d.root-servers.net. 518400 IN A 199.7.91.13 d.root-servers.net. 518400 IN AAAA 2001:500:2d::d e.root-servers.net. 518400 IN A 192.203.230.10 e.root-servers.net. 518400 IN AAAA 2001:500:a8::e f.root-servers.net. 518400 IN A 192.5.5.241 f.root-servers.net. 518400 IN AAAA 2001:500:2f::f g.root-servers.net. 518400 IN A 192.112.36.4 g.root-servers.net. 518400 IN AAAA 2001:500:12::d0d h.root-servers.net. 518400 IN A 198.97.190.53 h.root-servers.net. 518400 IN AAAA 2001:500:1::53 i.root-servers.net. 518400 IN A 192.36.148.17 i.root-servers.net. 518400 IN AAAA 2001:7fe::53 j.root-servers.net. 518400 IN A 192.58.128.30 j.root-servers.net. 518400 IN AAAA 2001:503:c27::2:30 k.root-servers.net. 518400 IN A 193.0.14.129 k.root-servers.net. 518400 IN AAAA 2001:7fd::1 l.root-servers.net. 518400 IN A 199.7.83.42 l.root-servers.net. 518400 IN AAAA 2001:500:9f::42 m.root-servers.net. 518400 IN A 202.12.27.33 m.root-servers.net. 518400 IN AAAA 2001:dc3::35 ;; Query time: 19 msec ;; SERVER: 170.247.170.2#53(b.root-servers.net) (UDP) ;; WHEN: Fri Dec 29 22:01:37 GMT 2023 ;; MSG SIZE rcvd: 1003 DNS/Resolver/MSWin32.pm000044400000007131152345050350010473 0ustar00package Net::DNS::Resolver::MSWin32; use strict; use warnings; our $VERSION = (qw$Id: MSWin32.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Resolver::MSWin32 - MS Windows resolver class =cut use Carp; use constant WINHLP => defined eval 'require Win32::IPHelper'; ## no critic use constant WINREG => defined eval 'use Win32::TieRegistry qw(KEY_READ REG_DWORD); 1'; ## no critic our $Registry; sub _init { my $defaults = shift->_defaults; my $debug = 0; my $FIXED_INFO = {}; my $err = Win32::IPHelper::GetNetworkParams($FIXED_INFO); croak "GetNetworkParams() error %u: %s\n", $err, Win32::FormatMessage($err) if $err; if ($debug) { require Data::Dumper; print Data::Dumper::Dumper $FIXED_INFO; } my @nameservers = map { $_->{IpAddress} } @{$FIXED_INFO->{DnsServersList}}; $defaults->nameservers( grep {$_} @nameservers ); my $devolution = 0; my $domainname = $FIXED_INFO->{DomainName} || ''; my @searchlist = grep {length} $domainname; if (WINREG) { # The Win32::IPHelper does not return searchlist. # Make best effort attempt to get searchlist from the registry. my @root = qw(HKEY_LOCAL_MACHINE SYSTEM CurrentControlSet Services); my $leaf = join '\\', @root, qw(Tcpip Parameters); my $reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} ); unless ( defined $reg_tcpip ) { # Didn't work, Win95/98/Me? $leaf = join '\\', @root, qw(VxD MSTCP); $reg_tcpip = $Registry->Open( $leaf, {Access => KEY_READ} ); } if ( defined $reg_tcpip ) { my $searchlist = $reg_tcpip->GetValue('SearchList') || ''; push @searchlist, split m/[\s,]+/, $searchlist; my ( $value, $type ) = $reg_tcpip->GetValue('UseDomainNameDevolution'); $devolution = defined $value && $type == REG_DWORD ? hex $value : 0; } } # fix devolution if configured, and simultaneously # eliminate duplicate entries (but keep the order) my @list; my %seen; foreach (@searchlist) { s/\.+$//; push( @list, $_ ) unless $seen{lc $_}++; next unless $devolution; # while there are more than two labels, cut while (s#^[^.]+\.(.+\..+)$#$1#) { push( @list, $_ ) unless $seen{lc $_}++; } } $defaults->searchlist(@list); %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); $defaults->_read_env; return; } 1; __END__ =head1 SYNOPSIS use Net::DNS::Resolver; =head1 DESCRIPTION This class implements the OS specific portions of C. No user serviceable parts inside, see L for all your resolving needs. =head1 COPYRIGHT Copyright (c)2003 Chris Reinhardt. Portions Copyright (c)2009 Olaf Kolkman, NLnet Labs All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut DNS/RR.pm000044400000053534152345050350006063 0ustar00package Net::DNS::RR; use strict; use warnings; our $VERSION = (qw$Id: RR.pm 2003 2025-01-21 12:06:06Z willem $)[2]; =head1 NAME Net::DNS::RR - DNS resource record base class =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('example.com IN AAAA 2001:DB8::1'); $rr = Net::DNS::RR->new( owner => 'example.com', type => 'AAAA', address => '2001:DB8::1' ); =head1 DESCRIPTION Net::DNS::RR is the base class for DNS Resource Record (RR) objects. See also the manual pages for each specific RR type. =cut use integer; use Carp; use constant LIB => grep { $_ ne '.' } grep { !ref($_) } @INC; use Net::DNS::Parameters qw(%classbyname :class :type); use Net::DNS::DomainName; =head1 METHODS B Do not assume the RR objects you receive from a query are of a particular type. You must always check the object type before calling any of its methods. If you call an unknown method, you will get an error message and execution will be terminated. =cut sub new { my ( $class, @list ) = @_; my $rr = eval { local $SIG{__DIE__}; scalar @list > 1 ? &_new_hash : &_new_string; }; return $rr if $rr; my @param = map { defined($_) ? split /\s+/ : 'undef' } @list; my $stmnt = substr "$class->new( @param )", 0, 80; croak "${@}in $stmnt\n"; } =head2 new (from string) $aaaa = Net::DNS::RR->new('host.example.com. 86400 AAAA 2001:DB8::1'); $mx = Net::DNS::RR->new('example.com. 7200 MX 10 mailhost.example.com.'); $cname = Net::DNS::RR->new('www.example.com 300 IN CNAME host.example.com'); $txt = Net::DNS::RR->new('txt.example.com 3600 HS TXT "text data"'); Returns an object of the appropriate RR type, or a L object if the type is not implemented. The attribute values are extracted from the string passed by the user. The syntax of the argument string follows the RFC1035 specification for zone files, and is compatible with the result returned by the string method. The owner and RR type are required; all other information is optional. Omitting the optional fields is useful for creating the empty RDATA sections required for certain dynamic update operations. See the L manual page for additional examples. All names are interpreted as fully qualified domain names. The trailing dot (.) is optional. =cut my $PARSE_REGEX = q/("[^"]*")|;[^\n]*|[ \t\n\r\f()]+/; # NB: *not* \s (matches Unicode white space) sub _new_string { my ( $base, $string ) = @_; die 'argument absent or undefined' unless defined $string; die 'non-scalar argument' if ref $string; # parse into quoted strings, contiguous non-whitespace and (discarded) comments local $_ = $string; s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon my ( $owner, @token ) = grep { defined && length } split /$PARSE_REGEX/o; die 'unable to parse RR string' unless scalar @token; my $t1 = $token[0]; my $t2 = $token[1]; my ( $ttl, $class ); if ( not defined $t2 ) { # @token = ('ANY') if $classbyname{uc $t1}; # } elsif ( $t1 =~ /^\d/ ) { $ttl = shift @token; # [] $class = shift @token if $classbyname{uc $t2} || $t2 =~ /^CLASS\d/i; } elsif ( $classbyname{uc $t1} || $t1 =~ /^CLASS\d/i ) { $class = shift @token; # [] $ttl = shift @token if $t2 =~ /^\d/; } my $type = shift(@token); my $populated = scalar @token; my $self = $base->_subclass( $type, $populated ); # create RR object $self->owner($owner); &class( $self, $class ); # specify CLASS &ttl( $self, $ttl ); # specify TTL return $self unless $populated; # empty RR if ( $#token && $token[0] =~ /^[\\]?#$/ ) { shift @token; # RFC3597 hexadecimal format my $rdlen = shift(@token) || 0; my $rdata = pack 'H*', join( '', @token ); die 'length and hexadecimal data inconsistent' unless $rdlen == length $rdata; $self->rdata($rdata); # unpack RDATA } else { $self->_parse_rdata(@token); # parse arguments } $self->_post_parse(); return $self; } =head2 new (from hash) $rr = Net::DNS::RR->new(%hash); $rr = Net::DNS::RR->new( owner => 'host.example.com', ttl => 86400, class => 'IN', type => 'AAAA', address => '2001:DB8::1' ); $rr = Net::DNS::RR->new( owner => 'txt.example.com', type => 'TXT', txtdata => [ 'one', 'two' ] ); Returns an object of the appropriate RR type, or a L object if the type is not implemented. Consult the relevant manual pages for the usage of type specific attributes. The owner and RR type are required; all other information is optional. Omitting optional attributes is useful for creating the empty RDATA sections required for certain dynamic update operations. =cut my @core = qw(owner name type class ttl rdlength); sub _new_hash { my $base = shift; my %attribute = ( owner => '.', type => 'NULL' ); while ( my $key = shift ) { $attribute{lc $key} = shift; } my ( $owner, $name, $type, $class, $ttl ) = delete @attribute{@core}; my $self = $base->_subclass( $type, scalar(%attribute) ); $self->owner( $name ? $name : $owner ); $self->class($class) if defined $class; # optional CLASS $self->ttl($ttl) if defined $ttl; # optional TTL eval { while ( my ( $attribute, $value ) = each %attribute ) { $self->$attribute( ref($value) eq 'ARRAY' ? @$value : $value ); } }; die ref($self) eq __PACKAGE__ ? "type $type not implemented" : () if $@; $self->_post_parse(); return $self; } =head2 decode ( $rr, $next ) = Net::DNS::RR->decode( \$data, $offset, @opaque ); Decodes a DNS resource record at the specified location within a DNS packet. The argument list consists of a reference to the buffer containing the packet data and offset indicating where resource record begins. Any remaining arguments are passed as opaque data to subordinate decoders and do not form part of the published interface. Returns a C object and the offset of the next record in the packet. An exception is raised if the data buffer contains insufficient or corrupt data. =cut use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4; sub decode { my ( $base, @argument ) = @_; my ( $owner, $fixed ) = Net::DNS::DomainName1035->decode(@argument); my $index = $fixed + RRFIXEDSZ; my ( $data, $offset, @opaque ) = @argument; die 'corrupt wire-format data' if length $$data < $index; my $self = $base->_subclass( unpack "\@$fixed n", $$data ); $self->{owner} = $owner; @{$self}{qw(class ttl rdlength)} = unpack "\@$fixed x2 n N n", $$data; my $next = $index + $self->{rdlength}; die 'corrupt wire-format data' if length $$data < $next; if ( $next > $index or $self->type eq 'OPT' ) { local $self->{offset} = $offset; eval { $self->_decode_rdata( $data, $index, @opaque ) }; warn $@ if $@; } return wantarray ? ( $self, $next ) : $self; } =head2 encode $data = $rr->encode( $offset, @opaque ); Returns the C in binary format suitable for inclusion in a DNS packet buffer. The offset indicates the intended location within the packet data where the C is to be stored. Any remaining arguments are opaque data which are passed intact to subordinate encoders. =cut sub encode { my ( $self, $offset, @opaque ) = @_; ( $offset, @opaque ) = ( 0x4000, {} ) unless defined $offset; my $owner = $self->{owner}->encode( $offset, @opaque ); my ( $type, $class, $ttl ) = @{$self}{qw(type class ttl)}; my $rdata = $self->_empty ? '' : $self->_encode_rdata( $offset + length($owner) + RRFIXEDSZ, @opaque ); return pack 'a* n2 N n a*', $owner, $type, $class || 1, $ttl || 0, length $rdata, $rdata; } =head2 canonical $data = $rr->canonical; Returns the C in canonical binary format suitable for DNSSEC signature validation. The absence of the associative array argument signals to subordinate encoders that the canonical uncompressed form of embedded domain names is to be used. =cut sub canonical { my $self = shift; my $owner = $self->{owner}->canonical; my ( $type, $class, $ttl ) = @{$self}{qw(type class ttl)}; my $rdata = $self->_empty ? '' : $self->_encode_rdata( length($owner) + RRFIXEDSZ ); return pack 'a* n2 N n a*', $owner, $type, $class || 1, $ttl || 0, length $rdata, $rdata; } =head2 print $rr->print; Prints the resource record to the currently selected output filehandle. Calls the string method to get the formatted RR representation. =cut sub print { print shift->string, "\n"; return; } =head2 string print $rr->string, "\n"; Returns a string representation of the RR using the master file format mandated by RFC1035. All domain names are fully qualified with trailing dot. This differs from RR attribute methods, which omit the trailing dot. =cut sub string { my $self = shift; my $name = $self->{owner}->string; my @ttl = grep {defined} $self->{ttl}; my @core = ( $name, @ttl, $self->class, $self->type ); local $SIG{__DIE__}; my $empty = $self->_empty; my @rdata = $empty ? () : eval { $self->_format_rdata }; carp $@ if $@; my $tab = length($name) < 72 ? "\t" : ' '; my @line = _wrap( join( $tab, @core, '(' ), @rdata, ')' ); my $last = pop(@line); # last or only line $last = join $tab, @core, "@rdata" unless scalar(@line); $self->_annotation('no data') if $empty; return join "\n\t", @line, _wrap( $last, map {"; $_"} $self->_annotation ); } =head2 plain $plain = $rr->plain; Returns a simplified single-line representation of the RR. This facilitates interaction with programs like nsupdate which have rudimentary parsers. =cut sub plain { return join ' ', shift->token; } =head2 token @token = $rr->token; Returns a token list representation of the RR zone file string. =cut sub token { my $self = shift; my @ttl = grep {defined} $self->{ttl}; my @core = ( $self->{owner}->string, @ttl, $self->class, $self->type ); # parse into quoted strings, contiguous non-whitespace and (discarded) comments local $_ = $self->_empty ? '' : join( ' ', $self->_format_rdata ); s/\\\\/\\092/g; # disguise escaped escape s/\\"/\\034/g; # disguise escaped quote s/\\\(/\\040/g; # disguise escaped bracket s/\\\)/\\041/g; # disguise escaped bracket s/\\;/\\059/g; # disguise escaped semicolon return ( @core, grep { defined && length } split /$PARSE_REGEX/o ); } =head2 generic $generic = $rr->generic; Returns the generic RR representation defined in RFC3597. This facilitates creation of zone files containing RRs unrecognised by outdated nameservers and provisioning software. =cut sub generic { my $self = shift; my @ttl = grep {defined} $self->{ttl}; my @class = map {"CLASS$_"} grep {defined} $self->{class}; my @core = ( $self->{owner}->string, @ttl, @class, "TYPE$self->{type}" ); my $data = $self->rdata; my @data = ( '\\#', length($data), split /(\S{32})/, unpack 'H*', $data ); my @line = _wrap( "@core (", @data, ')' ); return join "\n\t", @line if scalar(@line) > 1; return join ' ', @core, @data; } =head2 owner name $name = $rr->owner; Returns the owner name of the record. =cut sub owner { my ( $self, @name ) = @_; for (@name) { $self->{owner} = Net::DNS::DomainName1035->new($_) } return defined wantarray ? $self->{owner}->name : undef; } sub name { return &owner; } ## historical =head2 type $type = $rr->type; Returns the record type. =cut sub type { my ( $self, @value ) = @_; for (@value) { croak 'not possible to change RR->type' } return typebyval( $self->{type} ); } =head2 class $class = $rr->class; Resource record class. =cut sub class { my ( $self, $class ) = @_; return $self->{class} = classbyname($class) if defined $class; return defined $self->{class} ? classbyval( $self->{class} ) : 'IN'; } =head2 ttl $ttl = $rr->ttl; $ttl = $rr->ttl(3600); Resource record time to live in seconds. =cut # The following time units are recognised, but are not part of the # published API. These are required for parsing BIND zone files but # should not be used in other contexts. my %unit = ( W => 604800, D => 86400, H => 3600, M => 60, S => 1 ); sub ttl { my ( $self, $time ) = @_; return $self->{ttl} || 0 unless defined $time; # avoid defining rr->{ttl} my $ttl = 0; my %time = reverse split /(\D)\D*/, $time . 'S'; while ( my ( $u, $t ) = each %time ) { my $scale = $unit{uc $u} || die qq(bad time: $t$u); $ttl += $t * $scale; } return $self->{ttl} = $ttl; } ################################################################################ ## ## Default implementation for unknown RR type ## ################################################################################ sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; return $self->{rdata} = substr $$data, $offset, $self->{rdlength}; } sub _encode_rdata { ## encode rdata as wire-format octet string return shift->{rdata}; } sub _format_rdata { ## format rdata portion of RR string my $rdata = shift->rdata; # RFC3597 unknown RR format return ( '\\#', length($rdata), split /(\S{32})/, unpack 'H*', $rdata ); } sub _parse_rdata { ## parse RR attributes in argument list my $self = shift; die join ' ', 'type', $self->type, 'not implemented' if ref($self) eq __PACKAGE__; die join ' ', 'no zone file representation defined for', $self->type; } sub _post_parse { } ## parser post processing sub _defaults { } ## set attribute default values sub dump { ## print internal data structure my @data = @_; # uncoverable pod require Data::Dumper; local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 6; local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; local $Data::Dumper::Useqq = $Data::Dumper::Useqq || 1; return print Data::Dumper::Dumper(@data); } sub rdatastr { ## historical RR subtype method my $self = shift; # uncoverable pod $self->_deprecate('prefer $rr->rdstring()'); return $self->rdstring; } =head2 rdata $rr = Net::DNS::RR->new( type => NULL, rdata => 'arbitrary' ); Resource record data section when viewed as opaque octets. =cut sub rdata { my $self = shift; return $self->_empty ? '' : eval { $self->_encode_rdata( 0x4000, {} ) } unless @_; my $data = shift || ''; $self->_decode_rdata( \$data, 0 ) if ( $self->{rdlength} = length $data ); return; } =head2 rdstring $rdstring = $rr->rdstring; Returns a string representation of the RR-specific data. =cut sub rdstring { my $self = shift; local $SIG{__DIE__}; my @rdata = $self->_empty ? () : eval { $self->_format_rdata }; carp $@ if $@; return join "\n\t", _wrap(@rdata); } =head2 rdlength $rdlength = $rr->rdlength; Returns the uncompressed length of the encoded RR-specific data. =cut sub rdlength { return length shift->rdata; } ################################################################################### =head1 Sorting of RR arrays Sorting of RR arrays is done by Net::DNS::rrsort(), see documentation for L. This package provides class methods to set the comparator function used for a particular RR based on its attributes. =head2 set_rrsort_func my $function = sub { ## numerically ascending order $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; Net::DNS::RR::MX->set_rrsort_func( 'preference', $function ); Net::DNS::RR::MX->set_rrsort_func( 'default_sort', $function ); set_rrsort_func() must be called as a class method. The first argument is the attribute name on which the sorting is to take place. If you specify "default_sort" then that is the sort algorithm that will be used when get_rrsort_func() is called without an RR attribute as argument. The second argument is a reference to a comparator function that uses the global variables $a and $b in the Net::DNS package. During sorting, the variables $a and $b will contain references to objects of the class whose set_rrsort_func() was called. The above sorting function will only be applied to Net::DNS::RR::MX objects. The above example is the sorting function implemented in MX. =cut our %rrsortfunct; sub set_rrsort_func { my $class = shift; my $attribute = shift; my $function = shift; my ($type) = $class =~ m/::([^:]+)$/; $rrsortfunct{$type}{$attribute} = $function; return; } =head2 get_rrsort_func $function = Net::DNS::RR::MX->get_rrsort_func('preference'); $function = Net::DNS::RR::MX->get_rrsort_func(); get_rrsort_func() returns a reference to the comparator function. =cut my $default = sub { return $Net::DNS::a->canonical() cmp $Net::DNS::b->canonical(); }; sub get_rrsort_func { my $class = shift; my $attribute = shift || 'default_sort'; my ($type) = $class =~ m/::([^:]+)$/; return $rrsortfunct{$type}{$attribute} || return $default; } ################################################################################ # # Net::DNS::RR->_subclass($rrname) # Net::DNS::RR->_subclass($rrname, $default) # # Create a new object blessed into appropriate RR subclass, after # loading the subclass module (if necessary). A subclass with no # corresponding module will be regarded as unknown and blessed # into the RR base class. # # The optional second argument indicates that default values are # to be copied into the newly created object. our %_MINIMAL = ( 255 => bless ['type' => 255], __PACKAGE__ ); our %_LOADED = %_MINIMAL; sub _subclass { my ( $class, $rrname, $default ) = @_; unless ( $_LOADED{$rrname} ) { my $rrtype = typebyname($rrname); unless ( $_LOADED{$rrtype} ) { # load once only local @INC = LIB; my $identifier = typebyval($rrtype); $identifier =~ s/\W/_/g; # kosher Perl identifier my $subclass = join '::', __PACKAGE__, $identifier; unless ( eval "require $subclass" ) { ## no critic ProhibitStringyEval my $perl = Net::DNS::Parameters::_typespec("$rrtype.RRTYPE"); $subclass = join '::', __PACKAGE__, "TYPE$rrtype"; push @INC, sub { # see perldoc -f require my @line = split /\n/, $perl; return ( sub { defined( $_ = shift @line ) } ); }; eval "require $subclass"; ## no critic ProhibitStringyEval } $subclass = __PACKAGE__ if $@; # cache pre-built minimal and populated default object images my @base = ( 'type' => $rrtype ); $_MINIMAL{$rrtype} = bless [@base], $subclass; my $object = bless {@base}, $subclass; $object->_defaults; $_LOADED{$rrtype} = bless [%$object], $subclass; } $_MINIMAL{$rrname} = $_MINIMAL{$rrtype}; $_LOADED{$rrname} = $_LOADED{$rrtype}; } my $prebuilt = $default ? $_LOADED{$rrname} : $_MINIMAL{$rrname}; return bless {@$prebuilt}, ref($prebuilt); # create object } sub _annotation { my ( $self, @note ) = @_; $self->{annotation} = ["@note"] if scalar @note; return wantarray ? @{$self->{annotation} || []} : (); } my %warned; sub _deprecate { my ( undef, @note ) = @_; carp "deprecated method; @note" unless $warned{"@note"}++; return; } my %ignore = map { ( $_ => 1 ) } @core, 'annotation', '#'; sub _empty { my $self = shift; return not( $self->{'#'} ||= scalar grep { !$ignore{$_} } keys %$self ); } sub _wrap { my @text = @_; my $cols = 80; my $coln = 0; my ( @line, @fill ); foreach (@text) { $coln += ( length || next ) + 1; if ( $coln > $cols ) { # start new line push( @line, join ' ', @fill ) if @fill; $coln = length; @fill = (); } $coln = $cols if chomp; # force line break push( @fill, $_ ) if length; } return ( @line, join ' ', @fill ); } ################################################################################ sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) ## no critic sub AUTOLOAD { ## Default method my ($self) = @_; no strict 'refs'; ## no critic ProhibitNoStrict our $AUTOLOAD; my ($method) = reverse split /::/, $AUTOLOAD; for ( my $action = $method ) { ## tolerate mixed-case attribute name tr [A-Z-] [a-z_]; if ( $self->can($action) ) { *{$AUTOLOAD} = sub { shift->$action(@_) }; return &$AUTOLOAD; } } my $oref = ref($self); *{$AUTOLOAD} = sub { }; ## suppress deep recursion croak qq[$self has no class method "$method"] unless $oref; my $string = $self->string; my @object = grep { defined($_) } $oref, $oref->VERSION; my $module = join '::', __PACKAGE__, $self->type; eval("require $module") if $oref eq __PACKAGE__; ## no critic ProhibitStringyEval @_ = ( <<"END" ); *** FATAL PROGRAM ERROR!! Unknown instance method "$method" *** which the program has attempted to call for the object: *** $string *** *** THIS IS A BUG IN THE CALLING SOFTWARE, which incorrectly assumes *** that the object would be of a particular type. The type of an *** object should be checked before calling any of its methods. *** @object $@ END goto &Carp::confess; } 1; __END__ =head1 COPYRIGHT Copyright (c)1997-2001 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2005-2007 Olaf Kolkman. Portions Copyright (c)2007,2012 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L =cut DNS/Text.pm000044400000017134152345050350006460 0ustar00package Net::DNS::Text; use strict; use warnings; our $VERSION = (qw$Id: Text.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Text - DNS text representation =head1 SYNOPSIS use Net::DNS::Text; $object = Net::DNS::Text->new('example'); $string = $object->string; $object = Net::DNS::Text->decode( \$data, $offset ); ( $object, $next ) = Net::DNS::Text->decode( \$data, $offset ); $data = $object->encode; $text = $object->value; =head1 DESCRIPTION The C module implements a class of text objects with associated class and instance methods. Each text object instance has a fixed identity throughout its lifetime. =cut use integer; use Carp; use constant ASCII => ref eval { require Encode; Encode::find_encoding('ascii'); }; use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6] Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' ); }; =head1 METHODS =head2 new $object = Net::DNS::Text->new('example'); Creates a text object which encapsulates a single character string component of a resource record. Arbitrary single-byte characters can be represented by \ followed by exactly three decimal digits. Such characters are devoid of any special meaning. A character preceded by \ represents itself, without any special interpretation. =cut my ( %escape, %escapeUTF8, %unescape ); ## precalculated escape tables sub new { my $self = bless [], shift; local $_ = &_encode_utf8; s/^\042(.*)\042$/$1/s; # strip paired quotes s/\134([\060-\071]{3})/$unescape{$1}/eg; # restore numeric escapes s/\134([^\134])/$1/g; # restore character escapes s/\134\134/\134/g; # restore escaped escapes while ( length $_ > 255 ) { my $chunk = substr( $_, 0, 255 ); # carve into chunks $chunk =~ s/[\300-\377][\200-\277]*$//; push @$self, $chunk; substr( $_, 0, length $chunk ) = ''; } push @$self, $_; return $self; } =head2 decode $object = Net::DNS::Text->decode( \$buffer, $offset ); ( $object, $next ) = Net::DNS::Text->decode( \$buffer, $offset ); Creates a text object which represents the decoded data at the indicated offset within the data buffer. The argument list consists of a reference to a scalar containing the wire-format data and offset of the text data. The returned offset value indicates the start of the next item in the data buffer. =cut sub decode { my $class = shift; my $buffer = shift; # reference to data buffer my $offset = shift || 0; # offset within buffer my $size = shift; # specify size of unbounded text unless ( defined $size ) { $size = unpack "\@$offset C", $$buffer; $offset++; } my $next = $offset + $size; croak 'corrupt wire-format data' if $next > length $$buffer; my $self = bless [unpack( "\@$offset a$size", $$buffer )], $class; return wantarray ? ( $self, $next ) : $self; } =head2 encode $data = $object->encode; Returns the wire-format encoded representation of the text object suitable for inclusion in a DNS packet buffer. =cut sub encode { my $self = shift; return join '', map { pack( 'C a*', length $_, $_ ) } @$self; } =head2 raw $data = $object->raw; Returns the wire-format encoded representation of the text object without the explicit length field. =cut sub raw { my $self = shift; return join '', map { pack( 'a*', $_ ) } @$self; } =head2 value $value = $text->value; Character string representation of the text object. =cut sub value { return unless defined wantarray; my $self = shift; return _decode_utf8( join '', @$self ); } =head2 string $string = $text->string; Conditionally quoted RFC1035 zone file representation of the text object. =cut sub string { my $self = shift; my @s = map { split '', $_ } @$self; # escape special and ASCII non-printable my $s = _decode_utf8( join '', map { $escape{$_} } @s ); return $s =~ /[ \t\n\r\f(),;]|^$/ ? qq("$s") : $s; # quote special characters and empty string } =head2 unicode $string = $text->unicode; Conditionally quoted Unicode representation of the text object. =cut sub unicode { my $self = shift; my @s = map { split '', $_ } @$self; # escape special and non-printable my $s = _decode_utf8( join '', map { $escapeUTF8{$_} } @s ); return $s =~ /[ \t\n\r\f();]|^$/ ? qq("$s") : $s; # quote special characters and empty string } ######################################## # perlcc: address of encoding objects must be determined at runtime my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law: my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't. sub _decode_utf8 { ## UTF-8 to perl internal encoding local $_ = shift; # partial transliteration for non-ASCII character encodings tr [\040-\176\000-\377] [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->decode($_), $z ) : $_; } sub _encode_utf8 { ## perl internal encoding to UTF-8 local $_ = shift; croak 'argument undefined' unless defined $_; # partial transliteration for non-ASCII character encodings tr [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~] [\040-\176] unless ASCII; my $z = length($_) - length($_); # pre-5.18 taint workaround return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; } %escape = eval { ## precalculated ASCII escape table my %table = map { ( chr($_) => chr($_) ) } ( 0 .. 127 ); foreach my $n ( 0 .. 31, 34, 92, 127 .. 255 ) { # numerical escape my $codepoint = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $codepoint =~ tr [0-9] [\060-\071]; $table{chr($n)} = pack 'C a3', 92, $codepoint; } return %table; }; %escapeUTF8 = eval { ## precalculated UTF-8 escape table my @octet = UTF8 ? ( 128 .. 191, 194 .. 254 ) : (); return ( %escape, map { ( chr($_) => chr($_) ) } @octet ); }; %unescape = eval { ## precalculated numeric escape table my %table; foreach my $n ( 0 .. 255 ) { my $key = sprintf( '%03u', $n ); # transliteration for non-ASCII character encodings $key =~ tr [0-9] [\060-\071]; $table{$key} = pack 'C', $n; } $table{"\060\071\062"} = pack 'C2', 92, 92; # escaped escape return %table; }; 1; __END__ ######################################## =head1 BUGS Coding strategy is intended to avoid creating unnecessary argument lists and stack frames. This improves efficiency at the expense of code readability. Platform specific character coding features are conditionally compiled into the code. =head1 COPYRIGHT Copyright (c)2009-2011 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/FAQ.pod000044400000002124152345050350006302 0ustar00=head1 NAME Net::DNS::FAQ - Frequently Asked Net::DNS Questions =head1 SYNOPSIS perldoc Net::DNS::FAQ =head1 DESCRIPTION This document serves to answer the most frequently asked questions on both the Net::DNS Mailing List and those sent to the author. The latest version of this FAQ can be found at L =head1 GENERAL =head2 What is Net::DNS? Net::DNS is a perl implementation of a DNS resolver. =head1 INSTALLATION =head2 Where can I find Test::More? Test::More is part of the Test-Simple package, by Michael G Schwern. You should be able to find the distribution at L =head1 USAGE =head2 Why does $resolver->query() return undef when the answer section is empty? The short answer is, do not use query(). $resolver->send() will always return the response packet, as long as a response was received. The longer answer is that query() is modeled after the res_query() function from the libresolv C library, which has similar behavior. =head1 VERSION $Id: FAQ.pod 1709 2018-09-07 08:03:09Z willem $ DNS/Question.pm000044400000021014152345050350007333 0ustar00package Net::DNS::Question; use strict; use warnings; our $VERSION = (qw$Id: Question.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Question - DNS question record =head1 SYNOPSIS use Net::DNS::Question; $question = Net::DNS::Question->new('example.com', 'AAAA', 'IN'); =head1 DESCRIPTION A Net::DNS::Question object represents a record in the question section of a DNS packet. =cut use integer; use Carp; use Net::DNS::Parameters qw(%classbyname %typebyname :class :type); use Net::DNS::Domain; use Net::DNS::DomainName; =head1 METHODS =head2 new $question = Net::DNS::Question->new('example.com', 'AAAA', 'IN'); $question = Net::DNS::Question->new('example.com', 'A', 'IN'); $question = Net::DNS::Question->new('example.com'); $question = Net::DNS::Question->new('2001::DB8::dead:beef', 'PTR', 'IN'); $question = Net::DNS::Question->new('2001::DB8::dead:beef'); Creates a question object from the domain, type, and class passed as arguments. One or both type and class arguments may be omitted and will assume the default values shown above. RFC4291 and RFC4632 IP address/prefix notation is supported for queries in both in-addr.arpa and ip6.arpa namespaces. =cut sub new { my $self = bless {}, shift; my $qname = shift; my $qtype = shift || ''; my $qclass = shift || ''; # tolerate (possibly unknown) type and class in zone file order unless ( exists $classbyname{$qclass} ) { ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $classbyname{$qtype}; ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qtype =~ /CLASS/; } unless ( exists $typebyname{$qtype} ) { ( $qtype, $qclass ) = ( $qclass, $qtype ) if exists $typebyname{$qclass}; ( $qtype, $qclass ) = ( $qclass, $qtype ) if $qclass =~ /TYPE/; } # if argument is an IP address, do appropriate reverse lookup if ( defined $qname and $qname =~ m/:|\d$/ ) { if ( my $reverse = _dns_addr($qname) ) { $qname = $reverse; $qtype ||= 'PTR'; } } $self->{qname} = Net::DNS::DomainName1035->new($qname); $self->{qtype} = typebyname( $qtype || 'A' ); $self->{qclass} = classbyname( $qclass || 'IN' ); return $self; } =head2 decode $question = Net::DNS::Question->decode(\$data, $offset); ($question, $offset) = Net::DNS::Question->decode(\$data, $offset); Decodes the question record at the specified location within a DNS wire-format packet. The first argument is a reference to the buffer containing the packet data. The second argument is the offset of the start of the question record. Returns a Net::DNS::Question object and the offset of the next location in the packet. An exception is raised if the object cannot be created (e.g., corrupt or insufficient data). =cut use constant QFIXEDSZ => length pack 'n2', (0) x 2; sub decode { my ( $class, @argument ) = @_; my ( $data, $offset ) = @argument; my $self = bless {}, $class; ( $self->{qname}, $offset ) = Net::DNS::DomainName1035->decode(@argument); my $next = $offset + QFIXEDSZ; die 'corrupt wire-format data' if length $$data < $next; @{$self}{qw(qtype qclass)} = unpack "\@$offset n2", $$data; return wantarray ? ( $self, $next ) : $self; } =head2 encode $data = $question->encode( $offset, $hash ); Returns the Net::DNS::Question in binary format suitable for inclusion in a DNS packet buffer. The optional arguments are the offset within the packet data where the Net::DNS::Question is to be stored and a reference to a hash table used to index compressed names within the packet. =cut sub encode { my ( $self, @opaque ) = @_; return pack 'a* n2', $self->{qname}->encode(@opaque), @{$self}{qw(qtype qclass)}; } =head2 string print "string = ", $question->string, "\n"; Returns a string representation of the question record. =cut sub string { my $self = shift; return join "\t", $self->{qname}->string, $self->qclass, $self->qtype; } =head2 print $object->print; Prints the record to the standard output. Calls the string() method to get the string representation. =cut sub print { print &string, "\n"; return; } =head2 name $name = $question->name; Internationalised domain name corresponding to the qname attribute. Decoding non-ASCII domain names is computationally expensive and undesirable for names which are likely to be used to construct further queries. When required to communicate with humans, the 'proper' domain name should be extracted from a query or reply packet. $query = Net::DNS::Packet->new( $example, 'SOA' ); $reply = $resolver->send($query) or die; ($question) = $reply->question; $name = $question->name; =cut sub name { my ( $self, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return $self->{qname}->xname; } =head2 qname, zname $qname = $question->qname; $zname = $question->zname; Fully qualified domain name in the form required for a query transmitted to a nameserver. In dynamic update packets, this attribute is known as zname() and refers to the zone name. =cut sub qname { my ( $self, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return $self->{qname}->name; } sub zname { return &qname; } =head2 qtype, ztype, type $qtype = $question->type; $qtype = $question->qtype; $ztype = $question->ztype; Returns the question type attribute. In dynamic update packets, this attribute is known as ztype() and refers to the zone type. =cut sub type { my ( $self, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return typebyval( $self->{qtype} ); } sub qtype { return &type; } sub ztype { return &type; } =head2 qclass, zclass, class $qclass = $question->class; $qclass = $question->qclass; $zclass = $question->zclass; Returns the question class attribute. In dynamic update packets, this attribute is known as zclass() and refers to the zone class. =cut sub class { my ( $self, @argument ) = @_; for (@argument) { croak 'immutable object: argument invalid' } return classbyval( $self->{qclass} ); } sub qclass { return &class; } sub zclass { return &class; } ######################################## sub _dns_addr { ## Map IP address into reverse lookup namespace local $_ = shift; # IP address must contain address characters only s/[%].+$//; # discard RFC4007 scopeid return unless m#^[a-fA-F0-9:./]+$#; my ( $address, $pfxlen ) = split m#/#; # map IPv4 address to in-addr.arpa space if (m#^\d*[.\d]*\d(/\d+)?$#) { my @parse = split /\./, $address; $pfxlen = scalar(@parse) << 3 unless $pfxlen; my $last = $pfxlen > 24 ? 3 : ( $pfxlen - 1 ) >> 3; return join '.', reverse( ( @parse, (0) x 3 )[0 .. $last] ), 'in-addr.arpa.'; } # map IPv6 address to ip6.arpa space return unless m#^[:\w]+:([.\w]*)(/\d+)?$#; my $rhs = $1 || '0'; return _dns_addr($rhs) if m#^[:0]*:0*:[fF]{4}:[^:]+$#; # IPv4 $rhs = sprintf '%x%0.2x:%x%0.2x', map { $_ || 0 } split( /\./, $rhs, 4 ) if /\./; $address =~ s/:[^:]*$/:0$rhs/; my @parse = split /:/, ( reverse "0$address" ), 9; my @xpand = map { /./ ? $_ : ('0') x ( 9 - @parse ) } @parse; # expand :: $pfxlen = ( scalar(@xpand) << 4 ) unless $pfxlen; # implicit length if unspecified my $len = $pfxlen > 124 ? 32 : ( $pfxlen + 3 ) >> 2; my $hex = pack 'A4' x 8, map { $_ . '000' } ('0') x ( 8 - @xpand ), @xpand; return join '.', split( //, substr( $hex, -$len ) ), 'ip6.arpa.'; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2003,2006-2011 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/Resolver.pm000044400000047122152345050350007335 0ustar00package Net::DNS::Resolver; use strict; use warnings; our $VERSION = (qw$Id: Resolver.pm 2009 2025-02-10 13:43:50Z willem $)[2]; =head1 NAME Net::DNS::Resolver - DNS resolver class =cut use base qw(Net::DNS::Resolver::Base); 1; __END__ =head1 SYNOPSIS use Net::DNS; $resolver = Net::DNS::Resolver->new(); # Perform a lookup, using the searchlist if appropriate. $reply = $resolver->search( 'example.com' ); # Perform a lookup, without the searchlist $reply = $resolver->query( 'example.com', 'MX' ); # Perform a lookup, without pre or post-processing $reply = $resolver->send( 'example.com', 'MX', 'IN' ); # Send a prebuilt query packet $query = Net::DNS::Packet->new( ... ); $reply = $resolver->send( $query ); =head1 DESCRIPTION Instances of the Net::DNS::Resolver class represent resolver objects. A program may have multiple resolver objects, each maintaining its own state information such as the nameservers to be queried, whether recursion is desired, etc. =head1 METHODS =head2 new # Use the default configuration $resolver = Net::DNS::Resolver->new(); # Use my own configuration file $resolver = Net::DNS::Resolver->new( config_file => '/my/dns.conf' ); # Set options in the constructor $resolver = Net::DNS::Resolver->new( nameservers => [ '2001:DB8::1', 'ns.example.com' ], recurse => 0, debug => 1 ); Returns a resolver object. If no arguments are supplied, C returns an object having the default configuration. On Unix and Linux systems, the default values are read from the following files, in the order indicated: =over F, F<$HOME/.resolv.conf>, F<./.resolv.conf> =back The following keywords are recognised in resolver configuration files: =over =item B IP address of a name server that the resolver should query. =item B The domain suffix to be appended to a short non-absolute name. =item B A space-separated list of domains in the desired search path. =item B A space-separated list of key:value items. =back Except for F, files will only be read if owned by the effective userid running the program. In addition, several environment variables may contain configuration information; see L. Note that the domain and searchlist keywords are mutually exclusive. If both are present, the resulting behaviour is unspecified. If neither is present, the domain is determined from the local hostname. On Windows systems, an attempt is made to determine the system defaults using the registry. Systems with many dynamically configured network interfaces may confuse L. If a custom configuration file is specified at first instantiation, all other configuration files and environment variables are ignored. Explicit arguments to C override the corresponding configuration variables. The argument list consists of a sequence of (name=>value) pairs, each interpreted as an invocation of the corresponding method. =head2 print $resolver->print; Prints the resolver state on the standard output. =head2 query $packet = $resolver->query( 'host' ); $packet = $resolver->query( 'host.example.com' ); $packet = $resolver->query( '2001:DB8::1' ); $packet = $resolver->query( 'example.com', 'MX' ); $packet = $resolver->query( 'annotation.example.com', 'TXT', 'IN' ); Performs a DNS query for the given name; the search list is not applied. If C is true, the default domain will be appended to unqualified names. The record type and class can be omitted; they default to A and IN. If the name looks like an IP address (IPv4 or IPv6), then a query within in-addr.arpa or ip6.arpa will be performed. Returns a L object, or C if no answers were found. The reason for failure may be determined using C. If you need to examine the response packet, whether it contains any answers or not, use the C method instead. =head2 search $packet = $resolver->search( 'host' ); $packet = $resolver->search( 'host.example.com' ); $packet = $resolver->search( '2001:DB8::1' ); $packet = $resolver->search( 'example.com', 'MX' ); $packet = $resolver->search( 'annotation.example.com', 'TXT', 'IN' ); Performs a DNS query for the given name, applying the searchlist if appropriate. The search algorithm is as follows: If the name contains one or more non-terminal dots, perform an initial query using the unmodified name. If the number of dots is less than C, and there is no terminal dot, try appending each suffix in the search list. The record type and class can be omitted; they default to A and IN. If the name looks like an IP address (IPv4 or IPv6), then a query within in-addr.arpa or ip6.arpa will be performed. Returns a L object, or C if no answers were found. The reason for failure may be determined using C. If you need to examine the response packet, whether it contains any answers or not, use the C method instead. =head2 send $packet = $resolver->send( $query ); $packet = $resolver->send( 'host.example.com' ); $packet = $resolver->send( '2001:DB8::1' ); $packet = $resolver->send( 'example.com', 'MX' ); $packet = $resolver->send( 'annotation.example.com', 'TXT', 'IN' ); Performs a DNS query for the given name. Neither the searchlist nor the default domain will be appended. The argument list can be either a pre-built query L or a list of strings. The record type and class can be omitted; they default to A and IN. If the name looks like an IP address (IPv4 or IPv6), then a query within in-addr.arpa or ip6.arpa will be performed. Returns a L object whether there were any answers or not. Use C<< $packet->header->ancount >> or C<< $packet->answer >> to find out if there were any records in the answer section. Returns C if no response was received. =head2 axfr @zone = $resolver->axfr(); @zone = $resolver->axfr( 'example.com' ); @zone = $resolver->axfr( 'example.com', 'IN' ); $iterator = $resolver->axfr(); $iterator = $resolver->axfr( 'example.com' ); $iterator = $resolver->axfr( 'example.com', 'IN' ); $rr = $iterator->(); Performs a zone transfer using the resolver nameservers list, attempted in the order listed. If the zone is omitted, it defaults to the first zone listed in the resolver search list. If the class is omitted, it defaults to IN. When called in list context, C returns a list of L objects. The redundant SOA record that terminates the zone transfer is not returned to the caller. In deferrence to RFC1035(6.3), a complete zone transfer is expected to return all records in the zone or nothing at all. When no resource records are returned by C, the reason for failure may be determined using C. Here is an example that uses a timeout and TSIG verification: $resolver->tcp_timeout( 10 ); $resolver->tsig( $keyfile ); @zone = $resolver->axfr( 'example.com' ); foreach $rr (@zone) { $rr->print; } When called in scalar context, C returns an iterator object. Each invocation of the iterator returns a single L or C when the zone is exhausted. An exception is raised if the zone transfer can not be completed. The redundant SOA record that terminates the zone transfer is not returned to the caller. Here is the example above, implemented using an iterator: $resolver->tcp_timeout( 10 ); $resolver->tsig( $keyfile ); $iterator = $resolver->axfr( 'example.com' ); while ( $rr = $iterator->() ) { $rr->print; } =head2 bgsend $handle = $resolver->bgsend( $packet ) || die $resolver->errorstring; $handle = $resolver->bgsend( 'host.example.com' ); $handle = $resolver->bgsend( '2001:DB8::1' ); $handle = $resolver->bgsend( 'example.com', 'MX' ); $handle = $resolver->bgsend( 'annotation.example.com', 'TXT', 'IN' ); Performs a background DNS query for the given name and returns immediately without waiting for the response. The program can then perform other tasks while awaiting the response from the nameserver. The argument list can be either a L object or a list of strings. The record type and class can be omitted; they default to A and IN. If the name looks like an IP address (IPv4 or IPv6), then a query within in-addr.arpa or ip6.arpa will be performed. Returns an opaque handle which is passed to subsequent invocations of the C and C methods. Errors are indicated by returning C in which case the reason for failure may be determined using C. The response L object is obtained by calling C. B: Programs should make no assumptions about the nature of the handles returned by C which should be used strictly as described here. =head2 bgread $handle = $resolver->bgsend( 'www.example.com' ); $packet = $resolver->bgread($handle); Reads the response following a background query. The argument is the handle returned by C. Returns a L object or C if no response was received before the timeout interval expired. =head2 bgbusy $handle = $resolver->bgsend( 'foo.example.com' ); while ($resolver->bgbusy($handle)) { ... } $packet = $resolver->bgread($handle); Returns true while awaiting the response or for the transaction to time out. The argument is the handle returned by C. Truncated UDP packets will be retried transparently using TCP while continuing to assert busy to the caller. =head2 debug print 'debug flag: ', $resolver->debug, "\n"; $resolver->debug(1); Get or set the debug flag. If set, calls to C, C, and C will print debugging information on the standard output. The default is false. =head2 defnames print 'defnames flag: ', $resolver->defnames, "\n"; $resolver->defnames(0); Get or set the defnames flag. If true, calls to C will append the default domain to resolve names that are not fully qualified. The default is true. =head2 dnsrch print 'dnsrch flag: ', $resolver->dnsrch, "\n"; $resolver->dnsrch(0); Get or set the dnsrch flag. If true, calls to C will apply the search list to resolve names that are not fully qualified. The default is true. =head2 domain $domain = $resolver->domain; $resolver->domain( 'domain.example' ); Gets or sets the resolver default domain. =head2 igntc print 'igntc flag: ', $resolver->igntc, "\n"; $resolver->igntc(1); Get or set the igntc flag. If true, truncated packets will be ignored. If false, the query will be retried using TCP. The default is false. =head2 nameserver, nameservers @nameservers = $resolver->nameservers(); $resolver->nameservers( '2001:DB8::1', '192.0.2.1' ); $resolver->nameservers( 'ns.domain.example.' ); Gets or sets the nameservers to be queried. Also see the IPv6 transport notes below =head2 persistent_tcp print 'Persistent TCP flag: ', $resolver->persistent_tcp, "\n"; $resolver->persistent_tcp(1); Get or set the persistent TCP setting. If true, L will keep a TCP socket open for each host:port to which it connects. This is useful if you are using TCP and need to make a lot of queries or updates to the same nameserver. The default is false unless you are running a SOCKSified Perl, in which case the default is true. =head2 persistent_udp print 'Persistent UDP flag: ', $resolver->persistent_udp, "\n"; $resolver->persistent_udp(1); Get or set the persistent UDP setting. If true, a L resolver will use the same UDP socket for all queries within each address family. This avoids the cost of creating and tearing down UDP sockets, but also defeats source port randomisation. =head2 port print 'sending queries to port ', $resolver->port, "\n"; $resolver->port(9732); Gets or sets the port to which queries are sent. Convenient for nameserver testing using a non-standard port. The default is port 53. =head2 recurse print 'recursion flag: ', $resolver->recurse, "\n"; $resolver->recurse(0); Get or set the recursion flag. If true, this will direct nameservers to perform a recursive query. The default is true. =head2 retrans print 'retrans interval: ', $resolver->retrans, "\n"; $resolver->retrans(3); Get or set the retransmission interval The default is 5 seconds. =head2 retry print 'number of tries: ', $resolver->retry, "\n"; $resolver->retry(2); Get or set the number of times to try the query. The default is 4. =head2 searchlist @searchlist = $resolver->searchlist; $resolver->searchlist( 'a.example', 'b.example', 'c.example' ); Gets or sets the resolver search list. =head2 srcaddr $resolver->srcaddr('2001::DB8::1'); Sets the source address from which queries are sent. Convenient for forcing queries from a specific interface on a multi-homed host. The default is to use any local address. =head2 srcport $resolver->srcport(5353); Sets the port from which queries are sent. The default is 0, meaning any port. =head2 tcp_timeout print 'TCP timeout: ', $resolver->tcp_timeout, "\n"; $resolver->tcp_timeout(10); Get or set the TCP timeout in seconds. The default is 120 seconds (2 minutes). =head2 udp_timeout print 'UDP timeout: ', $resolver->udp_timeout, "\n"; $resolver->udp_timeout(10); Get or set the bgsend() UDP timeout in seconds. The default is 30 seconds. =head2 udppacketsize print "udppacketsize: ", $resolver->udppacketsize, "\n"; $resolver->udppacketsize(2048); Get or set the UDP packet size. If set to a value not less than the default DNS packet size, an EDNS extension will be added indicating support for large UDP datagrams. =head2 usevc print 'usevc flag: ', $resolver->usevc, "\n"; $resolver->usevc(1); Get or set the usevc flag. If true, queries will be performed using virtual circuits (TCP) instead of datagrams (UDP). The default is false. =head2 replyfrom print 'last response was from: ', $resolver->replyfrom, "\n"; Returns the IP address from which the most recent packet was received in response to a query. =head2 errorstring print 'query status: ', $resolver->errorstring, "\n"; Returns a string containing error information from the most recent DNS protocol interaction. C is meaningful only when interrogated immediately after the corresponding method call. =head2 dnssec print "dnssec flag: ", $resolver->dnssec, "\n"; $resolver->dnssec(0); The dnssec flag causes the resolver to transmit DNSSEC queries and to add a EDNS0 record as required by RFC2671 and RFC3225. The actions of, and response from, the remote nameserver is determined by the settings of the AD and CD flags. Calling the C method with a non-zero value will also set the UDP packet size to the default value of 2048. If that is too small or too big for your environment, you should call the C method immediately after. $resolver->dnssec(1); $resolver->udppacketsize(1250); # adjust UDP packet size A fatal exception will be raised if the C method is called but the L library has not been installed. =head2 adflag $resolver->dnssec(1); $resolver->adflag(1); print "authentication desired flag: ", $resolver->adflag, "\n"; Gets or sets the AD bit for dnssec queries. This bit indicates that the caller is interested in the returned AD (authentic data) bit but does not require any dnssec RRs to be included in the response. The default value is false. =head2 cdflag $resolver->dnssec(1); $resolver->cdflag(1); print "checking disabled flag: ", $resolver->cdflag, "\n"; Gets or sets the CD bit for dnssec queries. This bit indicates that authentication by upstream nameservers should be suppressed. Any dnssec RRs required to execute the authentication procedure should be included in the response. The default value is false. =head2 tsig $resolver->tsig( $keyfile ); $resolver->tsig( $keyfile, fudge => 60 ); $resolver->tsig( $tsig_rr ); $resolver->tsig( undef ); Set the TSIG record used to automatically sign outgoing queries, zone transfers and updates. Automatic signing is disabled if called with undefined arguments. The default resolver behaviour is not to sign any packets. You must call this method to set the key if you would like the resolver to sign and verify packets automatically. Packets can also be signed manually; see the L and L manual pages for examples. TSIG records in manually-signed packets take precedence over those that the resolver would add automatically. =head1 ENVIRONMENT The following environment variables can also be used to configure the resolver: =head2 RES_NAMESERVERS # Bourne Shell RES_NAMESERVERS="2001:DB8::1 192.0.2.1" export RES_NAMESERVERS # C Shell setenv RES_NAMESERVERS "2001:DB8::1 192.0.2.1" A space-separated list of nameservers to query. =head2 RES_SEARCHLIST # Bourne Shell RES_SEARCHLIST="a.example.com b.example.com c.example.com" export RES_SEARCHLIST # C Shell setenv RES_SEARCHLIST "a.example.com b.example.com c.example.com" A space-separated list of domains to put in the search list. =head2 LOCALDOMAIN # Bourne Shell LOCALDOMAIN=example.com export LOCALDOMAIN # C Shell setenv LOCALDOMAIN example.com The default domain. =head2 RES_OPTIONS # Bourne Shell RES_OPTIONS="retrans:3 retry:2 inet6" export RES_OPTIONS # C Shell setenv RES_OPTIONS "retrans:3 retry:2 inet6" A space-separated list of resolver options to set. Options that take values are specified as C. =head1 IPv4 TRANSPORT The C, C, C, and C methods with non-zero argument may be used to configure transport selection. The behaviour of the C method illustrates the transport selection mechanism. If, for example, IPv4 transport has been forced, the C method will only return IPv4 addresses: $resolver->nameservers( '192.0.2.1', '192.0.2.2', '2001:DB8::3' ); $resolver->force_v4(1); print join ' ', $resolver->nameservers(); will print 192.0.2.1 192.0.2.2 =head1 CUSTOMISED RESOLVERS Net::DNS::Resolver is actually an empty subclass. At compile time a super class is chosen based on the current platform. A side benefit of this allows for easy modification of the methods in Net::DNS::Resolver. You can simply add a method to the namespace! For example, if we wanted to cache lookups: package Net::DNS::Resolver; my %cache; sub send { my ( $self, @q ) = @_; return $cache{"@q"} ||= $self->SUPER::send(@q); } =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002-2004 Chris Reinhardt. Portions Copyright (c)2005 Olaf M. Kolkman, NLnet Labs. Portions Copyright (c)2014,2015 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L =cut DNS/DomainName.pm000044400000016333152345050350007544 0ustar00package Net::DNS::DomainName; use strict; use warnings; our $VERSION = (qw$Id: DomainName.pm 2005 2025-01-28 13:22:10Z willem $)[2]; =head1 NAME Net::DNS::DomainName - DNS name representation =head1 SYNOPSIS use Net::DNS::DomainName; $object = Net::DNS::DomainName->new('example.com'); $name = $object->name; $data = $object->encode; ( $object, $next ) = Net::DNS::DomainName->decode( \$data, $offset ); =head1 DESCRIPTION The Net::DNS::DomainName module implements the concrete representation of DNS domain names used within DNS packets. Net::DNS::DomainName defines methods for encoding and decoding wire format octet strings. All other behaviour is inherited from Net::DNS::Domain. The Net::DNS::DomainName1035 and Net::DNS::DomainName2535 packages implement disjoint domain name subtypes which provide the name compression and canonicalisation specified by RFC1035 and RFC2535. These are necessary to meet the backward compatibility requirements introduced by RFC3597. =cut use base qw(Net::DNS::Domain); use integer; use Carp; =head1 METHODS =head2 new $object = Net::DNS::DomainName->new('example.com'); Creates a domain name object which identifies the domain specified by the character string argument. =head2 decode $object = Net::DNS::DomainName->decode( \$buffer, $offset, $hash ); ( $object, $next ) = Net::DNS::DomainName->decode( \$buffer, $offset, $hash ); Creates a domain name object which represents the DNS domain name identified by the wire-format data at the indicated offset within the data buffer. The argument list consists of a reference to a scalar containing the wire-format data and specified offset. The optional reference to a hash table provides improved efficiency of decoding compressed names by exploiting already cached compression pointers. The returned offset value indicates the start of the next item in the data buffer. =cut sub decode { my $label = []; my $self = bless {label => $label}, shift; my $buffer = shift; # reference to data buffer my $offset = shift || 0; # offset within buffer my $linked = shift; # caller's compression index my $cache = $linked; $cache->{$offset} = $self; # hashed objectref by offset my $buflen = length $$buffer; my $index = $offset; while ( $index < $buflen ) { my $header = unpack( "\@$index C", $$buffer ) || return wantarray ? ( $self, ++$index ) : $self; if ( $header < 0x40 ) { # non-terminal label push @$label, substr( $$buffer, ++$index, $header ); $index += $header; } elsif ( $header < 0xC0 ) { # deprecated extended label types croak 'unimplemented label type'; } else { # compression pointer my $link = 0x3FFF & unpack( "\@$index n", $$buffer ); croak 'corrupt compression pointer' unless $link < $offset; croak 'invalid compression pointer' unless $linked; # uncoverable condition false $self->{origin} = $cache->{$link} ||= __PACKAGE__->decode( $buffer, $link, $cache ); return wantarray ? ( $self, $index + 2 ) : $self; } } croak 'corrupt wire-format data'; } =head2 encode $data = $object->encode; Returns the wire-format representation of the domain name suitable for inclusion in a DNS packet buffer. =cut sub encode { return join '', map { pack 'C a*', length($_), $_ } shift->_wire, ''; } =head2 canonical $data = $object->canonical; Returns the canonical wire-format representation of the domain name as defined in RFC2535(8.1). =cut sub canonical { my @label = shift->_wire; for (@label) { tr /\101-\132/\141-\172/; } return join '', map { pack 'C a*', length($_), $_ } @label, ''; } ######################################## package Net::DNS::DomainName1035; ## no critic ProhibitMultiplePackages our @ISA = qw(Net::DNS::DomainName); =head1 Net::DNS::DomainName1035 Net::DNS::DomainName1035 implements a subclass of domain name objects which are to be encoded using the compressed wire format defined in RFC1035. $data = $object->encode( $offset, $hash ); The arguments are the offset within the packet data where the domain name is to be stored and a reference to a hash table used to index compressed names within the packet. Note that RFC3597 implies that only the RR types defined in RFC1035(3.3) are eligible for compression of domain names occuring in RDATA. If the hash reference is undefined, encode() returns the lower case uncompressed canonical representation defined in RFC2535(8.1). =cut sub encode { my $self = shift; my $offset = shift || 0; # offset in data buffer my $hash = shift || return $self->canonical; # hashed offset by name my @labels = $self->_wire; my $data = ''; while (@labels) { my $name = join( '.', @labels ); return $data . pack( 'n', 0xC000 | $hash->{$name} ) if defined $hash->{$name}; my $label = shift @labels; my $length = length $label; $data .= pack( 'C a*', $length, $label ); next unless $offset < 0x4000; $hash->{$name} = $offset; $offset += 1 + $length; } return $data .= pack 'x'; } ######################################## package Net::DNS::DomainName2535; ## no critic ProhibitMultiplePackages our @ISA = qw(Net::DNS::DomainName); =head1 Net::DNS::DomainName2535 Net::DNS::DomainName2535 implements a subclass of domain name objects which are to be encoded using uncompressed wire format. $data = $object->encode( $offset, $hash ); The arguments are the offset within the packet data where the domain name is to be stored and a reference to a hash table used to index names already encoded within the packet. If the hash reference is undefined, encode() returns the lower case uncompressed canonical representation defined in RFC2535(8.1). Note that RFC3597, and latterly RFC4034, specifies that the lower case canonical form is to be used for RR types defined prior to RFC3597. =cut sub encode { my ( $self, $offset, $hash ) = @_; return $self->canonical unless defined $hash; my $name = join '.', my @labels = $self->_wire; $hash->{$name} = $offset if $offset < 0x4000; return join '', map { pack 'C a*', length($_), $_ } @labels, ''; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)2009-2011 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L =cut DNS/RR/IPSECKEY.pm000044400000015320152345050350007266 0ustar00package Net::DNS::RR::IPSECKEY; use strict; use warnings; our $VERSION = (qw$Id: IPSECKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::IPSECKEY - DNS IPSECKEY resource record =cut use integer; use Carp; use Net::DNS::DomainName; use Net::DNS::RR::A; use Net::DNS::RR::AAAA; use constant BASE64 => defined eval { require MIME::Base64 }; my %wireformat = ( 0 => 'C3 a0 a*', 1 => 'C3 a4 a*', 2 => 'C3 a16 a*', 3 => 'C3 a* a*', ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{qw(precedence gatetype algorithm)} = unpack "\@$offset C3", $$data; $offset += 3; my $gatetype = $self->{gatetype}; if ( not $gatetype ) { delete $self->{gateway}; # no gateway } elsif ( $gatetype == 1 ) { $self->{gateway} = unpack "\@$offset a4", $$data; $offset += 4; } elsif ( $gatetype == 2 ) { $self->{gateway} = unpack "\@$offset a16", $$data; $offset += 16; } elsif ( $gatetype == 3 ) { my $name; ( $name, $offset ) = Net::DNS::DomainName->decode( $data, $offset, @opaque ); $self->{gateway} = $name->encode; } else { die "unknown gateway type ($gatetype)"; } $self->keybin( substr $$data, $offset, $limit - $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $gatetype = $self->gatetype; my $gateway = $self->{gateway} || ''; my $precedence = $self->precedence; my $algorithm = $self->algorithm; my $keybin = $self->keybin; return pack $wireformat{$gatetype}, $precedence, $gatetype, $algorithm, $gateway, $keybin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->SUPER::_format_rdata() unless BASE64; my @rdata = map { $self->$_ } qw(precedence gatetype algorithm); my @base64 = split /\s+/, MIME::Base64::encode( $self->keybin ); push @rdata, ( $self->gateway, @base64 ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(precedence gatetype algorithm gateway)) { $self->$_( shift @argument ) } $self->key(@argument); return; } sub precedence { my ( $self, @value ) = @_; for (@value) { $self->{precedence} = 0 + $_ } return $self->{precedence} || 0; } sub gatetype { return shift->{gatetype} || 0; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub gateway { my ( $self, @value ) = @_; for (@value) { /^\.*$/ && do { $self->{gatetype} = 0; delete $self->{gateway}; # no gateway last; }; /:.*:/ && do { $self->{gatetype} = 2; $self->{gateway} = Net::DNS::RR::AAAA::address( {}, $_ ); last; }; /\.\d+$/ && do { $self->{gatetype} = 1; $self->{gateway} = Net::DNS::RR::A::address( {}, $_ ); last; }; /\..+/ && do { $self->{gatetype} = 3; $self->{gateway} = Net::DNS::DomainName->new($_)->encode; last; }; croak 'unrecognised gateway type'; } if ( defined wantarray ) { my $gateway = $self->{gateway}; for ( $self->gatetype ) { /^1$/ && return Net::DNS::RR::A::address( {address => $gateway} ); /^2$/ && return Net::DNS::RR::AAAA::address( {address => $gateway} ); /^3$/ && return Net::DNS::DomainName->decode( \$gateway )->name; } return wantarray ? '.' : undef; } return; } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } sub pubkey { return &key; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IPSECKEY precedence gatetype algorithm gateway key'); =head1 DESCRIPTION DNS IPSEC Key Storage (IPSECKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 precedence $precedence = $rr->precedence; $rr->precedence( $precedence ); This is an 8-bit precedence for this record. Gateways listed in IPSECKEY records with lower precedence are to be attempted first. =head2 gatetype $gatetype = $rr->gatetype; The gateway type field indicates the format of the information that is stored in the gateway field. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The algorithm type field identifies the public keys cryptographic algorithm and determines the format of the public key field. =head2 gateway $gateway = $rr->gateway; $rr->gateway( $gateway ); The gateway field indicates a gateway to which an IPsec tunnel may be created in order to reach the entity named by this resource record. =head2 pubkey =head2 key $key = $rr->key; $rr->key( $key ); Base64 representation of the optional public key block for the resource record. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); Binary representation of the public key block for the resource record. =head1 COPYRIGHT Copyright (c)2007 Olaf Kolkman, NLnet Labs. Portions Copyright (c)2012,2015 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/DNSKEY.pm000044400000022361152345050350007052 0ustar00package Net::DNS::RR::DNSKEY; use strict; use warnings; our $VERSION = (qw$Id: DNSKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DNSKEY - DNS DNSKEY resource record =cut use integer; use Carp; use constant BASE64 => defined eval { require MIME::Base64 }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; @{$self}{qw(flags protocol algorithm keybin)} = unpack 'n C2 a*', $rdata; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n C2 a*', @{$self}{qw(flags protocol algorithm keybin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = @{$self}{qw(flags protocol algorithm)}; if ( my $keybin = $self->keybin ) { $self->_annotation( 'keytag', $self->keytag ); return $self->SUPER::_format_rdata() unless BASE64; push @rdata, split /\s+/, MIME::Base64::encode($keybin); } else { push @rdata, '""'; } return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->flags( shift @argument ); $self->protocol( shift @argument ); my $algorithm = shift @argument; $self->key(@argument) if $algorithm; $self->algorithm($algorithm); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->flags(256); $self->protocol(3); $self->algorithm(1); $self->keybin(''); return; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub zone { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0100 ) { $_ ^= 0x0100 unless shift @value; } } return $self->{flags} & 0x0100; } sub revoke { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0080 ) { $_ ^= 0x0080 unless shift @value; } } return $self->{flags} & 0x0080; } sub sep { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0001 ) { $_ ^= 0x0001 unless shift @value; } } return $self->{flags} & 0x0001; } sub protocol { my ( $self, @value ) = @_; for (@value) { $self->{protocol} = 0 + $_ } return $self->{protocol} || 0; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /\D/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; return $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0) } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } sub publickey { my ( $self, @value ) = @_; return $self->key(@value); } sub privatekeyname { my $self = shift; my $name = $self->signame; return sprintf 'K%s+%03d+%05d.private', $name, $self->algorithm, $self->keytag; } sub signame { my $self = shift; return lc $self->{owner}->fqdn; } sub keylength { my $self = shift; my $keybin = $self->keybin || return; local $_ = _algbyval( $self->{algorithm} ); if (/^RSA/) { # Modulus length, see RFC 3110 if ( my $exp_length = unpack 'C', $keybin ) { return ( length($keybin) - $exp_length - 1 ) << 3; } else { $exp_length = unpack 'x n', $keybin; return ( length($keybin) - $exp_length - 3 ) << 3; } } elsif (/^DSA/) { # Modulus length, see RFC 2536 my $T = unpack 'C', $keybin; return ( $T << 6 ) + 512; } return length($keybin) << 2; ## ECDSA / EdDSA } sub keytag { my $self = shift; my $keybin = $self->{keybin} || return; # RFC4034 Appendix B.1: most significant 16 bits of least significant 24 bits return unpack 'n', substr $keybin, -3 if $self->{algorithm} == 1; # RFC4034 Appendix B my $od = length($keybin) & 1; my $rd = pack "n C2 a* x$od", @{$self}{qw(flags protocol algorithm)}, $keybin; my $ac = 0; $ac += $_ for unpack 'n*', $rd; $ac += ( $ac >> 16 ); return $ac & 0xFFFF; } ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DNSKEY flags protocol algorithm publickey'); =head1 DESCRIPTION Class for DNSSEC Key (DNSKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); Unsigned 16-bit number representing Boolean flags. =over 4 =item zone $rr->zone(1); if ( $rr->zone ) { ... } Boolean ZONE flag. =back =over 4 =item revoke $rr->revoke(1); if ( $rr->revoke ) { ... } Boolean REVOKE flag. =back =over 4 =item sep $rr->sep(1); if ( $rr->sep ) { ... } Boolean Secure Entry Point (SEP) flag. =back =head2 protocol $protocol = $rr->protocol; $rr->protocol( $protocol ); The 8-bit protocol number. This field MUST have value 3. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm number describes the public key algorithm. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 publickey =head2 key $key = $rr->key; $rr->key( $key ); Base64 representation of the public key material. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); Opaque octet string representing the public key material. =head2 privatekeyname $privatekeyname = $rr->privatekeyname; Returns the name of the privatekey as it would be generated by the BIND dnssec-keygen program. The format of that name being: K++.private =head2 signame $signame = $rr->signame; Returns the canonical signer name of the privatekey. =head2 keylength Returns the length (in bits) of the modulus calculated from the key text. =head2 keytag print "keytag = ", $rr->keytag, "\n"; Returns the 16-bit numerical key tag of the key. (RFC2535 4.1.6) =head1 COPYRIGHT Copyright (c)2003-2005 RIPE NCC. Author Olaf M. Kolkman All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut DNS/RR/CERT.pm000044400000015067152345050350006617 0ustar00package Net::DNS::RR::CERT; use strict; use warnings; our $VERSION = (qw$Id: CERT.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CERT - DNS CERT resource record =cut use integer; use Carp; use MIME::Base64; my %certtype = ( PKIX => 1, # X.509 as per PKIX SPKI => 2, # SPKI certificate PGP => 3, # OpenPGP packet IPKIX => 4, # The URL of an X.509 data object ISPKI => 5, # The URL of an SPKI certificate IPGP => 6, # The fingerprint and URL of an OpenPGP packet ACPKIX => 7, # Attribute Certificate IACPKIX => 8, # The URL of an Attribute Certificate URI => 253, # URI private OID => 254, # OID private ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(certtype keytag algorithm)} = unpack "\@$offset n2 C", $$data; $self->{certbin} = substr $$data, $offset + 5, $self->{rdlength} - 5; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack "n2 C a*", $self->certtype, $self->keytag, $self->algorithm, $self->{certbin}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @param = ( $self->certtype, $self->keytag, $self->algorithm ); my @rdata = ( @param, split /\s+/, encode_base64( $self->{certbin} ) ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(certtype keytag algorithm)) { $self->$_( shift @argument ); } $self->cert(@argument); return; } sub certtype { my ( $self, @value ) = @_; return $self->{certtype} unless scalar @value; my $certtype = shift @value; return $self->{certtype} = $certtype unless $certtype =~ /\D/; my $typenum = $certtype{$certtype}; $typenum || croak qq[unknown certtype $certtype]; return $self->{certtype} = $typenum; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub algorithm { my ( $self, $arg ) = @_; return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; return $self->{algorithm} = _algbyname($arg); } sub certificate { return &certbin; } sub certbin { my ( $self, @value ) = @_; for (@value) { $self->{certbin} = $_ } return $self->{certbin} || ""; } sub cert { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->certbin(), "" ) unless scalar @value; return $self->certbin( MIME::Base64::decode( join "", @value ) ); } sub format { return &certtype; } # uncoverable pod sub tag { return &keytag; } # uncoverable pod ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN CERT certtype keytag algorithm cert'); =head1 DESCRIPTION Class for DNS Certificate (CERT) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 certtype $certtype = $rr->certtype; Returns the certtype code for the certificate (in numeric form). =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); Returns the key tag for the public key in the certificate =head2 algorithm $algorithm = $rr->algorithm; Returns the algorithm used by the certificate (in numeric form). =head2 certificate =head2 certbin $certbin = $rr->certbin; $rr->certbin( $certbin ); Binary representation of the certificate. =head2 cert $cert = $rr->cert; $rr->cert( $cert ); Base64 representation of the certificate. =head1 COPYRIGHT Copyright (c)2002 VeriSign, Mike Schiraldi All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/NSEC3.pm000044400000030732152345050350006671 0ustar00package Net::DNS::RR::NSEC3; use strict; use warnings; our $VERSION = (qw$Id: NSEC3.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::NSEC); =head1 NAME Net::DNS::RR::NSEC3 - DNS NSEC3 resource record =cut use integer; use base qw(Exporter); our @EXPORT_OK = qw(name2hash); use Carp; require Net::DNS::DomainName; eval { require Digest::SHA }; ## optional for simple Net::DNS RR sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; my $ssize = unpack "\@$offset x4 C", $$data; my ( $algorithm, $flags, $iterations, $saltbin ) = unpack "\@$offset CCnx a$ssize", $$data; @{$self}{qw(algorithm flags iterations saltbin)} = ( $algorithm, $flags, $iterations, $saltbin ); $offset += 5 + $ssize; my $hsize = unpack "\@$offset C", $$data; $self->{hnxtname} = unpack "\@$offset x a$hsize", $$data; $offset += 1 + $hsize; $self->{typebm} = substr $$data, $offset, ( $limit - $offset ); $self->{hashfn} = _hashfn( $algorithm, $iterations, $saltbin ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $salt = $self->saltbin; my $hash = $self->{hnxtname}; return pack 'CCn C a* C a* a*', $self->algorithm, $self->flags, $self->iterations, length($salt), $salt, length($hash), $hash, $self->{typebm}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->algorithm, $self->flags, $self->iterations, $self->salt || '-', $self->hnxtname, $self->typelist ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; my $alg = $self->algorithm( shift @argument ); $self->flags( shift @argument ); my $iter = $self->iterations( shift @argument ); my $salt = shift @argument; $self->salt($salt) unless $salt eq '-'; $self->hnxtname( shift @argument ); $self->typelist(@argument); $self->{hashfn} = _hashfn( $alg, $iter, $self->{saltbin} ); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata( 1, 0, 0, '' ); return; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn); } return $self->{algorithm} unless defined $arg; return _digestbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; return $self->{algorithm} = _digestbyname($arg); } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub optout { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x01 ) { $_ ^= 0x01 unless shift @value; } } return $self->{flags} & 0x01; } sub iterations { my ( $self, @value ) = @_; for (@value) { $self->{iterations} = 0 + $_ } return $self->{iterations} || 0; } sub salt { my ( $self, @value ) = @_; return unpack "H*", $self->saltbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->saltbin( pack "H*", join "", @hex ); } sub saltbin { my ( $self, @value ) = @_; for (@value) { $self->{saltbin} = $_ } return $self->{saltbin} || ""; } sub hnxtname { my ( $self, @name ) = @_; for (@name) { $self->{hnxtname} = _decode_base32hex($_) } return defined(wantarray) ? _encode_base32hex( $self->{hnxtname} ) : undef; } sub match { my ( $self, $name ) = @_; my ($owner) = $self->{owner}->label; my $ownerhash = _decode_base32hex($owner); my $hashfn = $self->{hashfn}; return $ownerhash eq &$hashfn($name); } sub covers { my ( $self, $name ) = @_; my ( $owner, @zone ) = $self->{owner}->label; my $ownerhash = _decode_base32hex($owner); my $nexthash = $self->{hnxtname}; my @label = Net::DNS::DomainName->new($name)->label; my @close = @label; foreach (@zone) { pop(@close) } # strip zone labels return if lc($name) ne lc( join '.', @close, @zone ); # out of zone my $hashfn = $self->{hashfn}; foreach (@close) { my $hash = &$hashfn( join '.', @label ); my $cmp1 = $hash cmp $ownerhash; last unless $cmp1; # stop at provable encloser return 1 if ( $cmp1 + ( $nexthash cmp $hash ) ) == 2; shift @label; } return; } sub encloser { my ( $self, $qname ) = @_; my ( $owner, @zone ) = $self->{owner}->label; my $ownerhash = _decode_base32hex($owner); my $nexthash = $self->{hnxtname}; my @label = Net::DNS::DomainName->new($qname)->label; my @close = @label; foreach (@zone) { pop(@close) } # strip zone labels return if lc($qname) ne lc( join '.', @close, @zone ); # out of zone my $hashfn = $self->{hashfn}; my $encloser = $qname; foreach (@close) { my $nextcloser = $encloser; shift @label; my $hash = &$hashfn( $encloser = join '.', @label ); next if $hash ne $ownerhash; $self->{nextcloser} = $nextcloser; # next closer name $self->{wildcard} = "*.$encloser"; # wildcard at provable encloser return $encloser; # provable encloser } return; } sub nextcloser { return shift->{nextcloser}; } sub wildcard { return shift->{wildcard}; } ######################################## my @digestbyname = ( 'SHA-1' => 1, # [RFC3658] ); my @digestalias = ( 'SHA' => 1 ); my %digestbyval = reverse @digestbyname; foreach (@digestbyname) { s/[\W_]//g; } # strip non-alphanumerics my @digestrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @digestbyname; my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl sub _digestbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $digestbyname{$key}; croak qq[unknown algorithm $arg] unless defined $val; return $val; } sub _digestbyval { my $value = shift; return $digestbyval{$value} || return $value; } my %digest = ( '1' => scalar( eval { Digest::SHA->new(1) } ), # RFC3658 ); sub _decode_base32hex { local $_ = shift || ''; tr [0-9A-Va-v\060-\071\101-\126\141-\166] [\000-\037\012-\037\000-\037\012-\037]; my $l = ( 5 * length ) & ~7; return pack "B$l", join '', map { unpack( 'x3a5', unpack 'B8', $_ ) } split //; } sub _encode_base32hex { my @split = grep {length} split /(\S{5})/, unpack 'B*', shift; local $_ = join '', map { pack( 'B*', "000$_" ) } @split; tr [\000-\037] [0-9a-v]; return $_; } my ( $cache1, $cache2, $limit ) = ( {}, {}, 10 ); sub _hashfn { my $hashalg = shift; my $iterations = shift || 0; my $salt = shift || ''; my $hash = $digest{$hashalg}; return sub { croak "algorithm $hashalg not supported" } unless $hash; my $clone = $hash->clone; my $key_adjunct = pack 'Cna*', $hashalg, $iterations, $salt; return sub { my $name = Net::DNS::DomainName->new(shift)->canonical; my $key = join '', $name, $key_adjunct; my $cache = $$cache1{$key} ||= $$cache2{$key}; # two layer cache return $cache if defined $cache; ( $cache1, $cache2, $limit ) = ( {}, $cache1, 50 ) unless $limit--; # recycle cache $clone->add($name); $clone->add($salt); my $digest = $clone->digest; my $count = $iterations; while ( $count-- ) { $clone->add($digest); $clone->add($salt); $digest = $clone->digest; } return $$cache1{$key} = $digest; }; } sub hashalgo { return &algorithm; } # uncoverable pod sub name2hash { my $hashalg = shift; # uncoverable pod my $name = shift; my $iterations = shift || 0; my $salt = pack 'H*', shift || ''; my $hash = _hashfn( $hashalg, $iterations, $salt ); return _encode_base32hex( &$hash($name) ); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NSEC3 algorithm flags iterations salt hnxtname'); =head1 DESCRIPTION Class for DNSSEC NSEC3 resource records. The NSEC3 Resource Record (RR) provides authenticated denial of existence for DNS Resource Record Sets. The NSEC3 RR lists RR types present at the original owner name of the NSEC3 RR. It includes the next hashed owner name in the hash order of the zone. The complete set of NSEC3 RRs in a zone indicates which RRSets exist for the original owner name of the RR and form a chain of hashed owner names in the zone. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm field is represented as an unsigned decimal integer, but may be specified using the algorithm mnemonic. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); The Flags field is an unsigned decimal integer interpreted as eight concatenated Boolean values. =over 4 =item optout $rr->optout(1); if ( $rr->optout ) { ... } Boolean Opt Out flag. =back =head2 iterations $iterations = $rr->iterations; $rr->iterations( $iterations ); The Iterations field is represented as an unsigned decimal integer. The value is between 0 and 65535, inclusive. =head2 salt $salt = $rr->salt; $rr->salt( $salt ); The Salt field is represented as a contiguous sequence of hexadecimal digits. A "-" (unquoted) is used in string format to indicate that the salt field is absent. =head2 saltbin $saltbin = $rr->saltbin; $rr->saltbin( $saltbin ); The Salt field as a sequence of octets. =head2 hnxtname $hnxtname = $rr->hnxtname; $rr->hnxtname( $hnxtname ); The Next Hashed Owner Name field points to the next node that has authoritative data or contains a delegation point NS RRset. =head2 typelist @typelist = $rr->typelist; $typelist = $rr->typelist; $rr->typelist( @typelist ); typelist() identifies the RRset types that exist at the domain name matched by the NSEC3 RR. When called in scalar context, the list is interpolated into a string. =head2 typemap $exists = $rr->typemap($rrtype); typemap() returns a Boolean true value if the specified RRtype occurs in the type bitmap of the NSEC3 record. =head2 match $matched = $rr->match( 'example.foo' ); match() returns a Boolean true value if the hash of the domain name argument matches the hashed owner name of the NSEC3 RR. =head2 covers $covered = $rr->covers( 'example.foo' ); covers() returns a Boolean true value if the hash of the domain name argument, or ancestor of that name, falls between the owner name and the next hashed owner name of the NSEC3 RR. =head2 encloser, nextcloser, wildcard $encloser = $rr->encloser( 'example.foo' ); print "encloser: $encloser\n" if $encloser; encloser() returns the name of a provable encloser of the query name argument obtained from the NSEC3 RR. nextcloser() returns the next closer name, which is one label longer than the closest encloser. This is only valid after encloser() has returned a valid domain name. wildcard() returns the unexpanded wildcard name from which the next closer name was possibly synthesised. This is only valid after encloser() has returned a valid domain name. =head1 COPYRIGHT Copyright (c)2017,2018 Dick Franks Portions Copyright (c)2007,2008 NLnet Labs. Author Olaf M. Kolkman All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut DNS/RR/NULL.pm000044400000004066152345050350006631 0ustar00package Net::DNS::RR::NULL; use strict; use warnings; our $VERSION = (qw$Id: NULL.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NULL - DNS NULL resource record =cut 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NULL \# length hexdata ...'); =head1 DESCRIPTION Class for DNS null (NULL) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 rdlength $rdlength = $rr->rdlength; Returns the length of the record data section. =head2 rdata $rdata = $rr->rdata; $rr->rdata( $rdata ); Returns the record data section as binary data. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/OPENPGPKEY.pm000044400000006071152345050350007536 0ustar00package Net::DNS::RR::OPENPGPKEY; use strict; use warnings; our $VERSION = (qw$Id: OPENPGPKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::OPENPGPKEY - DNS OPENPGPKEY resource record =cut use integer; use MIME::Base64; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $length = $self->{rdlength}; $self->keybin( substr $$data, $offset, $length ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a*', $self->keybin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @base64 = split /\s+/, encode_base64( $self->keybin ); return @base64; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->key(@argument); return; } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name OPENPGPKEY key'); =head1 DESCRIPTION Class for OpenPGP Key (OPENPGPKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 key $key = $rr->key; $rr->key( $key ); Base64 encoded representation of the OpenPGP public key material. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); OpenPGP public key material consisting of a single OpenPGP transferable public key in RFC4880 format. =head1 COPYRIGHT Copyright (c)2014 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/DNAME.pm000044400000005614152345050350006703 0ustar00package Net::DNS::RR::DNAME; use strict; use warnings; our $VERSION = (qw$Id: DNAME.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DNAME - DNS DNAME resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{target} = Net::DNS::DomainName2535->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $target = $self->{target}; return $target->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; return $target->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->target(@argument); return; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName2535->new($_) } return $self->{target} ? $self->{target}->name : undef; } sub dname { return ⌖ } # uncoverable pod 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DNAME target'); =head1 DESCRIPTION Class for DNS Non-Terminal Name Redirection (DNAME) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 target $target = $rr->target; $rr->target( $target ); Redirection target domain name which is to be substituted for its owner as a suffix of a domain name. =head1 COPYRIGHT Copyright (c)2002 Andreas Gustafsson. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/L64.pm000044400000007500152345050350006420 0ustar00package Net::DNS::RR::L64; use strict; use warnings; our $VERSION = (qw$Id: L64.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::L64 - DNS L64 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(preference locator64)} = unpack "\@$offset n a8", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n a8', $self->{preference}, $self->{locator64}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->locator64; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference locator64)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub locator64 { my $self = shift; my $prfx = shift; $self->{locator64} = pack 'n4', map { hex($_) } split /:/, $prfx if defined $prfx; return $self->{locator64} ? sprintf( '%x:%x:%x:%x', unpack 'n4', $self->{locator64} ) : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN L64 preference locator64'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'L64', preference => 10, locator64 => '2001:0DB8:1140:1000' ); =head1 DESCRIPTION Class for DNS 64-bit Locator (L64) resource records. The L64 resource record is used to hold 64-bit Locator values for ILNPv6-capable nodes. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this L64 record among other L64 records associated with this owner name. Lower values are preferred over higher values. =head2 locator64 $locator64 = $rr->locator64; The Locator64 field is an unsigned 64-bit integer in network byte order that has the same syntax and semantics as a 64-bit IPv6 routing prefix. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/HTTPS.pm000044400000004060152345050350006753 0ustar00package Net::DNS::RR::HTTPS; use strict; use warnings; our $VERSION = (qw$Id: HTTPS.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR::SVCB); =head1 NAME Net::DNS::RR::HTTPS - DNS HTTPS resource record =cut 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name HTTPS SvcPriority TargetName alpn=h3-29,h3-28,h3-27,h2 ...'); =head1 DESCRIPTION DNS HTTPS resource record The HTTPS class is derived from, and inherits all properties of, the Net::DNS::RR::SVCB class. Please see the L documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2020 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/CSYNC.pm000044400000010645152345050350006736 0ustar00package Net::DNS::RR::CSYNC; use strict; use warnings; our $VERSION = (qw$Id: CSYNC.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CSYNC - DNS CSYNC resource record =cut use integer; use Net::DNS::RR::NSEC; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{qw(soaserial flags)} = unpack "\@$offset Nn", $$data; $offset += 6; $self->{typebm} = substr $$data, $offset, $limit - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'N n a*', $self->soaserial, $self->flags, $self->{typebm}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->soaserial, $self->flags, $self->typelist ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->soaserial( shift @argument ); $self->flags( shift @argument ); $self->typelist(@argument); return; } sub soaserial { my ( $self, @value ) = @_; for (@value) { $self->{soaserial} = 0 + $_ } return $self->{soaserial} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub immediate { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0001 ) { $_ ^= 0x0001 unless shift @value; } } return $self->{flags} & 0x0001; } sub soaminimum { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x0002 ) { $_ ^= 0x0002 unless shift @value; } } return $self->{flags} & 0x0002; } sub typelist { return &Net::DNS::RR::NSEC::typelist; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CSYNC SOAserial flags typelist'); =head1 DESCRIPTION Class for DNSSEC CSYNC resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 SOAserial =head2 soaserial $soaserial = $rr->soaserial; $rr->soaserial( $soaserial ); The SOA Serial field contains a copy of the 32-bit SOA serial number from the child zone. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); The flags field contains 16 bits of boolean flags that define operations which affect the processing of the CSYNC record. =over 4 =item immediate $rr->immediate(1); if ( $rr->immediate ) { ... } If not set, a parental agent must not process the CSYNC record until the zone administrator approves the operation through an out-of-band mechanism. =back =over 4 =item soaminimum $rr->soaminimum(1); if ( $rr->soaminimum ) { ... } If set, a parental agent querying child authoritative servers must not act on data from zones advertising an SOA serial number less than the SOAserial value. =back =head2 typelist @typelist = $rr->typelist; $typelist = $rr->typelist; The type list indicates the record types to be processed by the parental agent. When called in scalar context, the list is interpolated into a string. =head1 COPYRIGHT Copyright (c)2015 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/DELEG.pm000044400000004467152345050350006704 0ustar00package Net::DNS::RR::DELEG; use strict; use warnings; our $VERSION = (qw$Id: DELEG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::SVCB); =head1 NAME Net::DNS::RR::DELEG - DNS DELEG resource record =cut 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('alias DELEG 0 target'); $rr = Net::DNS::RR->new('child DELEG 1 nameserver ipv6hint=2001:db8::f00'); =head1 DESCRIPTION DNS DELEG resource record The DELEG record appears in, and is logically a part of, the parent zone to mark the delegation point for a child zone. It advertises, directly or indirectly, transport methods available for connection to nameservers serving the child zone. The DELEG class is derived from, and inherits all properties of, the Net::DNS::RR::SVCB class. Please see the L documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/MINFO.pm000044400000007721152345050350006730 0ustar00package Net::DNS::RR::MINFO; use strict; use warnings; our $VERSION = (qw$Id: MINFO.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MINFO - DNS MINFO resource record =cut use integer; use Net::DNS::Mailbox; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; ( $self->{rmailbx}, $offset ) = Net::DNS::Mailbox1035->decode( $data, $offset, @opaque ); ( $self->{emailbx}, $offset ) = Net::DNS::Mailbox1035->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my ( $offset, @opaque ) = @argument; my $rdata = $self->{rmailbx}->encode(@argument); $rdata .= $self->{emailbx}->encode( $offset + length $rdata, @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->{rmailbx}->string, $self->{emailbx}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(rmailbx emailbx)) { $self->$_( shift @argument ) } return; } sub rmailbx { my ( $self, @value ) = @_; for (@value) { $self->{rmailbx} = Net::DNS::Mailbox1035->new($_) } return $self->{rmailbx} ? $self->{rmailbx}->address : undef; } sub emailbx { my ( $self, @value ) = @_; for (@value) { $self->{emailbx} = Net::DNS::Mailbox1035->new($_) } return $self->{emailbx} ? $self->{emailbx}->address : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR('name MINFO rmailbx emailbx'); =head1 DESCRIPTION Class for DNS Mailbox Information (MINFO) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 rmailbx $rmailbx = $rr->rmailbx; $rr->rmailbx( $rmailbx ); A domain name which specifies a mailbox which is responsible for the mailing list or mailbox. If this domain name names the root, the owner of the MINFO RR is responsible for itself. Note that many existing mailing lists use a mailbox X-request to identify the maintainer of mailing list X, e.g., Msgroup-request for Msgroup. This field provides a more general mechanism. =head2 emailbx $emailbx = $rr->emailbx; $rr->emailbx( $emailbx ); A domain name which specifies a mailbox which is to receive error messages related to the mailing list or mailbox specified by the owner of the MINFO RR (similar to the ERRORS-TO: field which has been proposed). If this domain name names the root, errors should be returned to the sender of the message. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/MX.pm000044400000007522152345050350006403 0ustar00package Net::DNS::RR::MX; use strict; use warnings; our $VERSION = (qw$Id: MX.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MX - DNS MX resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{exchange} = Net::DNS::DomainName1035->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my ( $offset, @opaque ) = @argument; my $exchange = $self->{exchange}; return pack 'n a*', $self->preference, $exchange->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $exchange = $self->{exchange}; return join ' ', $self->preference, $exchange->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference exchange)) { $self->$_( shift @argument ) } return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->preference(10); return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub exchange { my ( $self, @value ) = @_; for (@value) { $self->{exchange} = Net::DNS::DomainName1035->new($_) } return $self->{exchange} ? $self->{exchange}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name MX preference exchange'); =head1 DESCRIPTION DNS Mail Exchanger (MX) resource record =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer which specifies the preference given to this RR among others at the same owner. Lower values are preferred. =head2 exchange $exchange = $rr->exchange; $rr->exchange( $exchange ); A domain name which specifies a host willing to act as a mail exchange for the owner name. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/CDNSKEY.pm000044400000004771152345050350007162 0ustar00package Net::DNS::RR::CDNSKEY; use strict; use warnings; our $VERSION = (qw$Id: CDNSKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::DNSKEY); =head1 NAME Net::DNS::RR::CDNSKEY - DNS CDNSKEY resource record =cut use integer; sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->SUPER::_format_rdata() if $self->algorithm; return my @rdata = @{$self}{qw(flags protocol algorithm)}, "AA=="; } sub algorithm { my ( $self, $arg ) = @_; return $self->SUPER::algorithm($arg) if $arg; return $self->SUPER::algorithm() unless defined $arg; @{$self}{qw(flags protocol algorithm keybin)} = ( 0, 3, 0, chr(0) ); return; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CDNSKEY flags protocol algorithm publickey'); =head1 DESCRIPTION DNS Child DNSKEY resource record This is a clone of the DNSKEY record and inherits all properties of the Net::DNS::RR::DNSKEY class. Please see the L perl documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2014,2017 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/RT.pm000044400000007401152345050350006400 0ustar00package Net::DNS::RR::RT; use strict; use warnings; our $VERSION = (qw$Id: RT.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::RT - DNS RT resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{intermediate} = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; return pack 'n a*', $self->preference, $self->{intermediate}->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->{intermediate}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference intermediate)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub intermediate { my ( $self, @value ) = @_; for (@value) { $self->{intermediate} = Net::DNS::DomainName2535->new($_) } return $self->{intermediate} ? $self->{intermediate}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name RT preference intermediate'); =head1 DESCRIPTION Class for DNS Route Through (RT) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer representing the preference of the route. Smaller numbers indicate more preferred routes. =head2 intermediate $intermediate = $rr->intermediate; $rr->intermediate( $intermediate ); The domain name of a host which will serve as an intermediate in reaching the host specified by the owner name. The DNS RRs associated with the intermediate host are expected to include at least one A, X25, or ISDN record. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/TSIG.pm000044400000050275152345050350006630 0ustar00package Net::DNS::RR::TSIG; use strict; use warnings; our $VERSION = (qw$Id: TSIG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::TSIG - DNS TSIG resource record =cut use integer; use Carp; use Net::DNS::DomainName; use Net::DNS::Parameters qw(:class :type :rcode); use constant SYMLINK => defined(&CORE::readlink); # Except Win32, VMS, RISC OS use constant ANY => classbyname q(ANY); use constant TSIG => typebyname q(TSIG); eval { require Digest::HMAC }; eval { require Digest::MD5 }; eval { require Digest::SHA }; eval { require MIME::Base64 }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{algorithm}, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); # Design decision: Use 32 bits, which will work until the end of time()! @{$self}{qw(time_signed fudge)} = unpack "\@$offset xxN n", $$data; $offset += 8; my $mac_size = unpack "\@$offset n", $$data; $self->{macbin} = unpack "\@$offset xx a$mac_size", $$data; $offset += $mac_size + 2; @{$self}{qw(original_id error)} = unpack "\@$offset nn", $$data; $offset += 4; my $other_size = unpack "\@$offset n", $$data; $self->{other} = unpack "\@$offset xx a$other_size", $$data; $offset += $other_size + 2; croak('misplaced or corrupt TSIG') unless $limit == length $$data; my $raw = substr $$data, 0, $self->{offset}++; $self->{rawref} = \$raw; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $offset = shift; my $undef = shift; my $message = shift; my $macbin = $self->macbin; unless ($macbin) { my $sigdata = $self->sig_data($message); # form data to be signed $macbin = $self->macbin( $self->_mac_function($sigdata) ); } my $rdata = $self->{algorithm}->canonical; # Design decision: Use 32 bits, which will work until the end of time()! $rdata .= pack 'xxN n', $self->time_signed, $self->fudge; $rdata .= pack 'na*', length($macbin), $macbin; $rdata .= pack 'nn', $self->original_id, $self->{error}; my $other = $self->other; $rdata .= pack 'na*', length($other), $other; return $rdata; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->algorithm(157); $self->class('ANY'); $self->error(0); $self->fudge(300); $self->other(''); return; } sub _size { ## estimate encoded size my $self = shift; my $clone = bless {%$self}, ref($self); # shallow clone return length $clone->encode( 0, undef, Net::DNS::Packet->new() ); } sub encode { ## override RR method my ( $self, @argument ) = @_; my $kname = $self->{owner}->encode(); # uncompressed key name my $rdata = eval { $self->_encode_rdata(@argument) } || ''; return pack 'a* n2 N n a*', $kname, TSIG, ANY, 0, length $rdata, $rdata; } sub string { ## override RR method my $self = shift; my $owner = $self->{owner}->string; my $type = $self->type; my $algorithm = $self->algorithm; my $time_signed = $self->time_signed; my $fudge = $self->fudge; my $signature = $self->mac; my $original_id = $self->original_id; my $error = $self->error; my $other = $self->other; return <<"QQ"; ; $owner $type ; algorithm: $algorithm ; time signed: $time_signed fudge: $fudge ; signature: $signature ; original id: $original_id ; $error $other QQ } sub algorithm { return &_algorithm; } sub key { my ( $self, @argument ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @argument; return $self->keybin( MIME::Base64::decode( join "", @argument ) ); } sub keybin { return &_keybin; } sub time_signed { my ( $self, @value ) = @_; for (@value) { $self->{time_signed} = 0 + $_ } return $self->{time_signed} ? $self->{time_signed} : ( $self->{time_signed} = time() ); } sub fudge { my ( $self, @value ) = @_; for (@value) { $self->{fudge} = 0 + $_ } return $self->{fudge} || 0; } sub mac { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->macbin(), "" ) unless scalar @value; return $self->macbin( MIME::Base64::decode( join "", @value ) ); } sub macbin { my ( $self, @value ) = @_; for (@value) { $self->{macbin} = $_ } return $self->{macbin} || ""; } sub prior_mac { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->prior_macbin(), "" ) unless scalar @value; return $self->prior_macbin( MIME::Base64::decode( join "", @value ) ); } sub prior_macbin { my ( $self, @value ) = @_; for (@value) { $self->{prior_macbin} = $_ } return $self->{prior_macbin} || ""; } sub request_mac { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->request_macbin(), "" ) unless scalar @value; return $self->request_macbin( MIME::Base64::decode( join "", @value ) ); } sub request_macbin { my ( $self, @value ) = @_; for (@value) { $self->{request_macbin} = $_ } return $self->{request_macbin} || ""; } sub original_id { my ( $self, @value ) = @_; for (@value) { $self->{original_id} = 0 + $_ } return $self->{original_id} || 0; } sub error { my ( $self, @value ) = @_; for (@value) { my $error = $self->{error} = rcodebyname($_); $self->other( time() ) if $error == 18; } return rcodebyval( $self->{error} || '' ); } sub other { my ( $self, @value ) = @_; for (@value) { $self->{other} = $_ ? pack( 'xxN', $_ ) : '' } return $self->{other} ? unpack( 'N', $self->{other} ) : ''; } sub other_data { return &other; } # uncoverable pod sub sig_function { my ( $self, @value ) = @_; for (@value) { $self->{sig_function} = $_ } return $self->{sig_function}; } sub sign_func { return &sig_function; } # uncoverable pod sub sig_data { my ( $self, $message ) = @_; if ( ref($message) ) { die 'missing packet reference' unless $message->isa('Net::DNS::Packet'); my @unsigned = grep { ref($_) ne ref($self) } @{$message->{additional}}; local $message->{additional} = \@unsigned; # remake header image my @part = qw(question answer authority additional); my @size = map { scalar @{$message->{$_}} } @part; if ( my $rawref = $self->{rawref} ) { delete $self->{rawref}; my $hbin = pack 'n6', $self->original_id, $message->{status}, @size; $message = join '', $hbin, substr $$rawref, length $hbin; } else { my $data = $message->encode; my $id = $message->header->id; my $hbin = pack 'n6', $id, $message->{status}, @size; $message = join '', $hbin, substr $data, length $hbin; $self->original_id($id); } } # Design decision: Use 32 bits, which will work until the end of time()! my $time = pack 'xxN n', $self->time_signed, $self->fudge; # Insert the prior MAC if present (multi-packet message). $self->prior_macbin( $self->{link}->macbin ) if $self->{link}; my $prior_macbin = $self->prior_macbin; return pack 'na* a* a*', length($prior_macbin), $prior_macbin, $message, $time if $prior_macbin; # Insert the request MAC if present (used to validate responses). my $req_mac = $self->request_macbin; my $sigdata = $req_mac ? pack( 'na*', length($req_mac), $req_mac ) : ''; $sigdata .= $message || ''; my $kname = $self->{owner}->canonical; # canonical key name $sigdata .= pack 'a* n N', $kname, ANY, 0; $sigdata .= $self->{algorithm}->canonical; # canonical algorithm name $sigdata .= $time; $sigdata .= pack 'n', $self->{error}; my $other = $self->other; $sigdata .= pack 'na*', length($other), $other; return $sigdata; } sub create { my ( $class, $karg, @argument ) = @_; croak 'argument undefined' unless defined $karg; if ( ref($karg) ) { if ( $karg->isa('Net::DNS::Packet') ) { my $sigrr = $karg->sigrr; croak 'no TSIG in request packet' unless defined $sigrr; return Net::DNS::RR->new( # ( request, options ) name => $sigrr->name, type => 'TSIG', algorithm => $sigrr->algorithm, request_macbin => $sigrr->macbin, @argument ); } elsif ( ref($karg) eq __PACKAGE__ ) { my $tsig = $karg->_chain; $tsig->{macbin} = undef; return $tsig; } elsif ( ref($karg) eq 'Net::DNS::RR::KEY' ) { return Net::DNS::RR->new( name => $karg->name, type => 'TSIG', algorithm => $karg->algorithm, key => $karg->key, @argument ); } } elsif ( ( scalar(@argument) % 2 ) == 0 ) { require File::Spec; # ( keyfile, options ) require Net::DNS::ZoneFile; my ($keypath) = SYMLINK ? grep( {$_} readlink($karg), $karg ) : $karg; my ( $vol, $dir, $name ) = File::Spec->splitpath($keypath); $name =~ m/^K([^+]+)\+\d+\+(\d+)\./; # BIND dnssec-keygen my ( $keyname, $keytag ) = ( $1, $2 ); my $keyfile = Net::DNS::ZoneFile->new($karg); my ( $algorithm, $secret ); while ( $keyfile->_getline ) { /^key "([^"]+)"/ and $keyname = $1; # BIND tsig key /algorithm ([^;]+);/ and $algorithm = $1; /secret "([^"]+)";/ and $secret = $1; /^Algorithm:/ and ( undef, $algorithm ) = split; # BIND dnssec private key /^Key:/ and ( undef, $secret ) = split; next unless /\bIN\s+KEY\b/; # BIND dnssec public key my $keyrr = Net::DNS::RR->new($_); carp "$karg does not appear to be a BIND dnssec public key" unless $keyrr->keytag == ( $keytag || 0 ); return $class->create( $keyrr, @argument ); } foreach ( $keyname, $algorithm, $secret ) { croak 'key file incompatible with TSIG' unless $_; } return Net::DNS::RR->new( name => $keyname, type => 'TSIG', algorithm => $algorithm, key => $secret, @argument ); } croak "Usage: $class->create( \$keyfile, \@options )"; } sub verify { my ( $self, $data, @link ) = @_; my $fail = undef; if ( scalar @link ) { my $link = shift @link; unless ( ref($link) ) { $self->error('BADSIG'); # (multi-packet) return $fail; } my $signerkey = lc( join '+', $self->name, $self->algorithm ); if ( $link->isa('Net::DNS::Packet') ) { my $request = $link->sigrr; # request TSIG my $rqstkey = lc( join '+', $request->name, $request->algorithm ); $self->error('BADKEY') unless $signerkey eq $rqstkey; $self->request_macbin( $request->macbin ); } elsif ( $link->isa(__PACKAGE__) ) { my $priorkey = lc( join '+', $link->name, $link->algorithm ); $self->error('BADKEY') unless $signerkey eq $priorkey; $self->prior_macbin( $link->macbin ); } else { croak 'Usage: $tsig->verify( $reply, $query )'; } } return $fail if $self->{error}; my $sigdata = $self->sig_data($data); # form data to be verified my $tsigmac = $self->_mac_function($sigdata); my $tsig = $self->_chain; my $macbin = $self->macbin; my $maclen = length $macbin; $self->error('BADSIG') if $macbin ne substr $tsigmac, 0, $maclen; my $minlen = length($tsigmac) >> 1; # per RFC4635, 3.1 $self->error('BADTRUNC') if $maclen < $minlen or $maclen > length $tsigmac; $self->error('BADTRUNC') if $maclen < 10; my $time_signed = $self->time_signed; if ( abs( time() - $time_signed ) > $self->fudge ) { $self->error('BADTIME'); $self->other($time_signed); } return $self->{error} ? $fail : $tsig; } sub vrfyerrstr { return shift->error; } ######################################## { my @algbyname = ( 'HMAC-MD5.SIG-ALG.REG.INT' => 157, # numbers are from ISC BIND keygen 'HMAC-SHA1' => 161, # and not blessed by IANA 'HMAC-SHA224' => 162, 'HMAC-SHA256' => 163, 'HMAC-SHA384' => 164, 'HMAC-SHA512' => 165, ); my @algalias = ( 'HMAC-MD5' => 157, 'HMAC-SHA' => 161, ); my %algbyval = reverse @algbyname; my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname, @algalias; foreach (@algrehash) { s/[\W_]//g; } # strip non-alphanumerics my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $key = uc shift; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics return $algbyname{$key}; } sub _algbyval { my $value = shift; return $algbyval{$value}; } } { my %digest = ( '157' => ['Digest::MD5'], '161' => ['Digest::SHA'], '162' => ['Digest::SHA', 224, 64], '163' => ['Digest::SHA', 256, 64], '164' => ['Digest::SHA', 384, 128], '165' => ['Digest::SHA', 512, 128], ); my %keytable; sub _algorithm { ## install sig function in key table my $self = shift; if ( my $algname = shift ) { unless ( my $digtype = _algbyname($algname) ) { $self->{algorithm} = Net::DNS::DomainName->new($algname); } else { $algname = _algbyval($digtype); $self->{algorithm} = Net::DNS::DomainName->new($algname); my ( $hash, @param ) = @{$digest{$digtype}}; my ( undef, @block ) = @param; my $digest = $hash->new(@param); my $function = sub { my $hmac = Digest::HMAC->new( shift, $digest, @block ); $hmac->add(shift); return $hmac->digest; }; $self->sig_function($function); my $keyname = ( $self->{owner} || return )->canonical; $keytable{$keyname}{digest} = $function; } } return defined wantarray ? $self->{algorithm}->name : undef; } sub _keybin { ## install key in key table my ( $self, @argument ) = @_; croak 'access to TSIG key material denied' unless scalar @argument; my $keyref = $keytable{$self->{owner}->canonical} ||= {}; my $private = shift @argument; # closure keeps private key private $keyref->{key} = sub { my $function = $keyref->{digest}; return &$function( $private, @_ ); }; return; } sub _mac_function { ## apply keyed hash function to argument my ( $self, @argument ) = @_; my $owner = $self->{owner}->canonical; $self->algorithm( $self->algorithm ) unless $keytable{$owner}{digest}; my $keyref = $keytable{$owner}; $keyref->{digest} = $self->sig_function unless $keyref->{digest}; my $function = $keyref->{key}; return &$function(@argument); } } # _chain() creates a new TSIG object linked to the original # RR, for the purpose of signing multi-message transfers. sub _chain { my $self = shift; $self->{link} = undef; return bless {%$self, link => $self}, ref($self); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $tsig = Net::DNS::RR::TSIG->create( $keyfile ); $tsig = Net::DNS::RR::TSIG->create( $keyfile, fudge => 300 ); =head1 DESCRIPTION Class for DNS Transaction Signature (TSIG) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); A domain name which specifies the name of the algorithm. =head2 key $rr->key( $key ); Base64 representation of the key material. =head2 keybin $rr->keybin( $keybin ); Binary representation of the key material. =head2 time_signed $time_signed = $rr->time_signed; $rr->time_signed( $time_signed ); Signing time as the number of seconds since 1 Jan 1970 00:00:00 UTC. The default signing time is the current time. =head2 fudge $fudge = $rr->fudge; $rr->fudge( $fudge ); "fudge" represents the permitted error in the signing time. The default fudge is 300 seconds. =head2 mac $rr->mac( $mac ); Message authentication code (MAC). The programmer must call the Net::DNS::Packet data() object method before this will return anything meaningful. =head2 macbin $macbin = $rr->macbin; $rr->macbin( $macbin ); Binary message authentication code (MAC). =head2 prior_mac $prior_mac = $rr->prior_mac; $rr->prior_mac( $prior_mac ); Prior message authentication code (MAC). =head2 prior_macbin $prior_macbin = $rr->prior_macbin; $rr->prior_macbin( $prior_macbin ); Binary prior message authentication code. =head2 request_mac $request_mac = $rr->request_mac; $rr->request_mac( $request_mac ); Request message authentication code (MAC). =head2 request_macbin $request_macbin = $rr->request_macbin; $rr->request_macbin( $request_macbin ); Binary request message authentication code. =head2 original_id $original_id = $rr->original_id; $rr->original_id( $original_id ); The message ID from the header of the original packet. =head2 error =head2 vrfyerrstr $rcode = $tsig->error; Returns the RCODE covering TSIG processing. Common values are NOERROR, BADSIG, BADKEY, and BADTIME. See RFC8945 for details. =head2 other $other = $tsig->other; This field should be empty unless the error is BADTIME, in which case it will contain the server time as the number of seconds since 1 Jan 1970 00:00:00 UTC. =head2 sig_function sub signing_function { my ( $keybin, $data ) = @_; my $hmac = Digest::HMAC->new( $keybin, 'Digest::MD5' ); hmac->add( $data ); return $hmac->digest; } $tsig->sig_function( \&signing_function ); This sets the signing function to be used for this TSIG record. The default signing function is HMAC-MD5. =head2 sig_data $sigdata = $tsig->sig_data($packet); Returns the packet packed according to RFC8945 in a form for signing. This is only needed if you want to supply an external signing function, such as is needed for TSIG-GSS. =head2 create $tsig = Net::DNS::RR::TSIG->create( $keyfile ); $tsig = Net::DNS::RR::TSIG->create( $keyfile, fudge => 300 ); Returns a TSIG RR constructed using the parameters in the specified key file, which is assumed to have been generated by tsig-keygen. =head2 verify $verify = $tsig->verify( $data ); $verify = $tsig->verify( $packet ); $verify = $tsig->verify( $reply, $query ); $verify = $tsig->verify( $packet, $prior ); The boolean verify method will return true if the hash over the packet data conforms to the data in the TSIG itself =head1 TSIG Keys The TSIG authentication mechanism employs a shared secret key to establish a trust relationship between two entities. It should be noted that it is possible for more than one key to be in use simultaneously between any such pair of entities. TSIG keys are generated using the tsig-keygen utility distributed with ISC BIND: tsig-keygen -a HMAC-SHA256 host1-host2.example. Other algorithms may be substituted for HMAC-SHA256 in the above example. These keys must be protected in a manner similar to private keys, lest a third party masquerade as one of the intended parties by forging the message authentication code (MAC). =head1 Configuring BIND Nameserver The generated key must be added to the /etc/named.conf configuration or a separate file introduced by the $INCLUDE directive: key "host1-host2.example. { algorithm hmac-sha256; secret "Secret+known+only+by+participating+entities="; }; =head1 ACKNOWLEDGMENT Most of the code in the Net::DNS::RR::TSIG module was contributed by Chris Turbeville. Support for external signing functions was added by Andrew Tridgell. Support for HMAC-SHA1, HMAC-SHA224, HMAC-SHA256, HMAC-SHA384, HMAC-SHA512 and BIND keyfile handling was added by Dick Franks. =head1 BUGS A 32-bit representation of time is used, contrary to RFC8945 which demands 48 bits. This design decision will need to be reviewed before the code stops working on 7 February 2106. =head1 COPYRIGHT Copyright (c)2000,2001 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2013,2020 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut DNS/RR/SSHFP.pm000044400000011343152345050350006736 0ustar00package Net::DNS::RR::SSHFP; use strict; use warnings; our $VERSION = (qw$Id: SSHFP.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SSHFP - DNS SSHFP resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $size = $self->{rdlength} - 2; @{$self}{qw(algorithm fptype fpbin)} = unpack "\@$offset C2 a$size", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C2 a*', @{$self}{qw(algorithm fptype fpbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; $self->_annotation( $self->babble ) if BABBLE; my @fprint = split /(\S{64})/, $self->fp; my @rdata = ( $self->algorithm, $self->fptype, @fprint ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(algorithm fptype)) { $self->$_( shift @argument ) } $self->fp(@argument); return; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub fptype { my ( $self, @value ) = @_; for (@value) { $self->{fptype} = 0 + $_ } return $self->{fptype} || 0; } sub fp { my ( $self, @value ) = @_; return unpack "H*", $self->fpbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->fpbin( pack "H*", join "", @hex ); } sub fpbin { my ( $self, @value ) = @_; for (@value) { $self->{fpbin} = $_ } return $self->{fpbin} || ""; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->fpbin ) : ''; } sub fingerprint { return &fp; } ## historical 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SSHFP algorithm fptype fp'); =head1 DESCRIPTION DNS SSH Fingerprint (SSHFP) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm number describes the algorithm used to construct the public key. =head2 fptype $fptype = $rr->fptype; $rr->fptype( $fptype ); The 8-bit fingerprint type number describes the message-digest algorithm used to calculate the fingerprint of the public key. =head2 fingerprint =head2 fp $fp = $rr->fp; $rr->fp( $fp ); Hexadecimal representation of the fingerprint digest. =head2 fpbin $fpbin = $rr->fpbin; $rr->fpbin( $fpbin ); Returns opaque octet string representing the fingerprint digest. =head2 babble print $rr->babble; The babble() method returns the 'BabbleBubble' representation of the fingerprint if the Digest::BubbleBabble package is available, otherwise an empty string is returned. Bubble babble represents a message digest as a string of "real" words, to make the fingerprint easier to remember. The "words" are not necessarily real words, but they look more like words than a string of hex characters. Bubble babble fingerprinting is used by the SSH2 suite (and consequently by Net::SSH::Perl, the Perl SSH implementation) to display easy-to-remember key fingerprints. The 'BubbleBabble' string is appended as a comment when the string method is called. =head1 COPYRIGHT Copyright (c)2007 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/EUI64.pm000044400000006306152345050350006652 0ustar00package Net::DNS::RR::EUI64; use strict; use warnings; our $VERSION = (qw$Id: EUI64.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::EUI64 - DNS EUI64 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a8", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a8', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address { my ( $self, $address ) = @_; $self->{address} = pack 'C8', map { hex($_) } split /[:-]/, $address if $address; return defined(wantarray) ? join '-', unpack( 'H2H2H2H2H2H2H2H2', $self->{address} ) : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN EUI64 address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'EUI64', address => '00-00-5e-ef-10-00-00-2a' ); =head1 DESCRIPTION DNS resource records for 64-bit Extended Unique Identifier (EUI64). The EUI64 resource record is used to represent IEEE Extended Unique Identifiers used in various layer-2 networks, ethernet for example. EUI64 addresses SHOULD NOT be published in the public DNS. RFC7043 describes potentially severe privacy implications resulting from indiscriminate publication of link-layer addresses in the DNS. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address The address field is a 8-octet layer-2 address in network byte order. The presentation format is hexadecimal separated by "-". =head1 COPYRIGHT Copyright (c)2013 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/ZONEMD.pm000044400000010652152345050350007051 0ustar00package Net::DNS::RR::ZONEMD; use strict; use warnings; our $VERSION = (qw$Id: ZONEMD.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::ZONEMD - DNS ZONEMD resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; @{$self}{qw(serial scheme algorithm digestbin)} = unpack 'NC2a*', $rdata; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'NC2a*', @{$self}{qw(serial scheme algorithm digestbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @digest = split /(\S{64})/, $self->digest || qq(""); my @rdata = ( @{$self}{qw(serial scheme algorithm)}, @digest ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(serial scheme algorithm)) { $self->$_( shift @argument ) } $self->digest(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata( 0, 1, 1, '' ); return; } sub serial { my ( $self, @value ) = @_; for (@value) { $self->{serial} = 0 + $_ } return $self->{serial} || 0; } sub scheme { my ( $self, @value ) = @_; for (@value) { $self->{scheme} = 0 + $_ } return $self->{scheme} || 0; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub digest { my ( $self, @value ) = @_; return unpack "H*", $self->digestbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->digestbin( pack "H*", join "", @hex ); } sub digestbin { my ( $self, @value ) = @_; for (@value) { $self->{digestbin} = $_ } return $self->{digestbin} || ""; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new("example.com. ZONEMD 2018031500 1 1 FEBE3D4CE2EC2FFA4BA99D46CD69D6D29711E55217057BEE 7EB1A7B641A47BA7FED2DD5B97AE499FAFA4F22C6BD647DE"); =head1 DESCRIPTION Class for DNS Zone Message Digest (ZONEMD) resource record. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 serial $serial = $rr->serial; $rr->serial( $serial ); Unsigned 32-bit integer zone serial number. =head2 scheme $scheme = $rr->scheme; $rr->scheme( $scheme ); The scheme field is an 8-bit unsigned integer that identifies the methods by which data is collated and presented as input to the hashing function. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The algorithm field is an 8-bit unsigned integer that identifies the cryptographic hash algorithm used to construct the digest. =head2 digest $digest = $rr->digest; $rr->digest( $digest ); Hexadecimal representation of the digest over the zone content. =head2 digestbin $digestbin = $rr->digestbin; $rr->digestbin( $digestbin ); Binary representation of the digest over the zone content. =head1 COPYRIGHT Copyright (c)2019 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/KEY.pm000044400000004535152345050350006510 0ustar00package Net::DNS::RR::KEY; use strict; use warnings; our $VERSION = (qw$Id: KEY.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR::DNSKEY); =head1 NAME Net::DNS::RR::KEY - DNS KEY resource record =cut sub _defaults { ## specify RR attribute default values my $self = shift; $self->algorithm(1); $self->flags(0); $self->protocol(3); return; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name KEY flags protocol algorithm publickey'); =head1 DESCRIPTION DNS KEY resource record This is a clone of the DNSKEY record and inherits all properties of the Net::DNS::RR::DNSKEY class. Please see the L documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L =cut DNS/RR/APL.pm000044400000014357152345050350006477 0ustar00package Net::DNS::RR::APL; use strict; use warnings; our $VERSION = (qw$Id: APL.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::APL - DNS APL resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; my $aplist = $self->{aplist} = []; while ( $offset < $limit ) { my $xlen = unpack "\@$offset x3 C", $$data; my $size = ( $xlen & 0x7F ); my $item = bless {}, 'Net::DNS::RR::APL::Item'; $item->{negate} = $xlen - $size; @{$item}{qw(family prefix address)} = unpack "\@$offset n C x a$size", $$data; $offset += $size + 4; push @$aplist, $item; } croak('corrupt APL data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my @rdata; my $aplist = $self->{aplist}; foreach (@$aplist) { my $address = $_->{address}; $address =~ s/[\000]+$//; # strip trailing null octets my $xlength = ( $_->{negate} ? 0x80 : 0 ) | length($address); push @rdata, pack 'n C2 a*', @{$_}{qw(family prefix)}, $xlength, $address; } return join '', @rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $aplist = $self->{aplist}; my @rdata = map { $_->string } @$aplist; return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->aplist(@argument); return; } sub aplist { my ( $self, @argument ) = @_; while ( scalar @argument ) { # parse apitem strings last unless $argument[0] =~ m#[!:./]#; local $_ = shift @argument; m#^(!?)(\d+):(.+)/(\d+)$#; my $n = $1 ? 1 : 0; my $f = $2 || 0; my $a = $3; my $p = $4 || 0; $self->aplist( negate => $n, family => $f, address => $a, prefix => $p ); } my $aplist = $self->{aplist} ||= []; if ( my %argval = @argument ) { # parse attribute=value list my $item = bless {}, 'Net::DNS::RR::APL::Item'; while ( my ( $attribute, $value ) = each %argval ) { $item->$attribute($value) unless $attribute eq 'address'; } $item->address( $argval{address} ); # address must be last push @$aplist, $item; } my @ap = @$aplist; return unless defined wantarray; return wantarray ? @ap : join ' ', map { $_->string } @ap; } ######################################## package Net::DNS::RR::APL::Item; ## no critic ProhibitMultiplePackages use Net::DNS::RR::A; use Net::DNS::RR::AAAA; my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); sub negate { my ( $self, @value ) = @_; for (@value) { return $self->{negate} = $_ } return $self->{negate}; } sub family { my ( $self, @value ) = @_; for (@value) { $self->{family} = 0 + $_ } return $self->{family} || 0; } sub prefix { my ( $self, @value ) = @_; for (@value) { $self->{prefix} = 0 + $_ } return $self->{prefix} || 0; } sub address { my ( $self, @value ) = @_; my $family = $family{$self->family} || die 'unknown address family'; return bless( {%$self}, $family )->address unless scalar @value; my $bitmask = $self->prefix; my $address = bless( {}, $family )->address( shift @value ); return $self->{address} = pack "B$bitmask", unpack 'B*', $address; } sub string { my $self = shift; my $not = $self->{negate} ? '!' : ''; my ( $family, $address, $prefix ) = ( $self->family, $self->address, $self->prefix ); return "$not$family:$address/$prefix"; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN APL aplist'); =head1 DESCRIPTION DNS Address Prefix List (APL) record =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 aplist @aplist = $rr->aplist; @aplist = $rr->aplist( '1:192.168.32.0/21', '!1:192.168.38.0/28' ); @aplist = $rr->aplist( '1:224.0.0.0/4', '2:FF00:0:0:0:0:0:0:0/8' ); @aplist = $rr->aplist( negate => 1, family => 1, address => '192.168.38.0', prefix => 28, ); Ordered, possibly empty, list of address prefix items. Additional items, if present, are appended to the existing list with neither prefix aggregation nor reordering. =head2 Net::DNS::RR::APL::Item Each element of the prefix list is a Net::DNS::RR::APL::Item object which is inextricably bound to the APL record which created it. =head2 negate $rr->negate(1); if ( $rr->negate ) { ... } Boolean attribute indicating the prefix to be an address range exclusion. =head2 family $family = $rr->family; $rr->family( $family ); Address family discriminant. =head2 prefix $prefix = $rr->prefix; $rr->prefix( $prefix ); Number of bits comprising the address prefix. =head2 address $address = $object->address; Address portion of the prefix list item. =head2 string $string = $object->string; Returns the prefix list item in the form required in zone files. =head1 COPYRIGHT Copyright (c)2008 Olaf Kolkman, NLnet Labs. Portions Copyright (c)2011,2017 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/RRSIG.pm000044400000057021152345050350006744 0ustar00package Net::DNS::RR::RRSIG; use strict; use warnings; our $VERSION = (qw$Id: RRSIG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::RRSIG - DNS RRSIG resource record =cut use integer; use Carp; use Time::Local; use Net::DNS::Parameters qw(:type); use constant DEBUG => 0; use constant UTIL => defined eval { require Scalar::Util; }; eval { require MIME::Base64 }; ## IMPORTANT: MUST NOT include crypto packages in metadata (strong crypto prohibited in many territories) use constant DNSSEC => defined $INC{'Net/DNS/SEC.pm'}; ## Discover how we got here, without exposing any crypto my @index; if (DNSSEC) { foreach my $class ( map {"Net::DNS::SEC::$_"} qw(Private RSA DSA ECDSA EdDSA Digest SM2) ) { my @algorithms = eval join '', qw(r e q u i r e), " $class; ${class}::_index()"; ## no critic push @index, map { ( $_ => $class ) } @algorithms; } croak 'Net::DNS::SEC version not supported' unless scalar(@index); } my %DNSSEC_verify = @index; my %DNSSEC_siggen = @index; my @deprecated = ( 1, 3, 6, 12 ); # RFC8624 delete @DNSSEC_siggen{@deprecated}; my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; ( $self->{signame}, $offset ) = Net::DNS::DomainName->decode( $data, $offset + 18, @opaque ); $self->{sigbin} = substr $$data, $offset, $limit - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $signame = $self->{signame}; return pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->canonical, $self->sigbin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $signame = $self->{signame}; my @sig64 = split /\s+/, MIME::Base64::encode( $self->sigbin ); my @rdata = ( map( { $self->$_ } @field ), $signame->string, @sig64 ); $rdata[3] .= "\n"; return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach ( @field, qw(signame) ) { $self->$_( shift @argument ) } $self->signature(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->sigval(30); return; } sub typecovered { my ( $self, @value ) = @_; for (@value) { $self->{typecovered} = typebyname($_) } my $typecode = $self->{typecovered}; return defined $typecode ? typebyval($typecode) : undef; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; return $self->{algorithm} = _algbyname($arg); } sub labels { my ( $self, @value ) = @_; for (@value) { $self->{labels} = 0 + $_ } return $self->{labels} || 0; } sub orgttl { my ( $self, @value ) = @_; for (@value) { $self->{orgttl} = 0 + $_ } return $self->{orgttl} || 0; } sub sigexpiration { my ( $self, @value ) = @_; for (@value) { $self->{sigexpiration} = _string2time($_) } my $time = $self->{sigexpiration}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub siginception { my ( $self, @value ) = @_; for (@value) { $self->{siginception} = _string2time($_) } my $time = $self->{siginception}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub sigex { return &sigexpiration; } ## historical sub sigin { return &siginception; } ## historical sub sigval { my ( $self, @value ) = @_; no integer; return ( $self->{sigval} ) = map { int( 86400 * $_ ) } @value; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub signame { my ( $self, @value ) = @_; for (@value) { $self->{signame} = Net::DNS::DomainName->new($_) } return $self->{signame} ? $self->{signame}->name : undef; } sub sig { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @value; return $self->sigbin( MIME::Base64::decode( join "", @value ) ); } sub sigbin { my ( $self, @value ) = @_; for (@value) { $self->{sigbin} = $_ } return $self->{sigbin} || ""; } sub signature { return &sig; } sub create { unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $class, $rrsetref, $priv_key, %etc ) = @_; $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY'; my $RR = $rrsetref->[0]; croak '$rrsetref is not reference to RR array' unless ref($RR) =~ /^Net::DNS::RR/; # All the TTLs need to be the same in the data RRset. my $ttl = $RR->ttl; croak 'RRs in RRset do not have same TTL' if grep { $_->ttl != $ttl } @$rrsetref; my $private = ref($priv_key) ? $priv_key : Net::DNS::SEC::Private->new($priv_key); croak 'unable to parse private key' unless ref($private) eq 'Net::DNS::SEC::Private'; my @label = grep { $_ ne chr(42) } $RR->{owner}->_wire; # count labels my $self = Net::DNS::RR->new( name => $RR->name, type => 'RRSIG', class => 'IN', ttl => $ttl, typecovered => $RR->type, labels => scalar @label, orgttl => $ttl, siginception => time(), algorithm => $private->algorithm, keytag => $private->keytag, signame => $private->signame, ); while ( my ( $attribute, $value ) = each %etc ) { $self->$attribute($value); } $self->{sigexpiration} = $self->{siginception} + $self->{sigval} unless $self->{sigexpiration}; my $sigdata = $self->_CreateSigData($rrsetref); $self->_CreateSig( $sigdata, $private ); return $self; } } sub verify { # Reminder... # $rrsetref must be a reference to an array of RR objects. # $keyref is either a key object or a reference to an array of key objects. unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $self, $rrsetref, $keyref ) = @_; croak '$keyref argument is scalar or undefined' unless ref($keyref); print '$keyref argument is ', ref($keyref), "\n" if DEBUG; if ( ref($keyref) eq "ARRAY" ) { # We will iterate over the supplied key list and # return when there is a successful verification. # If not, continue so that we survive key-id collision. print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; my @error; foreach my $keyrr (@$keyref) { my $result = $self->verify( $rrsetref, $keyrr ); return $result if $result; my $error = $self->{vrfyerrstr}; my $keyid = $keyrr->keytag; push @error, "key $keyid: $error"; print "key $keyid: $error\n" if DEBUG; next; } $self->{vrfyerrstr} = join "\n", @error; return 0; } elsif ( $keyref->isa('Net::DNS::RR::DNSKEY') ) { print "Validating using key with keytag: ", $keyref->keytag, "\n" if DEBUG; } else { croak join ' ', ref($keyref), 'can not be used as DNSSEC key'; } $rrsetref = [$rrsetref] unless ref($rrsetref) eq 'ARRAY'; my $RR = $rrsetref->[0]; croak '$rrsetref not a reference to array of RRs' unless ref($RR) =~ /^Net::DNS::RR/; if (DEBUG) { print "\n ---------------------- RRSIG DEBUG --------------------"; print "\n SIG:\t", $self->string; print "\n KEY:\t", $keyref->string; print "\n -------------------------------------------------------\n"; } $self->{vrfyerrstr} = ''; unless ( $self->algorithm == $keyref->algorithm ) { $self->{vrfyerrstr} = 'algorithm does not match'; return 0; } unless ( $self->keytag == $keyref->keytag ) { $self->{vrfyerrstr} = 'keytag does not match'; return 0; } my $sigdata = $self->_CreateSigData($rrsetref); $self->_VerifySig( $sigdata, $keyref ) || return 0; # time to do some time checking. my $t = time; if ( _ordered( $self->{sigexpiration}, $t ) ) { $self->{vrfyerrstr} = join ' ', 'Signature expired at', $self->sigexpiration; return 0; } elsif ( _ordered( $t, $self->{siginception} ) ) { $self->{vrfyerrstr} = join ' ', 'Signature valid from', $self->siginception; return 0; } return 1; } } #END verify sub vrfyerrstr { my $self = shift; return $self->{vrfyerrstr}; } ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } sub _CreateSigData { # This method creates the data string that will be signed. # See RFC4034(6) and RFC6840(5.1) on how this string is constructed # This method is called by the method that creates a signature # and by the method that verifies the signature. It is assumed # that the creation method has checked that all the TTLs are # the same for the rrsetref and that sig->orgttl has been set # to the TTL of the data. This method will set the datarr->ttl # to the sig->orgttl for all the RR in the rrsetref. if (DNSSEC) { my ( $self, $rrsetref ) = @_; print "_CreateSigData\n" if DEBUG; my $sigdata = pack 'n C2 N3 n a*', @{$self}{@field}, $self->{signame}->canonical; print "\npreamble\t", unpack( 'H*', $sigdata ), "\n" if DEBUG; my $owner = $self->{owner}; # create wildcard domain name my $limit = $self->{labels}; my @label = $owner->_wire; shift @label while scalar @label > $limit; my $wild = bless {label => \@label}, ref($owner); # DIY to avoid wrecking name cache my $suffix = $wild->canonical; unshift @label, chr(42); # asterisk my @RR = map { bless( {%$_}, ref($_) ) } @$rrsetref; # shallow RR clone my $rr = $RR[0]; my $class = $rr->class; my $type = $rr->type; my $ttl = $self->orgttl; my %table; foreach my $RR (@RR) { my $ident = $RR->{owner}->canonical; my $match = substr $ident, -length($suffix); croak 'RRs in RRset have different NAMEs' if $match ne $suffix; croak 'RRs in RRset have different TYPEs' if $type ne $RR->type; croak 'RRs in RRset have different CLASS' if $class ne $RR->class; $RR->ttl($ttl); # reset TTL my $offset = 10 + length($suffix); # RDATA offset if ( $ident ne $match ) { $RR->{owner} = $wild; $offset += 2; print "\nsubstituting wildcard name: ", $RR->name if DEBUG; } # For sorting we create a hash table of canonical data keyed on RDATA my $canonical = $RR->canonical; $table{substr $canonical, $offset} = $canonical; } $sigdata = join '', $sigdata, map { $table{$_} } sort keys %table; if (DEBUG) { my $i = 0; foreach my $rdata ( sort keys %table ) { print "\n>>> ", $i++, "\tRDATA:\t", unpack 'H*', $rdata; print "\nRR: ", unpack( 'H*', $table{$rdata} ), "\n"; } print "\n sigdata:\t", unpack( 'H*', $sigdata ), "\n"; } return $sigdata; } } sub _CreateSig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; return eval { my $class = $DNSSEC_siggen{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $self->sigbin( $class->sign(@argument) ); } || return croak "${@}signature generation failed"; } } sub _VerifySig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; my $returnval = eval { my $class = $DNSSEC_verify{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $class->verify( @argument, $self->sigbin ); }; unless ($returnval) { $self->{vrfyerrstr} = "${@}signature verification failed"; print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; return 0; } # uncoverable branch true # unexpected return value from EVP_DigestVerify croak "internal error in algorithm $algorithm verification" unless $returnval == 1; print "\nalgorithm $algorithm verification successful\n" if DEBUG; return $returnval; } } sub _ordered() { ## irreflexive 32-bit partial ordering my ( $n1, $n2 ) = @_; return 0 unless defined $n2; # ( any, undef ) return 1 unless defined $n1; # ( undef, any ) # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished use integer; # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ ( $n2 & 0x80000000 ); # -2**31 <= $n1 < 2**32 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) ); } my $y1998 = timegm( 0, 0, 0, 1, 0, 1998 ); my $y2026 = timegm( 0, 0, 0, 1, 0, 2026 ); my $y2082 = $y2026 << 1; my $y2054 = $y2082 - $y1998; my $m2026 = int( 0x80000000 - $y2026 ); my $m2054 = int( 0x80000000 - $y2054 ); my $t2082 = int( $y2082 & 0x7FFFFFFF ); my $t2100 = 1960058752; sub _string2time { ## parse time specification string my $arg = shift; return int($arg) if length($arg) < 12; my ( $y, $m, @dhms ) = unpack 'a4 a2 a2 a2 a2 a2', $arg . '00'; if ( $arg lt '20380119031408' ) { # calendar folding return timegm( reverse(@dhms), $m - 1, $y ) if $y < 2026; return timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2026; } elsif ( $y > 2082 ) { my $z = timegm( reverse(@dhms), $m - 1, $y - 84 ); # expunge 29 Feb 2100 return $z < 1456790400 ? $z + $y2054 : $z + $y2054 - 86400; } return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998; } sub _time2string { ## format time specification string my $arg = shift; my $ls31 = int( $arg & 0x7FFFFFFF ); if ( $arg & 0x80000000 ) { if ( $ls31 > $t2082 ) { $ls31 += 86400 unless $ls31 < $t2100; # expunge 29 Feb 2100 my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2054 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1984, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } elsif ( $ls31 > $y2026 ) { my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 - $y2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime $ls31 )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1900, $mm + 1, @dhms; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name RRSIG typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature'); use Net::DNS::SEC; $sigrr = Net::DNS::RR::RRSIG->create( \@rrset, $keypath, sigex => 20241230010101, sigin => 20241201010101 ); $sigrr->verify( \@rrset, $keyrr ) || die $sigrr->vrfyerrstr; =head1 DESCRIPTION Class for DNS digital signature (RRSIG) resource records. In addition to the regular methods inherited from Net::DNS::RR the class contains a method to sign RRsets using private keys (create) and a method for verifying signatures over RRsets (verify). The RRSIG RR is an implementation of RFC4034. See L for an implementation of SIG0 (RFC2931). =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 typecovered $typecovered = $rr->typecovered; The typecovered field identifies the type of the RRset that is covered by this RRSIG record. =head2 algorithm $algorithm = $rr->algorithm; The algorithm number field identifies the cryptographic algorithm used to create the signature. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 labels $labels = $rr->labels; $rr->labels( $labels ); The labels field specifies the number of labels in the original RRSIG RR owner name. =head2 orgttl $orgttl = $rr->orgttl; $rr->orgttl( $orgttl ); The original TTL field specifies the TTL of the covered RRset as it appears in the authoritative zone. =head2 sigexpiration and siginception times =head2 sigex sigin sigval $expiration = $rr->sigexpiration; $expiration = $rr->sigexpiration( $value ); $inception = $rr->siginception; $inception = $rr->siginception( $value ); The signature expiration and inception fields specify a validity time interval for the signature. The value may be specified by a string with format 'yyyymmddhhmmss' or a Perl time() value. Return values are dual-valued, providing either a string value or numerical Perl time() value. =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); The keytag field contains the key tag value of the DNSKEY RR that validates this signature. =head2 signame $signame = $rr->signame; $rr->signame( $signame ); The signer name field value identifies the owner name of the DNSKEY RR that a validator is supposed to use to validate this signature. =head2 signature =head2 sig $sig = $rr->sig; $rr->sig( $sig ); The Signature field contains the cryptographic signature that covers the RRSIG RDATA (excluding the Signature field) and the RRset specified by the RRSIG owner name, RRSIG class, and RRSIG type covered fields. =head2 sigbin $sigbin = $rr->sigbin; $rr->sigbin( $sigbin ); Binary representation of the cryptographic signature. =head2 create Create a signature over a RR set. use Net::DNS::SEC; $keypath = '/home/olaf/keys/Kbla.foo.+001+60114.private'; $sigrr = Net::DNS::RR::RRSIG->create( \@rrsetref, $keypath ); $sigrr = Net::DNS::RR::RRSIG->create( \@rrsetref, $keypath, sigex => 20241230010101, sigin => 20241201010101 ); $sigrr->print; # Alternatively use Net::DNS::SEC::Private $private = Net::DNS::SEC::Private->new($keypath); $sigrr= Net::DNS::RR::RRSIG->create( \@rrsetref, $private ); create() is an alternative constructor for a RRSIG RR object. This method returns an RRSIG with the signature over the subject rrset (an array of RRs) made with the private key stored in the key file. The first argument is a reference to an array that contains the RRset that needs to be signed. The second argument is a string which specifies the path to a file containing the private key as generated by dnssec-keygen. The optional remaining arguments consist of ( name => value ) pairs as follows: sigex => 20241230010101, # signature expiration sigin => 20241201010101, # signature inception sigval => 30, # validity window (days) ttl => 3600 The sigin and sigex values may be specified as Perl time values or as a string with the format 'yyyymmddhhmmss'. The default for sigin is the time of signing. The sigval argument specifies the signature validity window in days ( sigex = sigin + sigval ). By default the signature is valid for 30 days. By default the TTL matches the RRset that is presented for signing. =head2 verify $verify = $sigrr->verify( $rrsetref, $keyrr ); $verify = $sigrr->verify( $rrsetref, [$keyrr, $keyrr2, $keyrr3] ); $rrsetref contains a reference to an array of RR objects and the method verifies the RRset against the signature contained in the $sigrr object itself using the public key in $keyrr. The second argument can either be a Net::DNS::RR::KEYRR object or a reference to an array of such objects. Verification will return successful as soon as one of the keys in the array leads to positive validation. Returns 0 on error and sets $sig->vrfyerrstr =head2 vrfyerrstr $verify = $sigrr->verify( $rrsetref, $keyrr ); print $sigrr->vrfyerrstr unless $verify; $sigrr->verify( $rrsetref, $keyrr ) || die $sigrr->vrfyerrstr; =head1 KEY GENERATION Private key files and corresponding public DNSKEY records are most conveniently generated using dnssec-keygen, a program that comes with the ISC BIND distribution. dnssec-keygen -a 10 -b 2048 rsa.example. dnssec-keygen -a 13 -f ksk ecdsa.example. dnssec-keygen -a 13 ecdsa.example. Do not change the name of the private key file. The create method uses the filename as generated by dnssec-keygen to determine the keyowner, algorithm, and the keyid (keytag). =head1 REMARKS The code is not optimised for speed. It is probably not suitable to be used for signing large zones. If this code is still around in 2100 (not a leap year) you will need to check for proper handling of times after 28th February. =head1 ACKNOWLEDGMENTS Although their original code may have disappeared following redesign of Net::DNS, Net::DNS::SEC and the OpenSSL API, the following individual contributors deserve to be recognised for their significant influence on the development of the RRSIG package. Andy Vaskys (Network Associates Laboratories) supplied code for RSA. T.J. Mather provided support for the DSA algorithm. Dick Franks added support for elliptic curve and Edwards curve algorithms. Mike McCauley created the Crypt::OpenSSL::ECDSA perl extension module specifically for this development. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC, Olaf M. Kolkman Copyright (c)2007-2008 NLnet Labs, Olaf M. Kolkman Portions Copyright (c)2014 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L =cut DNS/RR/DHCID.pm000044400000010010152345050350006654 0ustar00package Net::DNS::RR::DHCID; use strict; use warnings; our $VERSION = (qw$Id: DHCID.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DHCID - DNS DHCID resource record =cut use integer; use MIME::Base64; sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = split /\s+/, encode_base64( $self->_encode_rdata ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->rdata( MIME::Base64::decode( join "", @argument ) ); return; } # +------------------+------------------------------------------------+ # | Identifier Type | Identifier | # | Code | | # +------------------+------------------------------------------------+ # | 0x0000 | The 1-octet 'htype' followed by 'hlen' octets | # | | of 'chaddr' from a DHCPv4 client's DHCPREQUEST | # | | [7]. | # | 0x0001 | The data octets (i.e., the Type and | # | | Client-Identifier fields) from a DHCPv4 | # | | client's Client Identifier option [10]. | # | 0x0002 | The client's DUID (i.e., the data octets of a | # | | DHCPv6 client's Client Identifier option [11] | # | | or the DUID field from a DHCPv4 client's | # | | Client Identifier option [6]). | # | 0x0003 - 0xfffe | Undefined; available to be assigned by IANA. | # | 0xffff | Undefined; RESERVED. | # +------------------+------------------------------------------------+ sub identifiertype { return unpack 'n', shift->{rdata} || return } sub digesttype { return unpack 'x2C', shift->{rdata} || return } sub digest { return unpack 'x3a*', shift->{rdata} || return } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('client.example.com. DHCID ( AAAB xLmlskllE0MVjd57zHcWmEH3pCQ6VytcKD//7es/deY= )'); $rr = Net::DNS::RR->new( name => 'client.example.com', type => 'DHCID', digest => 'ObfuscatedIdentityData', digesttype => 1, identifiertype => 2, ); =head1 DESCRIPTION DNS RR for Encoding DHCP Information (DHCID) =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 identifiertype $identifiertype = $rr->identifiertype; The 16-bit identifier type describes the form of host identifier used to construct the DHCP identity information. =head2 digesttype $digesttype = $rr->digesttype; The 8-bit digest type number describes the message-digest algorithm used to obfuscate the DHCP identity information. =head2 digest $digest = $rr->digest; Binary representation of the digest of DHCP identity information. =head1 COPYRIGHT Copyright (c)2009 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/SIG.pm000044400000053524152345050350006504 0ustar00package Net::DNS::RR::SIG; use strict; use warnings; our $VERSION = (qw$Id: SIG.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SIG - DNS SIG resource record =cut use integer; use Carp; use Time::Local; use Net::DNS::Parameters qw(:type); use constant DEBUG => 0; use constant UTIL => defined eval { require Scalar::Util; }; eval { require MIME::Base64 }; ## IMPORTANT: MUST NOT include crypto packages in metadata (strong crypto prohibited in many territories) use constant DNSSEC => defined $INC{'Net/DNS/SEC.pm'}; ## Discover how we got here, without exposing any crypto my @index; if (DNSSEC) { foreach my $class ( map {"Net::DNS::SEC::$_"} qw(Private RSA DSA ECDSA EdDSA Digest SM2) ) { my @algorithms = eval join '', qw(r e q u i r e), " $class; ${class}::_index()"; ## no critic push @index, map { ( $_ => $class ) } @algorithms; } croak 'Net::DNS::SEC version not supported' unless scalar(@index); } my %DNSSEC_verify = @index; my %DNSSEC_siggen = @index; my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; ( $self->{signame}, $offset ) = Net::DNS::DomainName->decode( $data, $offset + 18, @opaque ); $self->{sigbin} = substr $$data, $offset, $limit - $offset; croak('misplaced or corrupt SIG') unless $limit == length $$data; my $raw = substr $$data, 0, $self->{offset}++; $self->{rawref} = \$raw; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $signame = $self->{signame}; if ( DNSSEC && !$self->{sigbin} ) { my ( undef, $packet ) = @opaque; my $private = delete $self->{private}; # one shot is all you get my $sigdata = $self->_CreateSigData($packet); $self->_CreateSig( $sigdata, $private || die 'missing key reference' ); } return pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->canonical, $self->sigbin; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $sname = $self->{signame} || return ''; my @sig64 = split /\s+/, MIME::Base64::encode( $self->sigbin ); my @rdata = ( map( { $self->$_ } @field ), $sname->string, @sig64 ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach ( @field, qw(signame) ) { $self->$_( shift @argument ) } $self->signature(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->class('ANY'); $self->typecovered('TYPE0'); $self->algorithm(1); $self->labels(0); $self->orgttl(0); $self->sigval(10); return; } sub typecovered { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{typecovered} = typebyname($_) } my $typecode = $self->{typecovered}; return defined $typecode ? typebyval($typecode) : undef; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if $arg =~ /MNEMONIC/i; return $self->{algorithm} = _algbyname($arg); } sub labels { return shift->{labels} = 0; # uncoverable pod } sub orgttl { return shift->{orgttl} = 0; # uncoverable pod } sub sigexpiration { my ( $self, @value ) = @_; for (@value) { $self->{sigexpiration} = _string2time($_) } my $time = $self->{sigexpiration}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub siginception { my ( $self, @value ) = @_; for (@value) { $self->{siginception} = _string2time($_) } my $time = $self->{siginception}; return unless defined wantarray && defined $time; return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); } sub sigex { return &sigexpiration; } ## historical sub sigin { return &siginception; } ## historical sub sigval { my ( $self, @value ) = @_; no integer; ( $self->{sigval} ) = map { int( 60.0 * $_ ) } @value; return; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub signame { my ( $self, @value ) = @_; for (@value) { $self->{signame} = Net::DNS::DomainName2535->new($_) } return $self->{signame} ? $self->{signame}->name : undef; } sub sig { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @value; return $self->sigbin( MIME::Base64::decode( join "", @value ) ); } sub sigbin { my ( $self, @value ) = @_; for (@value) { $self->{sigbin} = $_ } return $self->{sigbin} || ""; } sub signature { return &sig; } sub create { unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $class, $data, $priv_key, %etc ) = @_; my $private = ref($priv_key) ? $priv_key : ( Net::DNS::SEC::Private->new($priv_key) ); croak 'Unable to parse private key' unless ref($private) eq 'Net::DNS::SEC::Private'; my $self = Net::DNS::RR->new( type => 'SIG', typecovered => 'TYPE0', siginception => time(), algorithm => $private->algorithm, keytag => $private->keytag, signame => $private->signame, ); while ( my ( $attribute, $value ) = each %etc ) { $self->$attribute($value); } $self->{sigexpiration} = $self->{siginception} + $self->{sigval} unless $self->{sigexpiration}; $self->_CreateSig( $self->_CreateSigData($data), $private ) if $data; $self->{private} = $private unless $data; # mark packet for SIG0 generation return $self; } } sub verify { # Reminder... # $dataref may be either a data string or a reference to a # Net::DNS::Packet object. # # $keyref is either a key object or a reference to an array # of keys. unless (DNSSEC) { croak qq[No "use Net::DNS::SEC" declaration in application code]; } else { my ( $self, $dataref, $keyref ) = @_; if ( my $isa = ref($dataref) ) { print '$dataref argument is ', $isa, "\n" if DEBUG; croak '$dataref must be scalar or a Net::DNS::Packet' unless $isa =~ /Net::DNS/ && $dataref->isa('Net::DNS::Packet'); } print '$keyref argument is of class ', ref($keyref), "\n" if DEBUG; if ( ref($keyref) eq "ARRAY" ) { # We will iterate over the supplied key list and # return when there is a successful verification. # If not, continue so that we survive key-id collision. print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; my @error; foreach my $keyrr (@$keyref) { my $result = $self->verify( $dataref, $keyrr ); return $result if $result; my $error = $self->{vrfyerrstr}; my $keyid = $keyrr->keytag; push @error, "key $keyid: $error"; print "key $keyid: $error\n" if DEBUG; next; } $self->{vrfyerrstr} = join "\n", @error; return 0; } elsif ( $keyref->isa('Net::DNS::RR::DNSKEY') ) { print "Validating using key with keytag: ", $keyref->keytag, "\n" if DEBUG; } else { croak join ' ', ref($keyref), 'can not be used as SIG0 key'; } croak "SIG typecovered is TYPE$self->{typecovered}" if $self->{typecovered}; if (DEBUG) { print "\n ---------------------- SIG DEBUG ----------------------"; print "\n SIG:\t", $self->string; print "\n KEY:\t", $keyref->string; print "\n -------------------------------------------------------\n"; } $self->{vrfyerrstr} = ''; unless ( $self->algorithm == $keyref->algorithm ) { $self->{vrfyerrstr} = 'algorithm does not match'; return 0; } unless ( $self->keytag == $keyref->keytag ) { $self->{vrfyerrstr} = 'keytag does not match'; return 0; } # The data that is to be verified my $sigdata = $self->_CreateSigData($dataref); my $verified = $self->_VerifySig( $sigdata, $keyref ) || return 0; # time to do some time checking. my $t = time; if ( _ordered( $self->{sigexpiration}, $t ) ) { $self->{vrfyerrstr} = join ' ', 'Signature expired at', $self->sigexpiration; return 0; } elsif ( _ordered( $t, $self->{siginception} ) ) { $self->{vrfyerrstr} = join ' ', 'Signature valid from', $self->siginception; return 0; } return 1; } } #END verify sub vrfyerrstr { return shift->{vrfyerrstr}; } ######################################## { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } { my %siglen = ( 1 => 128, 3 => 41, 5 => 256, 6 => 41, 7 => 256, 8 => 256, 10 => 256, 12 => 64, 13 => 64, 14 => 96, 15 => 64, 16 => 114, ); sub _size { ## estimate encoded size my $self = shift; my $clone = bless {%$self}, ref($self); # shallow clone $clone->sigbin( 'x' x $siglen{$self->algorithm} ); return length $clone->encode(); } } sub _CreateSigData { if (DNSSEC) { my ( $self, $message ) = @_; if ( ref($message) ) { die 'missing packet reference' unless $message->isa('Net::DNS::Packet'); my @unsigned = grep { ref($_) ne ref($self) } @{$message->{additional}}; local $message->{additional} = \@unsigned; # remake header image my @part = qw(question answer authority additional); my @size = map { scalar @{$message->{$_}} } @part; my $rref = delete $self->{rawref}; my $data = $rref ? $$rref : $message->encode; my ( $id, $status ) = unpack 'n2', $data; my $hbin = pack 'n6 a*', $id, $status, @size; $message = $hbin . substr $data, length $hbin; } my $sigdata = pack 'n C2 N3 n a*', @{$self}{@field}, $self->{signame}->encode; print "\npreamble\t", unpack( 'H*', $sigdata ), "\nrawdata\t", unpack( 'H100', $message ), " ...\n" if DEBUG; return join '', $sigdata, $message; } } sub _CreateSig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; return eval { my $class = $DNSSEC_siggen{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $self->sigbin( $class->sign(@argument) ); } || return croak "${@}signature generation failed"; } } sub _VerifySig { if (DNSSEC) { my ( $self, @argument ) = @_; my $algorithm = $self->algorithm; my $returnval = eval { my $class = $DNSSEC_verify{$algorithm}; die "algorithm $algorithm not supported\n" unless $class; $class->verify( @argument, $self->sigbin ); }; unless ($returnval) { $self->{vrfyerrstr} = "${@}signature verification failed"; print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; return 0; } # uncoverable branch true # unexpected return value from EVP_DigestVerify croak "internal error in algorithm $algorithm verification" unless $returnval == 1; print "\nalgorithm $algorithm verification successful\n" if DEBUG; return $returnval; } } sub _ordered() { ## irreflexive 32-bit partial ordering my ( $n1, $n2 ) = @_; return 0 unless defined $n2; # ( any, undef ) return 1 unless defined $n1; # ( undef, any ) # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished use integer; # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ ( $n2 & 0x80000000 ); # -2**31 <= $n1 < 2**32 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) ); } my $y1998 = timegm( 0, 0, 0, 1, 0, 1998 ); my $y2026 = timegm( 0, 0, 0, 1, 0, 2026 ); my $y2082 = $y2026 << 1; my $y2054 = $y2082 - $y1998; my $m2026 = int( 0x80000000 - $y2026 ); my $m2054 = int( 0x80000000 - $y2054 ); my $t2082 = int( $y2082 & 0x7FFFFFFF ); my $t2100 = 1960058752; sub _string2time { ## parse time specification string my $arg = shift; return int($arg) if length($arg) < 12; my ( $y, $m, @dhms ) = unpack 'a4 a2 a2 a2 a2 a2', $arg . '00'; if ( $arg lt '20380119031408' ) { # calendar folding return timegm( reverse(@dhms), $m - 1, $y ) if $y < 2026; return timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2026; } elsif ( $y > 2082 ) { my $z = timegm( reverse(@dhms), $m - 1, $y - 84 ); # expunge 29 Feb 2100 return $z < 1456790400 ? $z + $y2054 : $z + $y2054 - 86400; } return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998; } sub _time2string { ## format time specification string my $arg = shift; my $ls31 = int( $arg & 0x7FFFFFFF ); if ( $arg & 0x80000000 ) { if ( $ls31 > $t2082 ) { $ls31 += 86400 unless $ls31 < $t2100; # expunge 29 Feb 2100 my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2054 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1984, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 + $m2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } elsif ( $ls31 > $y2026 ) { my ( $yy, $mm, @dhms ) = reverse( ( gmtime( $ls31 - $y2026 ) )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1956, $mm + 1, @dhms; } my ( $yy, $mm, @dhms ) = reverse( ( gmtime $ls31 )[0 .. 5] ); return sprintf '%d%02d%02d%02d%02d%02d', $yy + 1900, $mm + 1, @dhms; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SIG typecovered algorithm labels orgttl sigexpiration siginception keytag signame signature'); use Net::DNS::SEC; $sigrr = Net::DNS::RR::SIG->create( $string, $keypath, sigval => 10 # minutes ); $sigrr->verify( $string, $keyrr ) || die $sigrr->vrfyerrstr; $sigrr->verify( $packet, $keyrr ) || die $sigrr->vrfyerrstr; =head1 DESCRIPTION Class for DNS digital signature (SIG) resource records. In addition to the regular methods inherited from Net::DNS::RR the class contains a method to sign packets and scalar data strings using private keys (create) and a method for verifying signatures. The SIG RR is an implementation of RFC2931. See L for an implementation of RFC4034. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; The algorithm number field identifies the cryptographic algorithm used to create the signature. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 sigexpiration and siginception times =head2 sigex sigin sigval $expiration = $rr->sigexpiration; $expiration = $rr->sigexpiration( $value ); $inception = $rr->siginception; $inception = $rr->siginception( $value ); The signature expiration and inception fields specify a validity time interval for the signature. The value may be specified by a string with format 'yyyymmddhhmmss' or a Perl time() value. Return values are dual-valued, providing either a string value or numerical Perl time() value. =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); The keytag field contains the key tag value of the KEY RR that validates this signature. =head2 signame $signame = $rr->signame; $rr->signame( $signame ); The signer name field value identifies the owner name of the KEY RR that a validator is supposed to use to validate this signature. =head2 signature =head2 sig $sig = $rr->sig; $rr->sig( $sig ); The Signature field contains the cryptographic signature that covers the SIG RDATA (excluding the Signature field) and the subject data. =head2 sigbin $sigbin = $rr->sigbin; $rr->sigbin( $sigbin ); Binary representation of the cryptographic signature. =head2 create Create a signature over scalar data. use Net::DNS::SEC; $keypath = '/home/olaf/keys/Kbla.foo.+001+60114.private'; $sigrr = Net::DNS::RR::SIG->create( $data, $keypath ); $sigrr = Net::DNS::RR::SIG->create( $data, $keypath, sigval => 10 ); $sigrr->print; # Alternatively use Net::DNS::SEC::Private $private = Net::DNS::SEC::Private->new($keypath); $sigrr= Net::DNS::RR::SIG->create( $data, $private ); create() is an alternative constructor for a SIG RR object. This method returns a SIG with the signature over the data made with the private key stored in the key file. The first argument is a scalar that contains the data to be signed. The second argument is a string which specifies the path to a file containing the private key as generated using dnssec-keygen, a program that comes with the ISC BIND distribution. The optional remaining arguments consist of ( name => value ) pairs as follows: sigin => 20241201010101, # signature inception sigex => 20241201011101, # signature expiration sigval => 10, # validity window (minutes) The sigin and sigex values may be specified as Perl time values or as a string with the format 'yyyymmddhhmmss'. The default for sigin is the time of signing. The sigval argument specifies the signature validity window in minutes ( sigex = sigin + sigval ). By default the signature is valid for 10 minutes. =head2 verify $verify = $sigrr->verify( $data, $keyrr ); $verify = $sigrr->verify( $data, [$keyrr, $keyrr2, $keyrr3] ); The verify() method performs SIG0 verification of the specified data against the signature contained in the $sigrr object itself using the public key in $keyrr. If a reference to a Net::DNS::Packet is supplied, the method performs a SIG0 verification on the packet data. The second argument can either be a Net::DNS::RR::KEYRR object or a reference to an array of such objects. Verification will return successful as soon as one of the keys in the array leads to positive validation. Returns false on error and sets $sig->vrfyerrstr =head2 vrfyerrstr $sig0 = $packet->sigrr || die 'not signed'; print $sig0->vrfyerrstr unless $sig0->verify( $packet, $keyrr ); $sigrr->verify( $packet, $keyrr ) || die $sigrr->vrfyerrstr; =head1 KEY GENERATION Private key files and corresponding public DNSKEY records are most conveniently generated using dnssec-keygen, a program that comes with the ISC BIND distribution. dnssec-keygen -a 10 -b 2048 rsa.example. dnssec-keygen -a 13 -f ksk ecdsa.example. dnssec-keygen -a 13 ecdsa.example. Do not change the name of the private key file. The create method uses the filename as generated by dnssec-keygen to determine the keyowner, algorithm, and the keyid (keytag). =head1 REMARKS The code is not optimised for speed. If this code is still around in 2100 (not a leap year) you will need to check for proper handling of times after 28th February. =head1 ACKNOWLEDGMENTS Although their original code may have disappeared following redesign of Net::DNS, Net::DNS::SEC and the OpenSSL API, the following individual contributors deserve to be recognised for their significant influence on the development of the SIG package. Andy Vaskys (Network Associates Laboratories) supplied code for RSA. T.J. Mather provided support for the DSA algorithm. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC, Olaf M. Kolkman Copyright (c)2007-2008 NLnet Labs, Olaf M. Kolkman Portions Copyright (c)2014 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L L L =cut DNS/RR/MG.pm000044400000005443152345050350006362 0ustar00package Net::DNS::RR::MG; use strict; use warnings; our $VERSION = (qw$Id: MG.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MG - DNS MG resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{mgmname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; return $self->{mgmname}->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{mgmname}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->mgmname(@argument); return; } sub mgmname { my ( $self, @value ) = @_; for (@value) { $self->{mgmname} = Net::DNS::DomainName1035->new($_) } return $self->{mgmname} ? $self->{mgmname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name MG mgmname'); =head1 DESCRIPTION Class for DNS Mail Group (MG) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 mgmname $mgmname = $rr->mgmname; $rr->mgmname( $mgmname ); A domain name which specifies a mailbox which is a member of the mail group specified by the owner name. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/SMIMEA.pm000044400000012375152345050350007034 0ustar00package Net::DNS::RR::SMIMEA; use strict; use warnings; our $VERSION = (qw$Id: SMIMEA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SMIMEA - DNS SMIMEA resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $next = $offset + $self->{rdlength}; @{$self}{qw(usage selector matchingtype)} = unpack "\@$offset C3", $$data; $offset += 3; $self->{certbin} = substr $$data, $offset, $next - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C3 a*', @{$self}{qw(usage selector matchingtype certbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; $self->_annotation( $self->babble ) if BABBLE; my @cert = split /(\S{64})/, $self->cert; my @rdata = ( $self->usage, $self->selector, $self->matchingtype, @cert ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(usage selector matchingtype)) { $self->$_( shift @argument ) } $self->cert(@argument); return; } sub usage { my ( $self, @value ) = @_; for (@value) { $self->{usage} = 0 + $_ } return $self->{usage} || 0; } sub selector { my ( $self, @value ) = @_; for (@value) { $self->{selector} = 0 + $_ } return $self->{selector} || 0; } sub matchingtype { my ( $self, @value ) = @_; for (@value) { $self->{matchingtype} = 0 + $_ } return $self->{matchingtype} || 0; } sub cert { my ( $self, @value ) = @_; return unpack "H*", $self->certbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->certbin( pack "H*", join "", @hex ); } sub certbin { my ( $self, @value ) = @_; for (@value) { $self->{certbin} = $_ } return $self->{certbin} || ""; } sub certificate { return &cert; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SMIMEA usage selector matchingtype certificate'); =head1 DESCRIPTION The SMIMEA DNS resource record (RR) is used to associate an end entity certificate or public key with the associated email address, thus forming a "SMIMEA certificate association". The semantics of how the SMIMEA RR is interpreted are described in RFC6698. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 usage $usage = $rr->usage; $rr->usage( $usage ); 8-bit integer value which specifies the provided association that will be used to match the certificate. =head2 selector $selector = $rr->selector; $rr->selector( $selector ); 8-bit integer value which specifies which part of the certificate presented by the server will be matched against the association data. =head2 matchingtype $matchingtype = $rr->matchingtype; $rr->matchingtype( $matchingtype ); 8-bit integer value which specifies how the certificate association is presented. =head2 certificate =head2 cert $cert = $rr->cert; $rr->cert( $cert ); Hexadecimal representation of the certificate data. =head2 certbin $certbin = $rr->certbin; $rr->certbin( $certbin ); Binary representation of the certificate data. =head2 babble print $rr->babble; The babble() method returns the 'BubbleBabble' representation of the digest if the Digest::BubbleBabble package is available, otherwise an empty string is returned. BubbleBabble represents a message digest as a string of plausible words, to make the digest easier to verify. The "words" are not necessarily real words, but they look more like words than a string of hex characters. The 'BubbleBabble' string is appended as a comment when the string method is called. =head1 COPYRIGHT Copyright (c)2016 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/MB.pm000044400000005375152345050350006361 0ustar00package Net::DNS::RR::MB; use strict; use warnings; our $VERSION = (qw$Id: MB.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MB - DNS MB resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{madname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; return $self->{madname}->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{madname}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->madname(@argument); return; } sub madname { my ( $self, @value ) = @_; for (@value) { $self->{madname} = Net::DNS::DomainName1035->new($_) } return $self->{madname} ? $self->{madname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name MB madname'); =head1 DESCRIPTION Class for DNS Mailbox (MB) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 madname $madname = $rr->madname; $rr->madname( $madname ); A domain name which specifies a host which has the specified mailbox. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/NID.pm000044400000007371152345050350006473 0ustar00package Net::DNS::RR::NID; use strict; use warnings; our $VERSION = (qw$Id: NID.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NID - DNS NID resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(preference nodeid)} = unpack "\@$offset n a8", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n a8', $self->{preference}, $self->{nodeid}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->nodeid; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference nodeid)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub nodeid { my ( $self, $idnt ) = @_; $self->{nodeid} = pack 'n4', map { hex($_) } split /:/, $idnt if defined $idnt; return $self->{nodeid} ? join( ':', unpack 'H4H4H4H4', $self->{nodeid} ) : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN NID preference nodeid'); =head1 DESCRIPTION Class for DNS Node Identifier (NID) resource records. The Node Identifier (NID) DNS resource record is used to hold values for Node Identifiers that will be used for ILNP-capable nodes. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this NID record among other NID records associated with this owner name. Lower values are preferred over higher values. =head2 nodeid $nodeid = $rr->nodeid; The NodeID field is an unsigned 64-bit value in network byte order. The text representation uses the same syntax (i.e., groups of 4 hexadecimal digits separated by a colons) that is already used for IPv6 interface identifiers. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/RESINFO.pm000044400000005510152345050350007157 0ustar00package Net::DNS::RR::RESINFO; use strict; use warnings; our $VERSION = (qw$Id: RESINFO.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::TXT); =head1 NAME Net::DNS::RR::RESINFO - DNS RESINFO resource record =cut use integer; 1; __END__ =head1 SYNOPSIS use Net::DNS; my $target = 'resolver.example.net'; my $resolver = Net::DNS::Resolver->new( nameserver => $target, recurse => 0 ); $resolver->send( $target, 'RESINFO' )->print; ;; HEADER SECTION ;; id = 46638 ;; qr = 1 aa = 1 tc = 0 rd = 0 opcode = QUERY ;; ra = 0 z = 0 ad = 0 cd = 0 rcode = NOERROR ;; do = 0 co = 0 ;; qdcount = 1 ancount = 1 ;; nscount = 0 arcount = 0 ;; QUESTION SECTION (1 record) ;; resolver.example.net. IN RESINFO ;; ANSWER SECTION (1 record) resolver.example.net. 7200 IN RESINFO ( qnamemin exterr=15-17 infourl=https://resolver.example.com/guide ) ;; AUTHORITY SECTION (0 records) ;; ADDITIONAL SECTION (0 records) =head1 DESCRIPTION Class for DNS Resolver Information(RESINFO) resource records. RESINFO is a clone of the Net::DNS::RR::TXT class. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 txtdata $string = $rr->txtdata; @list = $rr->txtdata; When invoked in scalar context, $rr->txtdata() returns the resolver properties as a single string, with elements separated by a single space. In a list context, $rr->txtdata() returns a list of the text elements. =head1 COPYRIGHT Copyright (c)2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/SPF.pm000044400000004700152345050350006502 0ustar00package Net::DNS::RR::SPF; use strict; use warnings; our $VERSION = (qw$Id: SPF.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::TXT); =head1 NAME Net::DNS::RR::SPF - DNS SPF resource record =cut use integer; sub spfdata { my ( $self, @argument ) = @_; my @spf = shift->char_str_list(@argument); return wantarray ? @spf : join '', @spf; } sub txtdata { return &spfdata; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SPF spfdata ...'); =head1 DESCRIPTION Class for DNS Sender Policy Framework (SPF) resource records. SPF records inherit most of the properties of the Net::DNS::RR::TXT class. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 spfdata =head2 txtdata $string = $rr->spfdata; @list = $rr->spfdata; $rr->spfdata( @list ); When invoked in scalar context, spfdata() returns the policy text as a single string, with text elements concatenated without intervening spaces. In a list context, spfdata() returns a list of the text elements. =head1 COPYRIGHT Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/OPT.pm000044400000042750152345050350006523 0ustar00package Net::DNS::RR::OPT; use strict; use warnings; our $VERSION = (qw$Id: OPT.pm 2005 2025-01-28 13:22:10Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::OPT - DNS OPT resource record =cut use integer; use Carp; use Net::DNS::Parameters qw(:rcode :ednsoption); use constant UTIL => scalar eval { require Scalar::Util; Scalar::Util->can('isdual') }; use constant OPT => Net::DNS::Parameters::typebyname qw(OPT); require Net::DNS::DomainName; require Net::DNS::RR::A; require Net::DNS::RR::AAAA; require Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $class = delete $self->{class}; # OPT redefines CLASS and TTL fields $self->udpsize($class) if defined $class; my $ttl = delete $self->{ttl}; $self->_ttl($ttl) if defined $ttl; my $limit = $offset + $self->{rdlength} - 4; while ( $offset <= $limit ) { my ( $code, $length ) = unpack "\@$offset nn", $$data; my $value = unpack "\@$offset x4 a$length", $$data; my @value = map { ref($_) ? @$_ : defined($_) ? $_ : () } $self->{option}{$code}, $value; $self->{option}{$code} = ( scalar(@value) == 1 ) ? $value : \@value; $offset += $length + 4; } return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $option = $self->{option} || {}; my @option = $self->options; foreach my $item (@option) { my @value = map { ref($_) ? @$_ : $_ } $option->{$item}; $item = join '', map { pack( 'nna*', $item, length($_), $_ ) } @value; } return join '', @option; } sub encode { ## override RR method my $self = shift; my $data = $self->_encode_rdata; return pack 'C n n N na*', 0, OPT, $self->udpsize, $self->_ttl, length($data), $data; } sub string { ## override RR method my @line = split /[\r\n]+/, shift->json; return join '', map {";;$_\n"} @line; } sub class { ## override RR method my ( $self, @value ) = @_; $self->_deprecate(qq[please use "UDPsize()"]); return $self->udpsize(@value); } sub ttl { ## override RR method my ( $self, @value ) = @_; $self->_deprecate(qq[please use "flags()", "rcode()" or "version()"]); return $self->_ttl(@value); } sub _ttl { my ( $self, @value ) = @_; for (@value) { @{$self}{qw(rcode version flags)} = unpack 'C2n', pack( 'N', $_ ); $self->{rcode} = $self->{rcode} << 4; return; } return unpack 'N', pack( 'C2n', $self->rcode >> 4, $self->version, $self->flags ); } sub generic { ## override RR method my $self = shift; local $self->{class} = $self->udpsize; my @xttl = ( $self->rcode >> 4, $self->version, $self->flags ); local $self->{ttl} = unpack 'N', pack( 'C2n', @xttl ); return $self->SUPER::generic; } sub token { ## override RR method return grep { !m/^[()]$/ } split /\s+/, &generic; } sub json { my $self = shift; # uncoverable pod my $version = $self->version; unless ( $version == 0 ) { my $content = unpack 'H*', $self->encode; return <<"QQ"; { "EDNS-VERSION": $version, "BASE16": "$content" } QQ } my $flags = $self->flags; my $rcode = $self->rcode; my $size = $self->udpsize; my @format = map { join( "\n\t\t\t", $self->_format_option($_) ) } $self->options; my @indent = scalar(@format) ? "\n\t\t" : (); my @option = join ",\n\t\t", @format; return <<"QQ"; { "EDNS-VERSION": $version, "FLAGS": $flags, "RCODE": $rcode, "UDPSIZE": $size, "OPTIONS": [@indent@option ] } QQ } sub version { my ( $self, @value ) = @_; for (@value) { $self->{version} = 0 + $_ } return $self->{version} || 0; } sub udpsize { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{udpsize} = ( $_ > 512 ) ? $_ : 0 } return $self->{udpsize} || 0; } sub size { my ( $self, @value ) = @_; # uncoverable pod $self->_deprecate(qq[size() is an alias of "UDPsize()"]); return $self->udpsize(@value); } sub rcode { my ( $self, @value ) = @_; for (@value) { $self->{rcode} = ( $_ < 16 ) ? 0 : $_ } # discard non-EDNS rcodes 1 .. 15 return $self->{rcode} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub options { my $self = shift; my $option = $self->{option} || {}; @{$self->{index}} = sort { $a <=> $b } keys %$option unless defined $self->{index}; return @{$self->{index}}; } sub option { my ( $self, $name, @value ) = @_; my $number = ednsoptionbyname($name); return $self->_get_option($number) unless scalar @value; my $value = $self->_set_option( $number, @value ); return $@ ? croak( ( split /\sat/i, $@ )[0] ) : $value; } ######################################## sub _get_option { my ( $self, $number ) = @_; my $options = $self->{option} || {}; my @payload = map { ref($_) ? @$_ : $_ } $options->{$number}; return shift @payload unless wantarray; my $optname = ednsoptionbyval($number); my $package = join '::', __PACKAGE__, $optname; $package =~ s/-/_/g; my $structured = $package->can('_decompose'); foreach my $value (@payload) { my @value; if ( length $value ) { @value = eval { $package->_decompose($value) } if $structured; @value = {BASE16 => unpack 'H*', $value} unless scalar @value; warn $@ if $@; } else { @value = $structured ? {'OPTION-LENGTH' => 0} : ''; } $value = {$optname => @value}; } return @payload; } sub _set_option { my ( $self, $number, @value ) = @_; my ($arg) = @value; my $options = $self->{option} || {}; delete $options->{$number}; delete $self->{index}; delete $self->{option} unless scalar( keys %$options ); return unless defined $arg; $self->{option} = $options; if ( ref($arg) eq 'HASH' ) { for ( keys %$arg ) { $$arg{uc $_} = $$arg{$_} } # tolerate mixed case my $length = $$arg{'OPTION-LENGTH'}; my $octets = $$arg{'OPTION-DATA'}; $octets = pack 'H*', $$arg{'BASE16'} if defined $$arg{'BASE16'}; $octets = '' if defined($length) && $length == 0; return $options->{$number} = $octets if defined $octets; } my $option = ednsoptionbyval($number); my $package = join '::', __PACKAGE__, $option; $package =~ s/-/_/g; return eval { $options->{$number} = $package->_compose(@value) } if length($arg) && $package->can('_compose'); croak "unable to compose option $number" if ref($arg); return $options->{$number} = $arg; } sub _specified { my $self = shift; return scalar grep { $self->{$_} } qw(udpsize flags rcode option); } sub _format_option { my ( $self, $number ) = @_; my @option = $self->_get_option($number); return map { Net::DNS::RR::_wrap( _JSONify($_) ) } @option; } sub _JSONify { my $value = shift; return 'null' unless defined $value; if ( ref($value) eq 'HASH' ) { my @tags = sort keys %$value; my $tail = pop @tags; for ( $$value{BASE16} ) { $_ = pack( 'U0a*', $_ ) if defined } # mark as UTF-8 my @body = map { my @x = ( qq("$_":), _JSONify( $$value{$_} ) ); $x[-1] .= ','; @x } @tags; push @body, ( qq("$tail":), _JSONify( $$value{$tail} ) ); $body[0] = '{' . $body[0]; $body[-1] .= '}'; return @body; } if ( ref($value) eq 'ARRAY' ) { my @array = @$value; my @tail = map { _JSONify($_) } grep {defined} pop @array; my @body = map { my @x = _JSONify($_); $x[-1] .= ','; @x } @array; return ( '[', @body, @tail, ']' ); } my $string = "$value"; ## stringify, then use isdual() as discriminant return $string if UTIL && Scalar::Util::isdual($value); # native numeric representation for ($string) { unless ( utf8::is_utf8($value) ) { return $_ if /^-?\d+$/; # integer (string representation) return $_ if /^-?\d+\.\d+$/; # non-integer return $_ if /^-?\d+(\.\d+)?e[+-]\d\d?$/i; } s/\\/\\\\/g; # escaped escape s/^"(.*)"$/$1/; # strip enclosing quotes s/"/\\"/g; # escape interior quotes } return qq("$string"); } ## no critic ProhibitMultiplePackages package Net::DNS::RR::OPT::NSID; # RFC5001 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return pack 'H*', pop @argument; } sub _decompose { return pack 'U0a*', unpack 'H*', pop @_ } # mark as UTF-8 package Net::DNS::RR::OPT::DAU; # RFC6975 sub _compose { my ( undef, @argument ) = map { ref($_) ? @$_ : $_ } @_; return pack 'C*', @argument; } sub _decompose { return [unpack 'C*', pop @_] } package Net::DNS::RR::OPT::DHU; # RFC6975 our @ISA = qw(Net::DNS::RR::OPT::DAU); package Net::DNS::RR::OPT::N3U; # RFC6975 our @ISA = qw(Net::DNS::RR::OPT::DAU); package Net::DNS::RR::OPT::CLIENT_SUBNET; # RFC7871 my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); my @field8 = qw(FAMILY SOURCE-PREFIX SCOPE-PREFIX ADDRESS); sub _compose { shift @_; my %argument = ( map( ( $_ => 0 ), @field8 ), map { ref($_) ? %$_ : $_ } @_ ); my $family = $family{$argument{FAMILY}} || die 'unrecognised address family'; my $bitmask = $argument{'SOURCE-PREFIX'}; my $address = bless( {}, $family )->address( $argument{ADDRESS} ); return pack 'a* B*', pack( 'nC2', @argument{@field8} ), unpack "B$bitmask", $address; } sub _decompose { my %object; @object{@field8} = unpack 'nC2a*', pop @_; my $family = $family{$object{FAMILY}} || die 'unrecognised address family'; for ( $object{ADDRESS} ) { $_ = bless( {address => $_}, $family )->address; s/:[:0]+$/::/; } return \%object; } package Net::DNS::RR::OPT::EXPIRE; # RFC7314 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return pack 'N', pop @argument; } sub _decompose { my $argument = pop @_; return {'EXPIRE-TIMER' => unpack 'N', $argument}; } package Net::DNS::RR::OPT::COOKIE; # RFC7873 my @field10 = qw(CLIENT SERVER); sub _compose { my ( undef, @argument ) = @_; for ( ref( $argument[0] ) ) { /HASH/ && ( @argument = @{$argument[0]}{@field10} ); /ARRAY/ && ( @argument = @{$argument[0]} ); } return pack 'a8a*', map { pack 'H*', $_ || '' } @argument; } sub _decompose { my %object; @object{@field10} = map { pack 'U0a*', $_ } unpack 'H16H*', pop @_; # mark as UTF-8 return \%object; } package Net::DNS::RR::OPT::TCP_KEEPALIVE; # RFC7828 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return pack 'n', pop @argument; } sub _decompose { my $argument = pop @_; return {'TIMEOUT' => unpack 'n', $argument}; } package Net::DNS::RR::OPT::PADDING; # RFC7830 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; my $length = pop(@argument) || 0; return pack "x$length"; } sub _decompose { my $argument = pop @_; return {'OPTION-LENGTH' => length $argument} if $argument =~ /^\000*$/; return {'BASE16' => unpack 'H*', $argument}; } package Net::DNS::RR::OPT::CHAIN; # RFC7901 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return Net::DNS::DomainName->new( pop @argument )->encode; } sub _decompose { my $argument = pop @_; return {'CLOSEST-TRUST-POINT' => Net::DNS::DomainName->decode( \$argument )->string}; } package Net::DNS::RR::OPT::KEY_TAG; # RFC8145 sub _compose { my ( undef, @argument ) = map { ref($_) ? @$_ : $_ } @_; return pack 'n*', @argument; } sub _decompose { return [unpack 'n*', pop @_] } package Net::DNS::RR::OPT::EXTENDED_ERROR; # RFC8914 sub _compose { my ( undef, @arg ) = @_; my %arg = ref( $arg[0] ) ? %{$arg[0]} : @arg; my $text = join '', Net::DNS::RR::OPT::_JSONify( $arg{'EXTRA-TEXT'} || '' ); return pack 'na*', $arg{'INFO-CODE'}, Net::DNS::Text->new($text)->raw; } sub _decompose { my ( $code, $text ) = unpack 'na*', pop @_; my $error = $Net::DNS::Parameters::dnserrorbyval{$code}; my @error = defined($error) ? ( 'ERROR' => $error ) : (); my $extra = Net::DNS::Text->decode( \$text, 0, length $text ); for ( $extra->value ) { last unless /^[\[\{]/; s/([\$\@])/\\$1/g; ## Here be dragons! my $REGEX = q/("[^"]*"|[\[\]{}:,]|[-0-9.Ee+]+)|\s+|(.)/; my @split = grep { defined && length } split /$REGEX/o; my $value = eval join( ' ', 'no integer;', map { s/^:$/=>/; $_ } @split ); return {'INFO-CODE' => $code, @error, 'EXTRA-TEXT' => $value} if ref($value); } return {'INFO-CODE' => $code, @error, 'EXTRA-TEXT' => $extra->value}; } package Net::DNS::RR::OPT::REPORT_CHANNEL; # RFC9567 sub _compose { my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_; return Net::DNS::DomainName->new( pop @argument )->encode; } sub _decompose { my $argument = pop @_; return {'AGENT-DOMAIN' => Net::DNS::DomainName->decode( \$argument )->string}; } package Net::DNS::RR::OPT::ZONEVERSION; # RFC9660 my @field19 = qw(LABELCOUNT TYPE VERSION); sub _compose { my ( undef, @argument ) = @_; for ( ref( $argument[0] ) ) { /HASH/ && ( @argument = @{$argument[0]}{@field19} ); /ARRAY/ && ( @argument = @{$argument[0]} ); } return scalar(@argument) ? pack( 'C2H*', @argument ) : ''; } sub _decompose { my %object; my ( $l, $t, $v ) = unpack 'C2H*', pop @_; @object{@field19} = ( $l, $t, pack 'U0a*', $v ); # mark hex data as UTF-8 return \%object; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; my $packet = Net::DNS::Packet->new( ... ); $packet->header->do(1); # extended header flag $packet->edns->UDPsize(1232); # UDP payload size $packet->edns->option( 'NSID' => {'OPTION-DATA' => 'rawbytes'} ); $packet->edns->option( 'DAU' => [8, 10, 13, 14, 15, 16] ); $packet->edns->option( 'TCP-KEEPALIVE' => 200 ); $packet->edns->option( 'EXTENDED-ERROR' => {'INFO-CODE' => 123} ); $packet->edns->option( '65023' => {'BASE16' => '076578616d706c6500'} ); $packet->edns->print; ;; { "EDNS-VERSION": 0, ;; "FLAGS": 32768, ;; "RCODE": 0, ;; "UDPSIZE": 1232, ;; "OPTIONS": [ ;; {"NSID": "7261776279746573"}, ;; {"DAU": [ 8, 10, 13, 14, 15, 16 ]}, ;; {"TCP-KEEPALIVE": {"TIMEOUT": 200}}, ;; {"EXTENDED-ERROR": {"INFO-CODE": 123, "EXTRA-TEXT": ""}}, ;; {"65023": {"BASE16": "076578616d706c6500"}} ] ;; } =head1 DESCRIPTION EDNS OPT pseudo resource record. The OPT record supports EDNS protocol extensions and is not intended to be created, accessed or modified directly by user applications. All EDNS features are performed indirectly by operations on the objects returned by the $packet->header and $packet->edns creator methods. The underlying mechanisms are, or should be, entirely hidden from the user. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 version $version = $packet->edns->version; The version of EDNS supported by this OPT record. =head2 UDPsize $size = $packet->edns->UDPsize; $packet->edns->UDPsize($size); UDPsize() advertises the maximum size (octets) of UDP packet that can be reassembled in the network stack of the originating host. =head2 rcode $extended_rcode = $packet->header->rcode; The 12 bit extended RCODE. The most significant 8 bits are obtained from the OPT record. The least significant 4 bits reside in the packet header. =head2 flags $do = $packet->header->do; $packet->header->do(1); $edns_flags = $packet->edns->flags; 16 bit field containing EDNS extended header flags. =head2 options my @options = $packet->edns->options; When called in a list context, options() returns a list of option codes found in the OPT record. =head2 option my $octets = $packet->edns->option('COOKIE'); my $base16 = unpack 'H*', $octets; When called in a scalar context with a single argument, option() returns the value of the specified option as an uninterpreted octet string. The method returns undef if the option is absent. $packet->edns->option( 'COOKIE' => {'OPTION-DATA' => $octets} ); $packet->edns->option( '10' => {'BASE16' => $base16} ); An option can be added or replaced by providing the (name,value) pair. The option is deleted if the value is undefined. my ($structure) = $packet->edns->option("DAU"); my $array = $$structure{"DAU"}; my @algorithms = @$array; my ($structure) = $packet->edns->option(15); my $table = $$structure{"EXTENDED-ERROR"}; my $info_code = $$table{'INFO-CODE'}; my $extra_text = $$table{'EXTRA-TEXT'}; When called in a list context with a single argument, option() returns a structured representation of the specified option. Similar forms of array or hash syntax may be used to construct the option value: $packet->edns->option( 'DAU' => [8, 10, 13, 14, 15, 16] ); $packet->edns->option( 'EXTENDED-ERROR' => { 'INFO-CODE' => 123, 'EXTRA-TEXT' => "" } ); =head1 COPYRIGHT Copyright (c)2001,2002 RIPE NCC. Author Olaf M. Kolkman. Portions Copyright (c)2012,2017-2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/HIP.pm000044400000012410152345050350006467 0ustar00package Net::DNS::RR::HIP; use strict; use warnings; our $VERSION = (qw$Id: HIP.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::HIP - DNS HIP resource record =cut use integer; use Carp; use Net::DNS::DomainName; use MIME::Base64; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my ( $hitlen, $pklen ) = unpack "\@$offset Cxn", $$data; @{$self}{qw(algorithm hitbin keybin)} = unpack "\@$offset xCxx a$hitlen a$pklen", $$data; my $limit = $offset + $self->{rdlength}; $offset += 4 + $hitlen + $pklen; $self->{servers} = []; while ( $offset < $limit ) { my $item; ( $item, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); push @{$self->{servers}}, $item; } croak('corrupt HIP data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $hit = $self->hitbin; my $key = $self->keybin; my $nos = pack 'C2n a* a*', length($hit), $self->algorithm, length($key), $hit, $key; return join '', $nos, map { $_->encode } @{$self->{servers}}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $base64 = MIME::Base64::encode( $self->{keybin}, '' ); my @server = map { $_->string } @{$self->{servers}}; my @rdata = ( $self->algorithm, $self->hit, $base64, @server ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(algorithm hit key)) { $self->$_( shift @argument ) } $self->servers(@argument); return; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub hit { my ( $self, @value ) = @_; return unpack "H*", $self->hitbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->hitbin( pack "H*", join "", @hex ); } sub hitbin { my ( $self, @value ) = @_; for (@value) { $self->{hitbin} = $_ } return $self->{hitbin} || ""; } sub key { my ( $self, @value ) = @_; return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value; return $self->keybin( MIME::Base64::decode( join "", @value ) ); } sub keybin { my ( $self, @value ) = @_; for (@value) { $self->{keybin} = $_ } return $self->{keybin} || ""; } sub servers { my ( $self, @names ) = @_; my $servers = $self->{servers} ||= []; for (@names) { push @$servers, Net::DNS::DomainName->new($_) } return defined(wantarray) ? map( { $_->name } @$servers ) : (); } sub rendezvousservers { ## historical my @servers = &servers; # uncoverable pod return \@servers; } sub pkalgorithm { ## historical return &algorithm; # uncoverable pod } sub pubkey { ## historical return &key; # uncoverable pod } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN HIP algorithm hit key servers'); =head1 DESCRIPTION Class for DNS Host Identity Protocol (HIP) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The PK algorithm field indicates the public key cryptographic algorithm and the implied public key field format. The values are those defined for the IPSECKEY algorithm type [RFC4025]. =head2 hit $hit = $rr->hit; $rr->hit( $hit ); The hexadecimal representation of the host identity tag. =head2 hitbin $hitbin = $rr->hitbin; $rr->hitbin( $hitbin ); The binary representation of the host identity tag. =head2 key $key = $rr->key; $rr->key( $key ); The MIME Base64 representation of the public key. =head2 keybin $keybin = $rr->keybin; $rr->keybin( $keybin ); The binary representation of the public key. =head2 servers @servers = $rr->servers; Optional list of domain names of rendezvous servers. =head1 COPYRIGHT Copyright (c)2009 Olaf Kolkman, NLnet Labs All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/CDS.pm000044400000004564152345050350006473 0ustar00package Net::DNS::RR::CDS; use strict; use warnings; our $VERSION = (qw$Id: CDS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR::DS); =head1 NAME Net::DNS::RR::CDS - DNS CDS resource record =cut use integer; sub algorithm { my ( $self, $arg ) = @_; return $self->SUPER::algorithm($arg) if $arg; return $self->SUPER::algorithm() unless defined $arg; @{$self}{qw(keytag algorithm digtype digestbin)} = ( 0, 0, 0, chr(0) ); return; } sub digtype { my ( $self, $arg ) = @_; return $self->SUPER::digtype($arg) if $arg; return $self->SUPER::digtype(); } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CDS keytag algorithm digtype digest'); =head1 DESCRIPTION DNS Child DS resource record This is a clone of the DS record and inherits all properties of the Net::DNS::RR::DS class. Please see the L perl documentation for details. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head1 COPYRIGHT Copyright (c)2014,2017 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/GPOS.pm000044400000007612152345050350006627 0ustar00package Net::DNS::RR::GPOS; use strict; use warnings; our $VERSION = (qw$Id: GPOS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::GPOS - DNS GPOS resource record =cut use integer; use Carp; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; for (qw(latitude longitude altitude)) { my $text; ( $text, $offset ) = Net::DNS::Text->decode( $data, $offset ); $self->$_( $text->value ); } croak('corrupt GPOS data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return join '', map { Net::DNS::Text->new($_)->encode } @{$self}{qw(latitude longitude altitude)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return map { Net::DNS::Text->new($_)->string } @{$self}{qw(latitude longitude altitude)}; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->latitude( shift @argument ); $self->longitude( shift @argument ); $self->altitude(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata(qw(0.0 0.0 0.0)); return; } sub latitude { my ( $self, @value ) = @_; for (@value) { return $self->{latitude} = _fp($_) } return $self->{latitude}; } sub longitude { my ( $self, @value ) = @_; for (@value) { return $self->{longitude} = _fp($_) } return $self->{longitude}; } sub altitude { my ( $self, @value ) = @_; for (@value) { return $self->{altitude} = _fp($_) } return $self->{altitude}; } ######################################## sub _fp { no integer; return sprintf( '%1.10g', 0.0 + shift ); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name GPOS latitude longitude altitude'); =head1 DESCRIPTION Class for DNS Geographical Position (GPOS) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 latitude $latitude = $rr->latitude; $rr->latitude( $latitude ); Floating-point representation of latitude, in degrees. =head2 longitude $longitude = $rr->longitude; $rr->longitude( $longitude ); Floating-point representation of longitude, in degrees. =head2 altitude $altitude = $rr->altitude; $rr->altitude( $altitude ); Floating-point representation of altitude, in metres. =head1 COPYRIGHT Copyright (c)1997,1998 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/MR.pm000044400000005423152345050350006373 0ustar00package Net::DNS::RR::MR; use strict; use warnings; our $VERSION = (qw$Id: MR.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::MR - DNS MR resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{newname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; return $self->{newname}->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{newname}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->newname(@argument); return; } sub newname { my ( $self, @value ) = @_; for (@value) { $self->{newname} = Net::DNS::DomainName1035->new($_) } return $self->{newname} ? $self->{newname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR('name MR newname'); =head1 DESCRIPTION Class for DNS Mail Rename (MR) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 newname $newname = $rr->newname; $rr->newname( $newname ); A domain name which specifies a mailbox which is the proper rename of the specified mailbox. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/CNAME.pm000044400000005752152345050350006705 0ustar00package Net::DNS::RR::CNAME; use strict; use warnings; our $VERSION = (qw$Id: CNAME.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CNAME - DNS CNAME resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{cname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $cname = $self->{cname}; return $cname->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $cname = $self->{cname}; return $cname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->cname(@argument); return; } sub cname { my ( $self, @value ) = @_; for (@value) { $self->{cname} = Net::DNS::DomainName1035->new($_) } return $self->{cname} ? $self->{cname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name CNAME cname'); $rr = Net::DNS::RR->new( name => 'alias.example.com', type => 'CNAME', cname => 'example.com', ); =head1 DESCRIPTION Class for DNS Canonical Name (CNAME) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 cname $cname = $rr->cname; $rr->cname( $cname ); A domain name which specifies the canonical or primary name for the owner. The owner name is an alias. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2002-2003 Chris Reinhardt. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/RP.pm000044400000007613152345050350006401 0ustar00package Net::DNS::RR::RP; use strict; use warnings; our $VERSION = (qw$Id: RP.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::RP - DNS RP resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Mailbox; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; ( $self->{mbox}, $offset ) = Net::DNS::Mailbox2535->decode( $data, $offset, @opaque ); $self->{txtdname} = Net::DNS::DomainName2535->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $txtdname = $self->{txtdname}; my $rdata = $self->{mbox}->encode( $offset, @opaque ); $rdata .= $txtdname->encode( $offset + length($rdata), @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->{mbox}->string, $self->{txtdname}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(mbox txtdname)) { $self->$_( shift @argument ) } return; } sub mbox { my ( $self, @value ) = @_; for (@value) { $self->{mbox} = Net::DNS::Mailbox2535->new($_) } return $self->{mbox} ? $self->{mbox}->address : undef; } sub txtdname { my ( $self, @value ) = @_; for (@value) { $self->{txtdname} = Net::DNS::DomainName2535->new($_) } return $self->{txtdname} ? $self->{txtdname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name RP mbox txtdname'); =head1 DESCRIPTION Class for DNS Responsible Person (RP) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 mbox $mbox = $rr->mbox; $rr->mbox( $mbox ); A domain name which specifies the mailbox for the person responsible for this domain. The format in master files uses the DNS encoding convention for mailboxes, identical to that used for the RNAME mailbox field in the SOA RR. The root domain name (just ".") may be specified to indicate that no mailbox is available. =head2 txtdname $txtdname = $rr->txtdname; $rr->txtdname( $txtdname ); A domain name identifying TXT RRs. A subsequent query can be performed to retrieve the associated TXT records. This provides a level of indirection so that the entity can be referred to from multiple places in the DNS. The root domain name (just ".") may be specified to indicate that there is no associated TXT RR. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/NS.pm000044400000005702152345050350006375 0ustar00package Net::DNS::RR::NS; use strict; use warnings; our $VERSION = (qw$Id: NS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NS - DNS NS resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{nsdname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $nsdname = $self->{nsdname}; return $nsdname->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $nsdname = $self->{nsdname}; return $nsdname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->nsdname(@argument); return; } sub nsdname { my ( $self, @value ) = @_; for (@value) { $self->{nsdname} = Net::DNS::DomainName1035->new($_) } return $self->{nsdname} ? $self->{nsdname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NS nsdname'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'NS', nsdname => 'ns.example.com', ); =head1 DESCRIPTION Class for DNS Name Server (NS) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 nsdname $nsdname = $rr->nsdname; $rr->nsdname( $nsdname ); A domain name which specifies a host which should be authoritative for the specified class and domain. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/TXT.pm000044400000007372152345050350006541 0ustar00package Net::DNS::RR::TXT; use strict; use warnings; our $VERSION = (qw$Id: TXT.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =encoding utf8 =head1 NAME Net::DNS::RR::TXT - DNS TXT resource record =cut use integer; use Carp; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $self->{rdlength}; my $rdata = substr $$data, $offset, $limit; my $array = $self->{txtdata} = []; my $index = 0; while ( $index < $limit ) { ( my $text, $index ) = Net::DNS::Text->decode( \$rdata, $index ); push @$array, $text; } return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $txtdata = $self->{txtdata}; return join '', map { $_->encode } @$txtdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $txtdata = $self->{txtdata}; return ( map { $_->unicode } @$txtdata ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->{txtdata} = [map { Net::DNS::Text->new($_) } @argument]; return; } sub txtdata { my ( $self, @value ) = @_; $self->{txtdata} = [map { Net::DNS::Text->new($_) } @value] if scalar @value; my $txtdata = $self->{txtdata} || []; return ( map { $_->value } @$txtdata ) if wantarray; return defined(wantarray) ? join( ' ', map { $_->value } @$txtdata ) : ''; } sub char_str_list { return my @txt = &txtdata } # uncoverable pod 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new( 'name TXT txtdata ...' ); $rr = Net::DNS::RR->new( name => 'name', type => 'TXT', txtdata => 'single text string' ); $rr = Net::DNS::RR->new( name => 'name', type => 'TXT', txtdata => [ 'multiple', 'strings', ... ] ); use utf8; $rr = Net::DNS::RR->new( 'jp TXT 古池や　蛙飛込む　水の音' ); =head1 DESCRIPTION Class for DNS Text (TXT) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 txtdata $string = $rr->txtdata; @list = $rr->txtdata; $rr->txtdata( @list ); When invoked in scalar context, txtdata() returns a concatenation of the descriptive text elements each separated by a single space character. In a list context, txtdata() returns a list of the text elements. =head1 COPYRIGHT Copyright (c)2011 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/SOA.pm000044400000020023152345050350006470 0ustar00package Net::DNS::RR::SOA; use strict; use warnings; our $VERSION = (qw$Id: SOA.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SOA - DNS SOA resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Mailbox; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; ( $self->{mname}, $offset ) = Net::DNS::DomainName1035->decode( $data, $offset, @opaque ); ( $self->{rname}, $offset ) = Net::DNS::Mailbox1035->decode( $data, $offset, @opaque ); @{$self}{qw(serial refresh retry expire minimum)} = unpack "\@$offset N5", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my ( $offset, @opaque ) = @argument; my $rname = $self->{rname}; my $rdata = $self->{mname}->encode(@argument); $rdata .= $rname->encode( $offset + length($rdata), @opaque ); $rdata .= pack 'N5', $self->serial, @{$self}{qw(refresh retry expire minimum)}; return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $mname = $self->{mname}->string; my $rname = $self->{rname}->string; my $serial = $self->serial; my $spacer = length "$serial" > 7 ? "" : "\t"; return ($mname, $rname, join( "\n\t\t\t\t", "\t\t\t$serial$spacer\t;serial", "$self->{refresh}\t\t;refresh", "$self->{retry}\t\t;retry", "$self->{expire}\t\t;expire", "$self->{minimum}\t\t;minimum\n" ) ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(mname rname)) { $self->$_( shift @argument ) } $self->serial( shift @argument ) if scalar @argument; # possibly undefined for (qw(refresh retry expire minimum)) { last unless scalar @argument; $self->$_( Net::DNS::RR::ttl( {}, shift @argument ) ); } return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata(qw(. . 0 4h 1h 3w 1h)); delete $self->{serial}; return; } sub mname { my ( $self, @value ) = @_; for (@value) { $self->{mname} = Net::DNS::DomainName1035->new($_) } return $self->{mname} ? $self->{mname}->name : undef; } sub rname { my ( $self, @value ) = @_; for (@value) { $self->{rname} = Net::DNS::Mailbox1035->new($_) } return $self->{rname} ? $self->{rname}->address : undef; } sub serial { my ( $self, @value ) = @_; return $self->{serial} || 0 unless scalar @value; # current/default value my $value = shift @value; # replace if in sequence return $self->{serial} = ( $value & 0xFFFFFFFF ) if _ordered( $self->{serial}, $value ); # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished my $serial = 0xFFFFFFFF & ( $self->{serial} || 0 ); return $self->{serial} = 0x80000000 if $serial == 0x7FFFFFFF; # wrap return $self->{serial} = 0x00000000 if $serial == 0xFFFFFFFF; # wrap return $self->{serial} = $serial + 1; # increment } sub refresh { my ( $self, @value ) = @_; for (@value) { $self->{refresh} = 0 + $_ } return $self->{refresh} || 0; } sub retry { my ( $self, @value ) = @_; for (@value) { $self->{retry} = 0 + $_ } return $self->{retry} || 0; } sub expire { my ( $self, @value ) = @_; for (@value) { $self->{expire} = 0 + $_ } return $self->{expire} || 0; } sub minimum { my ( $self, @value ) = @_; for (@value) { $self->{minimum} = 0 + $_ } return $self->{minimum} || 0; } ######################################## sub _ordered() { ## irreflexive 32-bit partial ordering my ( $n1, $n2 ) = @_; return 0 unless defined $n2; # ( any, undef ) return 1 unless defined $n1; # ( undef, any ) # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished use integer; # fold, leaving $n2 non-negative $n1 = ( $n1 & 0xFFFFFFFF ) ^ ( $n2 & 0x80000000 ); # -2**31 <= $n1 < 2**32 $n2 = ( $n2 & 0x7FFFFFFF ); # 0 <= $n2 < 2**31 return $n1 < $n2 ? ( $n1 > ( $n2 - 0x80000000 ) ) : ( $n2 < ( $n1 - 0x80000000 ) ); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SOA mname rname 0 14400 3600 1814400 3600'); =head1 DESCRIPTION Class for DNS Start of Authority (SOA) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 mname $mname = $rr->mname; $rr->mname( $mname ); The domain name of the name server that was the original or primary source of data for this zone. =head2 rname $rname = $rr->rname; $rr->rname( $rname ); The mailbox which identifies the person responsible for maintaining this zone. =head2 serial $serial = $rr->serial; $serial = $rr->serial(value); Unsigned 32 bit version number of the original copy of the zone. Zone transfers preserve this value. RFC1982 defines a strict (irreflexive) partial ordering for zone serial numbers. The serial number will be incremented unless the replacement value argument satisfies the ordering constraint. =head2 refresh $refresh = $rr->refresh; $rr->refresh( $refresh ); A 32 bit time interval before the zone should be refreshed. =head2 retry $retry = $rr->retry; $rr->retry( $retry ); A 32 bit time interval that should elapse before a failed refresh should be retried. =head2 expire $expire = $rr->expire; $rr->expire( $expire ); A 32 bit time value that specifies the upper limit on the time interval that can elapse before the zone is no longer authoritative. =head2 minimum $minimum = $rr->minimum; $rr->minimum( $minimum ); The unsigned 32 bit minimum TTL field that should be exported with any RR from this zone. =head1 Zone Serial Number Management The internal logic of the serial() method offers support for several widely used zone serial numbering policies. =head2 Strictly Sequential $successor = $soa->serial( SEQUENTIAL ); The existing serial number is incremented modulo 2**32 because the value returned by the auxiliary SEQUENTIAL() function can never satisfy the serial number ordering constraint. =head2 Date Encoded $successor = $soa->serial( YYYYMMDDxx ); The 32 bit value returned by the auxiliary YYYYMMDDxx() function will be used if it satisfies the ordering constraint, otherwise the serial number will be incremented as above. Serial number increments must be limited to 100 per day for the date information to remain useful. =head2 Time Encoded $successor = $soa->serial( UNIXTIME ); The 32 bit value returned by the auxiliary UNIXTIME() function will used if it satisfies the ordering constraint, otherwise the existing serial number will be incremented as above. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2003 Chris Reinhardt. Portions Copyright (c)2010,2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/L32.pm000044400000007435152345050350006422 0ustar00package Net::DNS::RR::L32; use strict; use warnings; our $VERSION = (qw$Id: L32.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::L32 - DNS L32 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; @{$self}{qw(preference locator32)} = unpack "\@$offset n a4", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n a4', $self->{preference}, $self->{locator32}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->preference, $self->locator32; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference locator32)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub locator32 { my $self = shift; my $prfx = shift; $self->{locator32} = pack 'C* @4', split /\./, $prfx if defined $prfx; return $self->{locator32} ? join( '.', unpack 'C4', $self->{locator32} ) : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN L32 preference locator32'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'L32', preference => 10, locator32 => '10.1.02.0' ); =head1 DESCRIPTION Class for DNS 32-bit Locator (L32) resource records. The L32 resource record is used to hold 32-bit Locator values for ILNPv4-capable nodes. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this L32 record among other L32 records associated with this owner name. Lower values are preferred over higher values. =head2 locator32 $locator32 = $rr->locator32; The Locator32 field is an unsigned 32-bit integer in network byte order that has the same syntax and semantics as a 32-bit IPv4 routing prefix. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/TKEY.pm000044400000013105152345050350006625 0ustar00package Net::DNS::RR::TKEY; use strict; use warnings; our $VERSION = (qw$Id: TKEY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::TKEY - DNS TKEY resource record =cut use integer; use Carp; use Net::DNS::Parameters qw(:class :type); use Net::DNS::DomainName; use constant ANY => classbyname qw(ANY); use constant TKEY => typebyname qw(TKEY); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{algorithm}, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); @{$self}{qw(inception expiration mode error)} = unpack "\@$offset N2n2", $$data; $offset += 12; my $key_size = unpack "\@$offset n", $$data; $self->{key} = substr $$data, $offset + 2, $key_size; $offset += $key_size + 2; my $other_size = unpack "\@$offset n", $$data; $self->{other} = substr $$data, $offset + 2, $other_size; $offset += $other_size + 2; croak('corrupt TKEY data') unless $offset == $limit; # more or less FUBAR return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return '' unless defined $self->{algorithm}; my $rdata = $self->{algorithm}->encode; $rdata .= pack 'N2n2', $self->inception, $self->expiration, $self->mode, $self->error; my $key = $self->key; # RFC2930(2.7) $rdata .= pack 'na*', length $key, $key; my $other = $self->other; # RFC2930(2.8) $rdata .= pack 'na*', length $other, $other; return $rdata; } sub class { ## override RR method return 'ANY'; } sub encode { ## override RR method my $self = shift; my $owner = $self->{owner}->encode(); my $rdata = eval { $self->_encode_rdata() } || ''; return pack 'a* n2 N n a*', $owner, TKEY, ANY, 0, length $rdata, $rdata; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = Net::DNS::DomainName->new($_) } return $self->{algorithm} ? $self->{algorithm}->name : undef; } sub inception { my ( $self, @value ) = @_; for (@value) { $self->{inception} = 0 + $_ } return $self->{inception} || 0; } sub expiration { my ( $self, @value ) = @_; for (@value) { $self->{expiration} = 0 + $_ } return $self->{expiration} || 0; } sub mode { my ( $self, @value ) = @_; for (@value) { $self->{mode} = 0 + $_ } return $self->{mode} || 0; } sub error { my ( $self, @value ) = @_; for (@value) { $self->{error} = 0 + $_ } return $self->{error} || 0; } sub key { my ( $self, @value ) = @_; for (@value) { $self->{key} = $_ } return $self->{key} || ""; } sub other { my ( $self, @value ) = @_; for (@value) { $self->{other} = $_ } return $self->{other} || ""; } sub other_data { return &other; } # uncoverable pod 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = new Net::DNS::RR('example.com IN TKEY ... '); =head1 DESCRIPTION Class for DNS TSIG Key (TKEY) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The algorithm name is in the form of a domain name with the same meaning as in [RFC 2845]. The algorithm determines how the secret keying material agreed to using the TKEY RR is actually used to derive the algorithm specific key. =head2 inception $inception = $rr->inception; $rr->inception( $inception ); Time expressed as the number of non-leap seconds modulo 2**32 since the beginning of January 1970 GMT. =head2 expiration $expiration = $rr->expiration; $rr->expiration( $expiration ); Time expressed as the number of non-leap seconds modulo 2**32 since the beginning of January 1970 GMT. =head2 mode $mode = $rr->mode; $rr->mode( $mode ); The mode field specifies the general scheme for key agreement or the purpose of the TKEY DNS message, as defined in [RFC2930(2.5)]. =head2 error $error = $rr->error; $rr->error( $error ); The error code field is an extended RCODE. =head2 key $key = $rr->key; $rr->key( $key ); Sequence of octets representing the key exchange data. The meaning of this data depends on the mode. =head2 other $other = $rr->other; $rr->other( $other ); Content not defined in the [RFC2930] specification but may be used in future extensions. =head1 COPYRIGHT Copyright (c)2000 Andrew Tridgell. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/NSEC3PARAM.pm000044400000011546152345050350007454 0ustar00package Net::DNS::RR::NSEC3PARAM; use strict; use warnings; our $VERSION = (qw$Id: NSEC3PARAM.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NSEC3PARAM - DNS NSEC3PARAM resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $size = unpack "\@$offset x4 C", $$data; @{$self}{qw(algorithm flags iterations saltbin)} = unpack "\@$offset CCnx a$size", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $salt = $self->saltbin; return pack 'CCnCa*', @{$self}{qw(algorithm flags iterations)}, length($salt), $salt; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->algorithm, $self->flags, $self->iterations, $self->salt || '-'; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(algorithm flags iterations)) { $self->$_( shift @argument ) } my $salt = shift @argument; $self->salt($salt) unless $salt eq '-'; return; } sub algorithm { my ( $self, @value ) = @_; for (@value) { $self->{algorithm} = 0 + $_ } return $self->{algorithm} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub iterations { my ( $self, @value ) = @_; for (@value) { $self->{iterations} = 0 + $_ } return $self->{iterations} || 0; } sub salt { my ( $self, @value ) = @_; return unpack "H*", $self->saltbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->saltbin( pack "H*", join "", @hex ); } sub saltbin { my ( $self, @value ) = @_; for (@value) { $self->{saltbin} = $_ } return $self->{saltbin} || ""; } ######################################## sub hashalgo { return &algorithm; } # uncoverable pod ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NSEC3PARAM algorithm flags iterations salt'); =head1 DESCRIPTION Class for DNSSEC NSEC3PARAM resource records. The NSEC3PARAM RR contains the NSEC3 parameters (hash algorithm, flags, iterations and salt) needed to calculate hashed ownernames. The presence of an NSEC3PARAM RR at a zone apex indicates that the specified parameters may be used by authoritative servers to choose an appropriate set of NSEC3 records for negative responses. The NSEC3PARAM RR is not used by validators or resolvers. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); The 8-bit algorithm field is represented as an unsigned decimal integer. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); The Flags field is an unsigned decimal integer interpreted as eight concatenated Boolean values. =head2 iterations $iterations = $rr->iterations; $rr->iterations( $iterations ); The Iterations field is represented as an unsigned decimal integer. The value is between 0 and 65535, inclusive. =head2 salt $salt = $rr->salt; $rr->salt( $salt ); The Salt field is represented as a contiguous sequence of hexadecimal digits. A "-" (unquoted) is used in string format to indicate that the salt field is absent. =head2 saltbin $saltbin = $rr->saltbin; $rr->saltbin( $saltbin ); The Salt field as a sequence of octets. =head1 COPYRIGHT Copyright (c)2007,2008 NLnet Labs. Author Olaf M. Kolkman All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/PTR.pm000044400000005511152345050350006520 0ustar00package Net::DNS::RR::PTR; use strict; use warnings; our $VERSION = (qw$Id: PTR.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::PTR - DNS PTR resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, @argument ) = @_; $self->{ptrdname} = Net::DNS::DomainName1035->decode(@argument); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, @argument ) = @_; my $ptrdname = $self->{ptrdname}; return $ptrdname->encode(@argument); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $ptrdname = $self->{ptrdname}; return $ptrdname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->ptrdname(@argument); return; } sub ptrdname { my ( $self, @value ) = @_; for (@value) { $self->{ptrdname} = Net::DNS::DomainName1035->new($_) } return $self->{ptrdname} ? $self->{ptrdname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name PTR ptrdname'); =head1 DESCRIPTION Class for DNS Pointer (PTR) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 ptrdname $ptrdname = $rr->ptrdname; $rr->ptrdname( $ptrdname ); A domain name which points to some location in the domain name space. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/A.pm000044400000005675152345050350006246 0ustar00package Net::DNS::RR::A; use strict; use warnings; our $VERSION = (qw$Id: A.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::A - DNS A resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a4", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a4', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } my $pad = pack 'x4'; sub address { my ( $self, $addr ) = @_; return join '.', unpack 'C4', $self->{address} . $pad unless defined $addr; # Note: pack masks overlarge values, mostly without warning my @part = split /\./, $addr; my $last = pop(@part); return $self->{address} = pack 'C4', @part, (0) x ( 3 - @part ), $last; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN A address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'A', address => '192.0.2.1' ); =head1 DESCRIPTION Class for DNS Address (A) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address $IPv4_address = $rr->address; $rr->address( $IPv4_address ); Version 4 IP address represented using dotted-quad notation. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/AMTRELAY.pm000044400000014561152345050350007276 0ustar00package Net::DNS::RR::AMTRELAY; use strict; use warnings; our $VERSION = (qw$Id: AMTRELAY.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::AMTRELAY - DNS AMTRELAY resource record =cut use integer; use Carp; use Net::DNS::DomainName; use Net::DNS::RR::A; use Net::DNS::RR::AAAA; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $size = $self->{rdlength} - 2; @{$self}{qw(precedence relaytype relay)} = unpack "\@$offset C2 a$size", $$data; for ( $self->relaytype ) { /^3$/ && return $self->{relay} = Net::DNS::DomainName->decode( $data, $offset + 2 ); /^2$/ && return $self->{relay} = pack( 'a16', $self->{relay} ); /^1$/ && return $self->{relay} = pack( 'a4', $self->{relay} ); } $self->{relay} = ''; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; for ( $self->relaytype ) { /^3$/ && return pack( 'C2 a*', @{$self}{qw(precedence relaytype)}, $self->{relay}->encode ); /^2$/ && return pack( 'C2 a16', @{$self}{qw(precedence relaytype relay)} ); /^1$/ && return pack( 'C2 a4', @{$self}{qw(precedence relaytype relay)} ); } return pack( 'C2', @{$self}{qw(precedence relaytype)} ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = map { $self->$_ } qw(precedence dbit relaytype relay); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(precedence dbit relaytype relay)) { $self->$_( shift @argument ); } return; } sub _defaults { ## specify RR attribute default values my $self = shift; @{$self}{qw(precedence relaytype relay)} = ( 0, 0, '' ); return; } sub precedence { my ( $self, @value ) = @_; for (@value) { $self->{precedence} = 0 + $_ } return $self->{precedence} || 0; } sub dbit { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{relaytype} = $self->relaytype | ( $_ ? 0x80 : 0 ) } return ( $self->{relaytype} || 0 ) >> 7; } sub d { return &dbit } # uncoverable pod sub relaytype { my ( $self, @value ) = @_; for (@value) { $self->{relaytype} = $self->dbit ? ( 0x80 | $_ ) : $_ } return 0x7f & ( $self->{relaytype} || 0 ); } sub relay { my ( $self, @value ) = @_; for (@value) { /^\.*$/ && do { $self->relaytype(0); $self->{relay} = ''; # no relay last; }; /:.*:/ && do { $self->relaytype(2); $self->{relay} = Net::DNS::RR::AAAA::address( {}, $_ ); last; }; /\.\d+$/ && do { $self->relaytype(1); $self->{relay} = Net::DNS::RR::A::address( {}, $_ ); last; }; /\..+/ && do { $self->relaytype(3); $self->{relay} = Net::DNS::DomainName->new($_); last; }; croak 'unrecognised relay type'; } if ( defined wantarray ) { for ( $self->relaytype ) { /^1$/ && return Net::DNS::RR::A::address( {address => $self->{relay}} ); /^2$/ && return Net::DNS::RR::AAAA::address( {address => $self->{relay}} ); /^3$/ && return wantarray ? $self->{relay}->string : $self->{relay}->name; } } return wantarray ? '.' : undef; } my $function = sub { ## sort RRs in numerically ascending order. $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('owner AMTRELAY precedence Dbit relaytype relay'); =head1 DESCRIPTION AMTRELAY resource record designed to permit DNS Reverse IP AMT Discovery (DRIAD), a mechanism for AMT gateways to discover AMT relays that are capable of forwarding multicast traffic from a known source IP address. AMT (Automatic Multicast Tunneling) is defined in RFC7450 and provides a method to transport multicast traffic over a unicast tunnel in order to traverse network segments that are not multicast capable. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 precedence $precedence = $rr->precedence; $rr->precedence( $precedence ); 8-bit integer which indicates relative precedence within the RRset. Relays listed in AMTRELAY records with lower precedence are to be attempted first. =head2 Dbit, Discovery Optional $Dbit = $rr->Dbit; $rr->Dbit(1); Boolean field which indicates that the gateway MAY send an AMT Request message directly to the discovered relay address without first sending an AMT Discovery message. =head2 relaytype $relaytype = $rr->relaytype; The relaytype type field indicates the format of the information that is stored in the relay field. The following values are defined: =over 4 0: The relay field is empty (0 bytes). 1: The relay field contains a 4-octet IPv4 address. 2: The relay field contains a 16-octet IPv6 address. 3: The relay field contains a wire-encoded domain name. =back =head2 relay $relay = $rr->relay; $rr->relay( $relay ); The relay field is the address or domain name of the AMT relay. It is formatted according to the relaytype field. =head1 COPYRIGHT Copyright (c)2020 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/ISDN.pm000044400000006657152345050350006624 0ustar00package Net::DNS::RR::ISDN; use strict; use warnings; our $VERSION = (qw$Id: ISDN.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::ISDN - DNS ISDN resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; ( $self->{address}, $offset ) = Net::DNS::Text->decode( $data, $offset ); ( $self->{sa}, $offset ) = Net::DNS::Text->decode( $data, $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $address = $self->{address}; return join '', $address->encode, $self->{sa}->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $address = $self->{address}; return join ' ', $address->string, $self->{sa}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address( shift @argument ); $self->sa(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->sa(''); return; } sub address { my ( $self, @value ) = @_; for (@value) { $self->{address} = Net::DNS::Text->new($_) } return $self->{address} ? $self->{address}->value : undef; } sub sa { my ( $self, @value ) = @_; for (@value) { $self->{sa} = Net::DNS::Text->new($_) } return $self->{sa} ? $self->{sa}->value : undef; } sub ISDNaddress { return &address; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name ISDN ISDNaddress sa'); =head1 DESCRIPTION Class for DNS ISDN resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 ISDNaddress =head2 address $address = $rr->address; $rr->address( $address ); The ISDN-address is a string of characters, normally decimal digits, beginning with the E.163 country code and ending with the DDI if any. =head2 sa $sa = $rr->sa; $rr->sa( $sa ); The optional subaddress (SA) is a string of hexadecimal digits. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/DS.pm000044400000024545152345050350006371 0ustar00package Net::DNS::RR::DS; use strict; use warnings; our $VERSION = (qw$Id: DS.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DS - DNS DS resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; eval { require Digest::SHA }; ## optional for simple Net::DNS RR my %digest = ( '1' => ['Digest::SHA', 1], '2' => ['Digest::SHA', 256], '4' => ['Digest::SHA', 384], '6' => ['Net::DNS::SEC::Digest::SM3'], ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $rdata = substr $$data, $offset, $self->{rdlength}; @{$self}{qw(keytag algorithm digtype digestbin)} = unpack 'n C2 a*', $rdata; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'n C2 a*', @{$self}{qw(keytag algorithm digtype digestbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = @{$self}{qw(keytag algorithm digtype)}; if ( my $digest = $self->digest ) { $self->_annotation( $self->babble ) if BABBLE; push @rdata, split /(\S{64})/, $digest; } else { push @rdata, '""'; } return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->keytag( shift @argument ); my $algorithm = shift @argument; $self->digtype( shift @argument ); $self->digest(@argument); $self->algorithm($algorithm); return; } sub keytag { my ( $self, @value ) = @_; for (@value) { $self->{keytag} = 0 + $_ } return $self->{keytag} || 0; } sub algorithm { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn); } return $self->{algorithm} unless defined $arg; return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; return $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0) } sub digtype { my ( $self, $arg ) = @_; unless ( ref($self) ) { ## class method or simple function my $argn = pop; return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn); } return $self->{digtype} unless defined $arg; return _digestbyval( $self->{digtype} ) if uc($arg) eq 'MNEMONIC'; return $self->{digtype} = _digestbyname($arg) || die _digestbyname('') # disallow digtype(0) } sub digest { my ( $self, @value ) = @_; return unpack "H*", $self->digestbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->digestbin( pack "H*", join "", @hex ); } sub digestbin { my ( $self, @value ) = @_; for (@value) { $self->{digestbin} = $_ } return $self->{digestbin} || ""; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->digestbin ) : ''; } sub create { my ( $class, $keyrr, %args ) = @_; my ($type) = reverse split '::', $class; croak "Unable to create $type record for invalid key" unless $keyrr->protocol == 3; croak "Unable to create $type record for revoked key" if $keyrr->revoke; croak "Unable to create $type record for non-zone key" unless $keyrr->zone; my $self = Net::DNS::RR->new( owner => $keyrr->owner, # per definition, same as keyrr type => $type, class => $keyrr->class, ttl => $keyrr->{ttl}, digtype => 1, # SHA1 by default %args, algorithm => $keyrr->algorithm, keytag => $keyrr->keytag ); my $spec = $digest{$self->digtype}; my $hash = eval { my ( $object, @param ) = @$spec; $object->new(@param); }; croak join ' ', 'digtype', $self->digtype('MNEMONIC'), 'not supported' unless $hash; $hash->add( $keyrr->{owner}->canonical ); $hash->add( $keyrr->_encode_rdata ); $self->digestbin( $hash->digest ); return $self; } sub verify { my ( $self, $key ) = @_; my $verify = Net::DNS::RR::DS->create( $key, ( digtype => $self->digtype ) ); return $verify->digestbin eq $self->digestbin; } ######################################## { my @digestbyname = ( 'SHA-1' => 1, # [RFC3658] 'SHA-256' => 2, # [RFC4509] 'GOST-R-34.11-94' => 3, # [RFC5933] 'SHA-384' => 4, # [RFC6605] 'GOST-R-34.11-2012' => 5, # [RFC-makarenko-gost2012-dnssec-05] 'SM3' => 6, # [RFC-cuiling-dnsop-sm2-alg-15] ); my @digestalias = ( 'SHA' => 1 ); my %digestbyval = reverse @digestbyname; foreach (@digestbyname) { s/[\W_]//g; } # strip non-alphanumerics my @digestrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @digestbyname; my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl sub _digestbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $digestbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _digestbyval { my $value = shift; return $digestbyval{$value} || return $value; } } { my @algbyname = ( 'DELETE' => 0, # [RFC4034][RFC4398][RFC8078] 'RSAMD5' => 1, # [RFC3110][RFC4034] 'DH' => 2, # [RFC2539] 'DSA' => 3, # [RFC3755][RFC2536] ## Reserved => 4, # [RFC6725] 'RSASHA1' => 5, # [RFC3110][RFC4034] 'DSA-NSEC3-SHA1' => 6, # [RFC5155] 'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155] 'RSASHA256' => 8, # [RFC5702] ## Reserved => 9, # [RFC6725] 'RSASHA512' => 10, # [RFC5702] ## Reserved => 11, # [RFC6725] 'ECC-GOST' => 12, # [RFC5933] 'ECDSAP256SHA256' => 13, # [RFC6605] 'ECDSAP384SHA384' => 14, # [RFC6605] 'ED25519' => 15, # [RFC8080] 'ED448' => 16, # [RFC8080] 'SM2SM3' => 17, # [RFC-cuiling-dnsop-sm2-alg-15] 'ECC-GOST12' => 23, # [RFC-makarenko-gost2012-dnssec-05] 'INDIRECT' => 252, # [RFC4034] 'PRIVATEDNS' => 253, # [RFC4034] 'PRIVATEOID' => 254, # [RFC4034] ## Reserved => 255, # [RFC4034] ); my %algbyval = reverse @algbyname; foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname; my %algbyname = @algrehash; # work around broken cperl sub _algbyname { my $arg = shift; my $key = uc $arg; # synthetic key $key =~ s/[\W_]//g; # strip non-alphanumerics my $val = $algbyname{$key}; return $val if defined $val; return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg]; } sub _algbyval { my $value = shift; return $algbyval{$value} || return $value; } } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DS keytag algorithm digtype digest'); use Net::DNS::SEC; $ds = Net::DNS::RR::DS->create( $dnskeyrr, digtype => 'SHA256', ttl => 3600 ); =head1 DESCRIPTION Class for DNS Delegation Signer (DS) resource record. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 keytag $keytag = $rr->keytag; $rr->keytag( $keytag ); The 16-bit numerical key tag of the key. (RFC2535 4.1.6) =head2 algorithm $algorithm = $rr->algorithm; $rr->algorithm( $algorithm ); Decimal representation of the 8-bit algorithm field. algorithm() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 digtype $digtype = $rr->digtype; $rr->digtype( $digtype ); Decimal representation of the 8-bit digest type field. digtype() may also be invoked as a class method or simple function to perform mnemonic and numeric code translation. =head2 digest $digest = $rr->digest; $rr->digest( $digest ); Hexadecimal representation of the digest over the label and key. =head2 digestbin $digestbin = $rr->digestbin; $rr->digestbin( $digestbin ); Binary representation of the digest over the label and key. =head2 babble print $rr->babble; The babble() method returns the 'BubbleBabble' representation of the digest if the Digest::BubbleBabble package is available, otherwise an empty string is returned. BubbleBabble represents a message digest as a string of plausible words, to make the digest easier to verify. The "words" are not necessarily real words, but they look more like words than a string of hex characters. The 'BubbleBabble' string is appended as a comment when the string method is called. =head2 create use Net::DNS::SEC; $dsrr = Net::DNS::RR::DS->create( $keyrr, digtype => 'SHA-256' ); $keyrr->print; $dsrr->print; This constructor takes a DNSKEY argument and will return the corresponding DS RR constructed using the specified algorithm. The digest algorithm defaults to SHA-1. =head2 verify $verify = $dsrr->verify($keyrr); The boolean verify method will return true if the hash over the key RR provided as the argument conforms to the data in the DS itself i.e. the DS points to the DNSKEY from the argument. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC. Author Olaf M. Kolkman Portions Copyright (c)2013,2021 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L =cut DNS/RR/AFSDB.pm000044400000006646152345050350006704 0ustar00package Net::DNS::RR::AFSDB; use strict; use warnings; our $VERSION = (qw$Id: AFSDB.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::AFSDB - DNS AFSDB resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{subtype} = unpack "\@$offset n", $$data; $self->{hostname} = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $hostname = $self->{hostname}; return pack 'n a*', $self->subtype, $hostname->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $hostname = $self->{hostname}; return join ' ', $self->subtype, $hostname->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(subtype hostname)) { $self->$_( shift @argument ) } return; } sub subtype { my ( $self, @value ) = @_; for (@value) { $self->{subtype} = 0 + $_ } return $self->{subtype} || 0; } sub hostname { my ( $self, @value ) = @_; for (@value) { $self->{hostname} = Net::DNS::DomainName2535->new($_) } return $self->{hostname} ? $self->{hostname}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name AFSDB subtype hostname'); =head1 DESCRIPTION Class for DNS AFS Data Base (AFSDB) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 subtype $subtype = $rr->subtype; $rr->subtype( $subtype ); A 16 bit integer which indicates the service offered by the listed host. =head2 hostname $hostname = $rr->hostname; $rr->hostname( $hostname ); The hostname field is a domain name of a host that has a server for the cell named by the owner name of the RR. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/KX.pm000044400000007164152345050350006403 0ustar00package Net::DNS::RR::KX; use strict; use warnings; our $VERSION = (qw$Id: KX.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::KX - DNS KX resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{exchange} = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $exchange = $self->{exchange}; return pack 'n a*', $self->preference, $exchange->encode( $offset + 2, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $exchange = $self->{exchange}; return join ' ', $self->preference, $exchange->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference exchange)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub exchange { my ( $self, @value ) = @_; for (@value) { $self->{exchange} = Net::DNS::DomainName2535->new($_) } return $self->{exchange} ? $self->{exchange}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name KX preference exchange'); =head1 DESCRIPTION DNS Key Exchange Delegation (KX) record =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer which specifies the preference given to this RR among others at the same owner. Lower values are preferred. =head2 exchange $exchange = $rr->exchange; $rr->exchange( $exchange ); A domain name which specifies a host willing to act as a key exchange for the owner name. =head1 COPYRIGHT Copyright (c)2009 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/X25.pm000044400000005525152345050350006436 0ustar00package Net::DNS::RR::X25; use strict; use warnings; our $VERSION = (qw$Id: X25.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::X25 - DNS X25 resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = Net::DNS::Text->decode( $data, $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return $self->{address}->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->{address}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address { my ( $self, @value ) = @_; for (@value) { $self->{address} = Net::DNS::Text->new($_) } return $self->{address} ? $self->{address}->value : undef; } sub PSDNaddress { return &address; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name X25 PSDNaddress'); =head1 DESCRIPTION Class for DNS X25 resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 PSDNaddress =head2 address $address = $rr->address; $rr->address( $address ); The PSDN-address is a string of decimal digits, beginning with the 4 digit DNIC (Data Network Identification Code), as specified in X.121. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/LP.pm000044400000007641152345050350006374 0ustar00package Net::DNS::RR::LP; use strict; use warnings; our $VERSION = (qw$Id: LP.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::LP - DNS LP resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); $self->{target} = Net::DNS::DomainName->decode( $data, $offset + 2 ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $target = $self->{target}; return pack 'n a*', $self->preference, $target->encode(); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; return join ' ', $self->preference, $target->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference target)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName->new($_) } return $self->{target} ? $self->{target}->name : undef; } sub FQDN { return shift->{target}->fqdn; } sub fqdn { return shift->{target}->fqdn; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN LP preference FQDN'); =head1 DESCRIPTION Class for DNS Locator Pointer (LP) resource records. The LP DNS resource record (RR) is used to hold the name of a subnetwork for ILNP. The name is an FQDN which can then be used to look up L32 or L64 records. LP is, effectively, a Locator Pointer to L32 and/or L64 records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit unsigned integer in network byte order that indicates the relative preference for this LP record among other LP records associated with this owner name. Lower values are preferred over higher values. =head2 FQDN, fqdn =head2 target $target = $rr->target; $rr->target( $target ); The FQDN field contains the DNS target name that is used to reference L32 and/or L64 records. =head1 COPYRIGHT Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/DSYNC.pm000044400000010134152345050350006730 0ustar00package Net::DNS::RR::DSYNC; use strict; use warnings; our $VERSION = (qw$Id: DSYNC.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::DSYNC - DNS DSYNC resource record =cut use integer; use Net::DNS::Parameters qw(:type); use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; @{$self}{qw(rrtype scheme port)} = unpack "\@$offset nCn", $$data; $self->{target} = Net::DNS::DomainName->decode( $data, $offset + 5, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $target = $self->{target}; return pack 'nCn a*', @{$self}{qw(rrtype scheme port)}, $target->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @params = map { $self->$_ } qw(rrtype scheme port); my $target = $self->{target}; return ( @params, $target->string ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->$_( shift @argument ) foreach qw(rrtype scheme port target); return; } sub rrtype { my ( $self, @value ) = @_; for (@value) { $self->{rrtype} = typebyname($_) } my $typecode = $self->{rrtype}; return defined $typecode ? typebyval($typecode) : undef; } sub scheme { my ( $self, @value ) = @_; for (@value) { $self->{scheme} = 0 + $_ } return $self->{scheme} || 0; } sub port { my ( $self, @value ) = @_; for (@value) { $self->{port} = 0 + $_ } return $self->{port} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName->new($_) } return $self->{target} ? $self->{target}->name : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name DSYNC rrtype scheme port target'); =head1 DESCRIPTION Class for DNS Generalized Notify (DSYNC) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 rrtype $rrtype = $rr->rrtype; $rr->rrtype($rrtype); The type of generalized NOTIFY for which this DSYNC RR defines the desired target address. =head2 scheme $scheme = $rr->scheme; $rr->scheme( $scheme ); The scheme indicates the mode used for locating the notification address. This is an 8 bit unsigned integer. Records with value 0 (null scheme) are ignored by consumers. =head2 port $port = $rr->port; $rr->port( $port ); The port on the host providing the notification service. This is a 16 bit unsigned integer. =head2 target $target = $rr->target; $rr->target( $target ); The domain name of the target host providing the service which listens for notifications of the specified type. This name MUST resolve to one or more address records. =head1 COPYRIGHT Copyright (c)2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L draft-ietf-dnsop-generalized-notify =cut DNS/RR/PX.pm000044400000010413152345050350006377 0ustar00package Net::DNS::RR::PX; use strict; use warnings; our $VERSION = (qw$Id: PX.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::PX - DNS PX resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; $self->{preference} = unpack( "\@$offset n", $$data ); ( $self->{map822}, $offset ) = Net::DNS::DomainName2535->decode( $data, $offset + 2, @opaque ); ( $self->{mapx400}, $offset ) = Net::DNS::DomainName2535->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $mapx400 = $self->{mapx400}; my $rdata = pack( 'n', $self->{preference} ); $rdata .= $self->{map822}->encode( $offset + 2, @opaque ); $rdata .= $mapx400->encode( $offset + length($rdata), @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->preference, $self->{map822}->string, $self->{mapx400}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(preference map822 mapx400)) { $self->$_( shift @argument ) } return; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub map822 { my ( $self, @value ) = @_; for (@value) { $self->{map822} = Net::DNS::DomainName2535->new($_) } return $self->{map822} ? $self->{map822}->name : undef; } sub mapx400 { my ( $self, @value ) = @_; for (@value) { $self->{mapx400} = Net::DNS::DomainName2535->new($_) } return $self->{mapx400} ? $self->{mapx400}->name : undef; } my $function = sub { ## sort RRs in numerically ascending order. return $Net::DNS::a->{'preference'} <=> $Net::DNS::b->{'preference'}; }; __PACKAGE__->set_rrsort_func( 'preference', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name PX preference map822 mapx400'); =head1 DESCRIPTION Class for DNS X.400 Mail Mapping Information (PX) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16 bit integer which specifies the preference given to this RR among others at the same owner. Lower values are preferred. =head2 map822 $map822 = $rr->map822; $rr->map822( $map822 ); A domain name element containing , the RFC822 part of the MIXER Conformant Global Address Mapping. =head2 mapx400 $mapx400 = $rr->mapx400; $rr->mapx400( $mapx400 ); A element containing the value of derived from the X.400 part of the MIXER Conformant Global Address Mapping. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/CAA.pm000044400000010144152345050350006435 0ustar00package Net::DNS::RR::CAA; use strict; use warnings; our $VERSION = (qw$Id: CAA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::CAA - DNS CAA resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; $self->{flags} = unpack "\@$offset C", $$data; ( $self->{tag}, $offset ) = Net::DNS::Text->decode( $data, $offset + 1 ); $self->{value} = Net::DNS::Text->decode( $data, $offset, $limit - $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C a* a*', $self->flags, $self->{tag}->encode, $self->{value}->raw; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = ( $self->flags, $self->{tag}->string, $self->{value}->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->flags( shift @argument ); $self->tag( lc shift @argument ); $self->value( shift @argument ); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->flags(0); return; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = 0 + $_ } return $self->{flags} || 0; } sub critical { my ( $self, @value ) = @_; if ( scalar @value ) { for ( $self->{flags} |= 0x80 ) { $_ ^= 0x80 unless shift @value; } } return $self->{flags} & 0x80; } sub tag { my ( $self, @value ) = @_; for (@value) { $self->{tag} = Net::DNS::Text->new($_) } return $self->{tag} ? $self->{tag}->value : undef; } sub value { my ( $self, @value ) = @_; for (@value) { $self->{value} = Net::DNS::Text->new($_) } return $self->{value} ? $self->{value}->value : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN CAA flags tag value'); =head1 DESCRIPTION Class for Certification Authority Authorization (CAA) DNS resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); Unsigned 8-bit number representing Boolean flags. =over 4 =item critical $rr->critical(1); if ( $rr->critical ) { ... } Issuer critical flag. =back =head2 tag $tag = $rr->tag; $rr->tag( $tag ); Property identifier which may contain the characters a-z, A-Z, and 0-9. The tag field must not contain any other characters. Matching of tags is not case sensitive. =head2 value $value = $rr->value; $rr->value( $value ); A sequence of octets representing the property value. Property values are encoded as binary values and may employ sub-formats. =head1 COPYRIGHT Copyright (c)2013,2015 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/AAAA.pm000044400000007654152345050350006550 0ustar00package Net::DNS::RR::AAAA; use strict; use warnings; our $VERSION = (qw$Id: AAAA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::AAAA - DNS AAAA resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a16", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a16', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address_short; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address_long { my $addr = pack 'a*@16', grep {defined} shift->{address}; return sprintf '%x:%x:%x:%x:%x:%x:%x:%x', unpack 'n8', $addr; } sub address_short { my $addr = pack 'a*@16', grep {defined} shift->{address}; local $_ = sprintf ':%x:%x:%x:%x:%x:%x:%x:%x:', unpack 'n8', $addr; s/(:0[:0]+:)(?!.+:0\1)/::/; # squash longest zero sequence s/^:// unless /^::/; # prune LH : s/:$// unless /::$/; # prune RH : return $_; } sub address { my ( $self, $addr ) = @_; return address_long($self) unless defined $addr; my @parse = split /:/, "0$addr"; if ( (@parse)[$#parse] =~ /\./ ) { # embedded IPv4 my @ip4 = split /\./, pop(@parse); my $rhs = pop(@ip4); my @ip6 = map { /./ ? hex($_) : (0) x ( 7 - @parse ) } @parse; return $self->{address} = pack 'n6 C4', @ip6, @ip4, (0) x ( 3 - @ip4 ), $rhs; } # Note: pack() masks overlarge values, mostly without warning. my @expand = map { /./ ? hex($_) : (0) x ( 9 - @parse ) } @parse; return $self->{address} = pack 'n8', @expand; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN AAAA address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'AAAA', address => '2001:DB8::8:800:200C:417A' ); =head1 DESCRIPTION Class for DNS IPv6 Address (AAAA) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address $IPv6_address = $rr->address; Returns the text representation of the IPv6 address. =head2 address_long $IPv6_address = $rr->address_long; Returns the text representation specified in RFC3513, 2.2(1). =head2 address_short $IPv6_address = $rr->address_short; Returns the textual form of address recommended by RFC5952. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2003 Chris Reinhardt. Portions Copyright (c)2012 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/TLSA.pm000044400000012443152345050350006620 0ustar00package Net::DNS::RR::TLSA; use strict; use warnings; our $VERSION = (qw$Id: TLSA.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::TLSA - DNS TLSA resource record =cut use integer; use Carp; use constant BABBLE => defined eval { require Digest::BubbleBabble }; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $next = $offset + $self->{rdlength}; @{$self}{qw(usage selector matchingtype)} = unpack "\@$offset C3", $$data; $offset += 3; $self->{certbin} = substr $$data, $offset, $next - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C3 a*', @{$self}{qw(usage selector matchingtype certbin)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; $self->_annotation( $self->babble ) if BABBLE; my @cert = split /(\S{64})/, $self->cert; my @rdata = ( $self->usage, $self->selector, $self->matchingtype, @cert ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(usage selector matchingtype)) { $self->$_( shift @argument ) } $self->cert(@argument); return; } sub usage { my ( $self, @value ) = @_; for (@value) { $self->{usage} = 0 + $_ } return $self->{usage} || 0; } sub selector { my ( $self, @value ) = @_; for (@value) { $self->{selector} = 0 + $_ } return $self->{selector} || 0; } sub matchingtype { my ( $self, @value ) = @_; for (@value) { $self->{matchingtype} = 0 + $_ } return $self->{matchingtype} || 0; } sub cert { my ( $self, @value ) = @_; return unpack "H*", $self->certbin() unless scalar @value; my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value; return $self->certbin( pack "H*", join "", @hex ); } sub certbin { my ( $self, @value ) = @_; for (@value) { $self->{certbin} = $_ } return $self->{certbin} || ""; } sub certificate { return &cert; } sub babble { return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name TLSA usage selector matchingtype certificate'); =head1 DESCRIPTION The Transport Layer Security Authentication (TLSA) DNS resource record is used to associate a TLS server certificate or public key with the domain name where the record is found, forming a "TLSA certificate association". The semantics of how the TLSA RR is interpreted are described in RFC6698. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 usage $usage = $rr->usage; $rr->usage( $usage ); 8-bit integer value which specifies the provided association that will be used to match the certificate presented in the TLS handshake. =head2 selector $selector = $rr->selector; $rr->selector( $selector ); 8-bit integer value which specifies which part of the TLS certificate presented by the server will be matched against the association data. =head2 matchingtype $matchingtype = $rr->matchingtype; $rr->matchingtype( $matchingtype ); 8-bit integer value which specifies how the certificate association is presented. =head2 certificate =head2 cert $cert = $rr->cert; $rr->cert( $cert ); Hexadecimal representation of the certificate data. =head2 certbin $certbin = $rr->certbin; $rr->certbin( $certbin ); Binary representation of the certificate data. =head2 babble print $rr->babble; The babble() method returns the 'BubbleBabble' representation of the digest if the Digest::BubbleBabble package is available, otherwise an empty string is returned. BubbleBabble represents a message digest as a string of plausible words, to make the digest easier to verify. The "words" are not necessarily real words, but they look more like words than a string of hex characters. The 'BubbleBabble' string is appended as a comment when the string method is called. =head1 COPYRIGHT Copyright (c)2012 Willem Toorop, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/EUI48.pm000044400000006274152345050350006660 0ustar00package Net::DNS::RR::EUI48; use strict; use warnings; our $VERSION = (qw$Id: EUI48.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::EUI48 - DNS EUI48 resource record =cut use integer; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; $self->{address} = unpack "\@$offset a6", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'a6', $self->{address}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return $self->address; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->address(@argument); return; } sub address { my ( $self, $address ) = @_; $self->{address} = pack 'C6', map { hex($_) } split /[:-]/, $address if $address; return defined(wantarray) ? join( '-', unpack 'H2H2H2H2H2H2', $self->{address} ) : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name IN EUI48 address'); $rr = Net::DNS::RR->new( name => 'example.com', type => 'EUI48', address => '00-00-5e-00-53-2a' ); =head1 DESCRIPTION DNS resource records for 48-bit Extended Unique Identifier (EUI48). The EUI48 resource record is used to represent IEEE Extended Unique Identifiers used in various layer-2 networks, ethernet for example. EUI48 addresses SHOULD NOT be published in the public DNS. RFC7043 describes potentially severe privacy implications resulting from indiscriminate publication of link-layer addresses in the DNS. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 address The address field is a 6-octet layer-2 address in network byte order. The presentation format is hexadecimal separated by "-". =head1 COPYRIGHT Copyright (c)2013 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/LOC.pm000044400000017601152345050350006473 0ustar00package Net::DNS::RR::LOC; use strict; use warnings; our $VERSION = (qw$Id: LOC.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::LOC - DNS LOC resource record =cut use integer; use Carp; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $version = $self->{version} = unpack "\@$offset C", $$data; @{$self}{qw(size hp vp latitude longitude altitude)} = unpack "\@$offset xC3N3", $$data; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return pack 'C4N3', @{$self}{qw(version size hp vp latitude longitude altitude)}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my ( $altitude, @precision ) = map { $self->$_() . 'm' } qw(altitude size hp vp); my $precision = join ' ', @precision; for ($precision) { s/^1m 10000m 10m$//; s/ 10000m 10m$//; s/ 10m$//; } return ( $self->latitude, '', $self->longitude, '', $altitude, $precision ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; my @lat; while ( scalar @argument ) { my $this = shift @argument; push( @lat, $this ); last if $this =~ /[NSns]/; } $self->latitude(@lat); my @long; while ( scalar @argument ) { my $this = shift @argument; push( @long, $this ); last if $this =~ /[EWew]/; } $self->longitude(@long); foreach my $attr (qw(altitude size hp vp)) { $self->$attr(@argument); shift @argument; } return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->{version} = 0; $self->size(1); $self->hp(10000); $self->vp(10); return; } sub latitude { my ( $self, @value ) = @_; $self->{latitude} = _encode_angle(@value) if scalar @value; return _decode_angle( $self->{latitude} || return, 'N', 'S' ); } sub longitude { my ( $self, @value ) = @_; $self->{longitude} = _encode_angle(@value) if scalar @value; return _decode_angle( $self->{longitude} || return, 'E', 'W' ); } sub altitude { my ( $self, @value ) = @_; $self->{altitude} = _encode_alt(@value) if scalar @value; return _decode_alt( $self->{altitude} ); } sub size { my ( $self, @value ) = @_; $self->{size} = _encode_prec(@value) if scalar @value; return _decode_prec( $self->{size} ); } sub hp { my ( $self, @value ) = @_; $self->{hp} = _encode_prec(@value) if scalar @value; return _decode_prec( $self->{hp} ); } sub horiz_pre { return &hp; } # uncoverable pod sub vp { my ( $self, @value ) = @_; $self->{vp} = _encode_prec(@value) if scalar @value; return _decode_prec( $self->{vp} ); } sub vert_pre { return &vp; } # uncoverable pod sub latlon { my ( $self, @argument ) = @_; my @lat = @argument; my ( undef, @long ) = @argument; return ( scalar $self->latitude(@lat), scalar $self->longitude(@long) ); } sub version { return shift->{version}; } ######################################## no integer; use constant ALTITUDE0 => 10000000; use constant ORDINATE0 => 0x80000000; sub _decode_angle { my ( $msec, $N, $S ) = @_; return int( 0.5 + ( $msec - ORDINATE0 ) / 0.36 ) / 10000000 unless wantarray; use integer; my $abs = abs( $msec - ORDINATE0 ); my $deg = int( $abs / 3600000 ); my $min = int( $abs / 60000 ) % 60; no integer; my $sec = ( $abs % 60000 ) / 1000; return ( $deg, $min, $sec, ( $msec < ORDINATE0 ? $S : $N ) ); } sub _encode_angle { my @ang = @_; @ang = split /[\s\260'"]+/, shift @ang unless scalar @ang > 1; my $ang = ( 0 + shift @ang ) * 3600000; my $neg = ( @ang ? pop @ang : '' ) =~ /[SWsw]/; $ang += ( @ang ? shift @ang : 0 ) * 60000; $ang += ( @ang ? shift @ang : 0 ) * 1000; return int( 0.5 + ( $neg ? ORDINATE0 - $ang : ORDINATE0 + $ang ) ); } sub _decode_alt { my $cm = ( shift || ALTITUDE0 ) - ALTITUDE0; return 0.01 * $cm; } sub _encode_alt { ( my $argument = shift ) =~ s/[Mm]$//; $argument += 0; return int( 0.5 + ALTITUDE0 + 100 * $argument ); } my @power10 = ( 0.01, 0.1, 1, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 0, 0, 0, 0, 0 ); sub _decode_prec { my $argument = shift || 0; my $mantissa = $argument >> 4; return $mantissa * $power10[$argument & 0x0F]; } sub _encode_prec { ( my $argument = shift ) =~ s/[Mm]$//; my $exponent = 0; until ( $argument < $power10[1 + $exponent] ) { $exponent++ } my $mantissa = int( 0.5 + $argument / $power10[$exponent] ); return ( $mantissa & 0xF ) << 4 | $exponent; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name LOC latitude longitude altitude size hp vp'); =head1 DESCRIPTION DNS geographical location (LOC) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 latitude $latitude = $rr->latitude; ($deg, $min, $sec, $ns ) = $rr->latitude; $rr->latitude( 42.357990 ); $rr->latitude( 42, 21, 28.764, 'N' ); $rr->latitude( '42 21 28.764 N' ); When invoked in scalar context, latitude is returned in degrees, a negative ordinate being south of the equator. When invoked in list context, latitude is returned as a list of separate degree, minute, and second values followed by N or S as appropriate. Optional replacement values may be represented as single value, list or formatted string. Trailing zero values are optional. =head2 longitude $longitude = $rr->longitude; ($deg, $min, $sec, $ew ) = $rr->longitude; $rr->longitude( -71.014338 ); $rr->longitude( 71, 0, 51.617, 'W' ); $rr->longitude( '71 0 51.617 W' ); When invoked in scalar context, longitude is returned in degrees, a negative ordinate being west of the prime meridian. When invoked in list context, longitude is returned as a list of separate degree, minute, and second values followed by E or W as appropriate. =head2 altitude $altitude = $rr->altitude; Represents altitude, in metres, relative to the WGS 84 reference spheroid used by GPS. =head2 size $size = $rr->size; Represents the diameter, in metres, of a sphere enclosing the described entity. =head2 hp $hp = $rr->hp; Represents the horizontal precision of the data expressed as the diameter, in metres, of the circle of error. =head2 vp $vp = $rr->vp; Represents the vertical precision of the data expressed as the total spread, in metres, of the distribution of possible values. =head2 latlon ($lat, $lon) = $rr->latlon; $rr->latlon($lat, $lon); Representation of the latitude and longitude coordinate pair as signed floating-point degrees. =head2 version $version = $rr->version; Version of LOC protocol. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2011 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/HINFO.pm000044400000006076152345050350006725 0ustar00package Net::DNS::RR::HINFO; use strict; use warnings; our $VERSION = (qw$Id: HINFO.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::HINFO - DNS HINFO resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; ( $self->{cpu}, $offset ) = Net::DNS::Text->decode( $data, $offset ); ( $self->{os}, $offset ) = Net::DNS::Text->decode( $data, $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return join '', $self->{cpu}->encode, $self->{os}->encode; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; return join ' ', $self->{cpu}->string, $self->{os}->string; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->cpu( shift @argument ); $self->os(@argument); return; } sub cpu { my ( $self, @value ) = @_; for (@value) { $self->{cpu} = Net::DNS::Text->new($_) } return $self->{cpu} ? $self->{cpu}->value : undef; } sub os { my ( $self, @value ) = @_; for (@value) { $self->{os} = Net::DNS::Text->new($_) } return $self->{os} ? $self->{os}->value : undef; } 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name HINFO cpu os'); =head1 DESCRIPTION Class for DNS Hardware Information (HINFO) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 cpu $cpu = $rr->cpu; $rr->cpu( $cpu ); Returns the CPU type for this RR. =head2 os $os = $rr->os; $rr->os( $os ); Returns the operating system type for this RR. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/NAPTR.pm000044400000013442152345050350006741 0ustar00package Net::DNS::RR::NAPTR; use strict; use warnings; our $VERSION = (qw$Id: NAPTR.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NAPTR - DNS NAPTR resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; @{$self}{qw(order preference)} = unpack "\@$offset n2", $$data; ( $self->{flags}, $offset ) = Net::DNS::Text->decode( $data, $offset + 4 ); ( $self->{service}, $offset ) = Net::DNS::Text->decode( $data, $offset ); ( $self->{regexp}, $offset ) = Net::DNS::Text->decode( $data, $offset ); $self->{replacement} = Net::DNS::DomainName2535->decode( $data, $offset, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $rdata = pack 'n2', @{$self}{qw(order preference)}; $rdata .= $self->{flags}->encode; $rdata .= $self->{service}->encode; $rdata .= $self->{regexp}->encode; $rdata .= $self->{replacement}->encode( $offset + length($rdata), @opaque ); return $rdata; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @order = @{$self}{qw(order preference)}; my @rdata = ( @order, map { $_->string } @{$self}{qw(flags service regexp replacement)} ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach (qw(order preference flags service regexp replacement)) { $self->$_( shift @argument ) } return; } sub order { my ( $self, @value ) = @_; for (@value) { $self->{order} = 0 + $_ } return $self->{order} || 0; } sub preference { my ( $self, @value ) = @_; for (@value) { $self->{preference} = 0 + $_ } return $self->{preference} || 0; } sub flags { my ( $self, @value ) = @_; for (@value) { $self->{flags} = Net::DNS::Text->new($_) } return $self->{flags} ? $self->{flags}->value : undef; } sub service { my ( $self, @value ) = @_; for (@value) { $self->{service} = Net::DNS::Text->new($_) } return $self->{service} ? $self->{service}->value : undef; } sub regexp { my ( $self, @value ) = @_; for (@value) { $self->{regexp} = Net::DNS::Text->new($_) } return $self->{regexp} ? $self->{regexp}->value : undef; } sub replacement { my ( $self, @value ) = @_; for (@value) { $self->{replacement} = Net::DNS::DomainName2535->new($_) } return $self->{replacement} ? $self->{replacement}->name : undef; } my $function = sub { my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); return $a->{order} <=> $b->{order} || $a->{preference} <=> $b->{preference}; }; __PACKAGE__->set_rrsort_func( 'order', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name NAPTR ( order preference flags service regexp replacement )'); =head1 DESCRIPTION DNS Naming Authority Pointer (NAPTR) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 order $order = $rr->order; $rr->order( $order ); A 16-bit unsigned integer specifying the order in which the NAPTR records must be processed to ensure the correct ordering of rules. Low numbers are processed before high numbers. =head2 preference $preference = $rr->preference; $rr->preference( $preference ); A 16-bit unsigned integer that specifies the order in which NAPTR records with equal "order" values should be processed, low numbers being processed before high numbers. =head2 flags $flags = $rr->flags; $rr->flags( $flags ); A string containing flags to control aspects of the rewriting and interpretation of the fields in the record. Flags are single characters from the set [A-Z0-9]. =head2 service $service = $rr->service; $rr->service( $service ); Specifies the service(s) available down this rewrite path. It may also specify the protocol used to communicate with the service. =head2 regexp $regexp = $rr->regexp; $rr->regexp; A string containing a substitution expression that is applied to the original string held by the client in order to construct the next domain name to lookup. =head2 replacement $replacement = $rr->replacement; $rr->replacement( $replacement ); The next NAME to query for NAPTR, SRV, or address records depending on the value of the flags field. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. Based on code contributed by Ryan Moats. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/NSEC.pm000044400000017772152345050350006617 0ustar00package Net::DNS::RR::NSEC; use strict; use warnings; our $VERSION = (qw$Id: NSEC.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::NSEC - DNS NSEC resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::Parameters qw(:type); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; ( $self->{nxtdname}, $offset ) = Net::DNS::DomainName->decode( $data, $offset ); $self->{typebm} = substr $$data, $offset, $limit - $offset; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $nxtdname = $self->{nxtdname}; return join '', $nxtdname->encode(), $self->{typebm}; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $nxtdname = $self->{nxtdname}; return ( $nxtdname->string(), $self->typelist ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->nxtdname( shift @argument ); $self->typelist(@argument); return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata('.'); return; } sub nxtdname { my ( $self, @value ) = @_; for (@value) { $self->{nxtdname} = Net::DNS::DomainName->new($_) } return $self->{nxtdname} ? $self->{nxtdname}->name : undef; } sub typelist { my ( $self, @argument ) = @_; if ( scalar(@argument) || !defined(wantarray) ) { $self->{typebm} = &_type2bm(@argument); return; } my @type = &_bm2type( $self->{typebm} ); return wantarray ? (@type) : "@type"; } sub typemap { my ( $self, $type ) = @_; my $number = typebyname($type); my $window = $number >> 8; my $bitnum = $number & 255; my $typebm = $self->{typebm} || return; my @bitmap; my $index = 0; while ( $index < length $typebm ) { my ( $block, $size ) = unpack "\@$index C2", $typebm; $bitmap[$block] = unpack "\@$index xxa$size", $typebm; $index += $size + 2; } my @bit = split //, unpack 'B*', ( $bitmap[$window] || return ); return $bit[$bitnum]; } sub match { my ( $self, $qname ) = @_; my $name = Net::DNS::DomainName->new($qname)->canonical; return $name eq $self->{owner}->canonical; } sub covers { my ( $self, $qname ) = @_; my $name = join chr(0), reverse Net::DNS::DomainName->new($qname)->_wire; my $this = join chr(0), reverse $self->{owner}->_wire; my $next = join chr(0), reverse $self->{nxtdname}->_wire; foreach ( $name, $this, $next ) {tr /\101-\132/\141-\172/} return ( $name cmp $this ) + ( "$next\001" cmp $name ) == 2 unless $next gt $this; return ( $name cmp $this ) + ( $next cmp $name ) == 2; } sub encloser { my ( $self, $qname ) = @_; my @label = Net::DNS::Domain->new($qname)->label; my @owner = $self->{owner}->label; my $depth = scalar(@owner); my $next; while ( scalar(@label) > $depth ) { $next = shift @label; } return unless defined $next; my $nextcloser = join( '.', $next, @label ); return if lc($nextcloser) ne lc( join '.', $next, @owner ); $self->{nextcloser} = $nextcloser; $self->{wildcard} = join( '.', '*', @label ); return $self->owner; } sub nextcloser { return shift->{nextcloser}; } sub wildcard { return shift->{wildcard}; } ######################################## sub _type2bm { my @typelist = @_; my @typearray; foreach my $typename ( map { split() } @typelist ) { my $number = typebyname($typename); my $window = $number >> 8; my $bitnum = $number & 255; my $octet = $bitnum >> 3; my $bit = $bitnum & 7; $typearray[$window][$octet] |= 0x80 >> $bit; } my $bitmap = ''; my $window = 0; foreach (@typearray) { if ( my $pane = $typearray[$window] ) { my @content = map { $_ || 0 } @$pane; $bitmap .= pack 'CC C*', $window, scalar(@content), @content; } $window++; } return $bitmap; } sub _bm2type { my @empty; my $bitmap = shift || return @empty; my $index = 0; my $limit = length $bitmap; my @typelist; while ( $index < $limit ) { my ( $block, $size ) = unpack "\@$index C2", $bitmap; my $typenum = $block << 8; foreach my $octet ( unpack "\@$index xxC$size", $bitmap ) { my $i = $typenum += 8; my @name; while ($octet) { --$i; unshift @name, typebyval($i) if $octet & 1; $octet = $octet >> 1; } push @typelist, @name; } $index += $size + 2; } return @typelist; } sub typebm { ## historical my ( $self, @typebm ) = @_; # uncoverable pod for (@typebm) { $self->{typebm} = $_ } $self->_deprecate('prefer $rr->typelist() or $rr->typemap()'); return $self->{typebm}; } sub covered { ## historical my ( $self, @argument ) = @_; # uncoverable pod return $self->covers(@argument); } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new( 'name NSEC nxtdname typelist' ); =head1 DESCRIPTION Class for DNSSEC NSEC resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 nxtdname $nxtdname = $rr->nxtdname; $rr->nxtdname( $nxtdname ); The Next Domain field contains the next owner name (in the canonical ordering of the zone) that has authoritative data or contains a delegation point NS RRset. =head2 typelist @typelist = $rr->typelist; $typelist = $rr->typelist; typelist() identifies the RRset types that exist at the NSEC RR owner name. When called in scalar context, the list is interpolated into a string. =head2 typemap $exists = $rr->typemap($rrtype); typemap() returns a Boolean true value if the specified RRtype occurs in the type bitmap of the NSEC record. =head2 match $matched = $rr->match( 'example.foo' ); match() returns a Boolean true value if the canonical form of the name argument matches the canonical owner name of the NSEC RR. =head2 covers $covered = $rr->covers( 'example.foo' ); covers() returns a Boolean true value if the canonical form of the name, or one of its ancestors, falls between the owner name and the nxtdname field of the NSEC record. =head2 encloser, nextcloser, wildcard $encloser = $rr->encloser( 'example.foo' ); print "encloser: $encloser\n" if $encloser; encloser() returns the name of a provable encloser of the query name argument obtained from the NSEC RR. nextcloser() returns the next closer name, which is one label longer than the closest encloser. This is only valid after encloser() has returned a valid domain name. wildcard() returns the unexpanded wildcard name from which the next closer name was possibly synthesised. This is only valid after encloser() has returned a valid domain name. =head1 COPYRIGHT Copyright (c)2001-2005 RIPE NCC. Author Olaf M. Kolkman Portions Copyright (c)2018-2019 Dick Franks All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/SVCB.pm000044400000030051152345050350006605 0ustar00package Net::DNS::RR::SVCB; use strict; use warnings; our $VERSION = (qw$Id: SVCB.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SVCB - DNS SVCB resource record =cut use integer; use Net::DNS::DomainName; use Net::DNS::RR::A; use Net::DNS::RR::AAAA; use Net::DNS::Text; use MIME::Base64; my %keybyname = ( mandatory => 'key0', # RFC9460(8) alpn => 'key1', # RFC9460(7.1) 'no-default-alpn' => 'key2', # RFC9460(7.1) port => 'key3', # RFC9460(7.2) ipv4hint => 'key4', # RFC9460(7.3) ech => 'key5', # RFC9460 ipv6hint => 'key6', # RFC9460(7.3) dohpath => 'key7', # RFC9461 ohttp => 'key8', # RFC9540(4) 'tls-supported-groups' => 'key9', ); my %boolean = ( 'no-default-alpn' => 'key2', ohttp => 'key8', ); sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $self->{rdlength}; my $rdata = $self->{rdata} = substr $$data, $offset, $limit; $self->{SvcPriority} = unpack 'n', $rdata; ( $self->{TargetName}, $offset ) = Net::DNS::DomainName->decode( \$rdata, 2 ); my $params = $self->{SvcParams} = []; while ( ( my $start = $offset + 4 ) <= $limit ) { my ( $key, $size ) = unpack( "\@$offset n2", $rdata ); my $next = $start + $size; last if $next > $limit; push @$params, ( $key, substr $rdata, $start, $size ); $offset = $next; } die $self->type . ': corrupt RDATA' unless $offset == $limit; return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; return $self->{rdata} if $self->{rdata}; my @packed = pack 'n a*', $self->{SvcPriority}, $self->{TargetName}->encode; my $params = $self->{SvcParams} || []; my @params = @$params; while (@params) { my $key = shift @params; my $val = shift @params; push @packed, pack( 'n2a*', $key, length($val), $val ); } return join '', @packed; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my @rdata = unpack 'H4', pack 'n', $self->{SvcPriority}; my $encode = $self->{TargetName}->encode(); my $length = 2 + length $encode; my @target = grep {length} split /(\S{32})/, unpack 'H*', $encode; my $target = substr $self->{TargetName}->string, 0, 40; push @rdata, join '', shift(@target), "\t; $target\n"; push @rdata, @target; my $params = $self->{SvcParams} || []; my @params = @$params; while (@params) { my $key = shift @params; my $val = shift @params; push @rdata, "\n", unpack 'H4H4', pack( 'n2', $key, length $val ); my @hex = grep {length} split /(\S{32})/, unpack 'H*', $val; push @rdata, shift @hex if @hex; push @rdata, "\t; key$key\n" unless $key < 16; push @rdata, @hex; $length += 4 + length $val; } if ( $self->{rdata} ) { if ( my $corrupt = substr $self->{rdata}, $length ) { my ( $hex, @hex ) = grep {length} split /(\S{32})/, unpack 'H*', $corrupt; push @rdata, "\n$hex\t; corrupt RDATA\n", @hex; $length += length $corrupt; } } return ( "\\# $length", @rdata ); } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; $self->svcpriority( shift @argument ); $self->targetname( shift @argument ); local $SIG{__WARN__} = sub { die @_ }; while ( my $svcparam = shift @argument ) { for ($svcparam) { my @value; if (/^key\d+=(.*)$/i) { local $_ = length($1) ? $1 : shift @argument; s/^"([^"]*)"$/$1/; # strip enclosing quotes push @value, $_; } elsif (/^[^=]+=(.*)$/) { local $_ = length($1) ? $1 : shift @argument; die <<"Amen" if /\\092[,\\]/; SVCB: Please use standard RFC1035 escapes RFC9460 double-escape nonsense not implemented Amen s/^"([^"]*)"$/$1/; # strip enclosing quotes s/\\,/\\044/g; # disguise (RFC1035) escaped comma push @value, split /,/; } else { push @value, '' unless $keybyname{$_}; # unregistered boolean key } m/^([^=]+)/; # extract identifier my $key = $1; push @value, 1 if $boolean{$key}; $key =~ s/[-]/_/g; $self->$key(@value); } } return; } sub _post_parse { ## parser post processing my $self = shift; my $paramref = $self->{SvcParams} || []; my %svcparam = scalar(@$paramref) ? @$paramref : return; $self->key0(undef); # ruse to force sorting of SvcParams if ( defined $svcparam{0} ) { my %unique; foreach ( grep { !$unique{$_}++ } unpack 'n*', $svcparam{0} ) { die( $self->type . qq[: unexpected "key0" in mandatory list] ) if $unique{0}; die( $self->type . qq[: duplicate "key$_" in mandatory list] ) if --$unique{$_}; die( $self->type . qq[: mandatory "key$_" not present] ) unless defined $svcparam{$_}; } $self->mandatory( keys %unique ); # restore mandatory key list } die( $self->type . qq[: expected alpn="..." not present] ) if defined( $svcparam{2} ) && !$svcparam{1}; return; } sub _defaults { ## specify RR attribute default values my $self = shift; $self->_parse_rdata(qw(0 .)); return; } sub svcpriority { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{SvcPriority} = 0 + $_ } return $self->{SvcPriority} || 0; } sub targetname { my ( $self, @value ) = @_; # uncoverable pod for (@value) { $self->{TargetName} = Net::DNS::DomainName->new($_) } my $target = $self->{TargetName} ? $self->{TargetName}->name : return; return $target unless $self->{SvcPriority}; return ( $target eq '.' ) ? $self->owner : $target; } sub mandatory { ## mandatory=key1,port,... my ( $self, @value ) = @_; my @list = map { $keybyname{lc $_} || $_ } map { split /,/ } @value; my @keys = map { /(\d+)$/ ? $1 : die( $self->type . qq[: unexpected "$_"] ) } @list; return $self->key0( _integer16( sort { $a <=> $b } @keys ) ); } sub alpn { ## alpn=h3,h2,... my ( $self, @value ) = @_; return $self->key1( _string(@value) ); } sub no_default_alpn { ## no-default-alpn (Boolean) my ( $self, @value ) = @_; # uncoverable pod return $self->key2( _boolean(@value) ); } sub port { ## port=1234 my ( $self, @value ) = @_; return $self->key3( map { _integer16($_) } @value ); } sub ipv4hint { ## ipv4hint=192.0.2.1,... my ( $self, @value ) = @_; return $self->key4( _ipv4(@value) ); } sub ech { ## ech=base64 my ( $self, @value ) = @_; return $self->key5( map { _base64($_) } @value ); } sub ipv6hint { ## ipv6hint=2001:DB8::1,... my ( $self, @value ) = @_; return $self->key6( _ipv6(@value) ); } sub dohpath { ## dohpath=/dns-query{?dns} my ( $self, @value ) = @_; # uncoverable pod return $self->key7(@value); } sub ohttp { ## ohttp my ( $self, @value ) = @_; # uncoverable pod return $self->key8( _boolean(@value) ); } sub tls_supported_groups { ## tls_supported_groups=29,23 my ( $self, @value ) = @_; # uncoverable pod return $self->key9( _integer16(@value) ); } ######################################## sub _presentation { ## represent octet string(s) using local charset my @arg = @_; my $raw = scalar(@arg) ? join( '', @arg ) : return (); # concatenate arguments return Net::DNS::Text->decode( \$raw, 0, length($raw) )->string; } sub _boolean { my @arg = @_; return @arg unless scalar @arg; # read key my $arg = shift @arg; return $arg unless defined $arg; # delete key. return ( $arg ? '' : undef, @arg ); # set key } sub _string { my @arg = @_; return _presentation( map { Net::DNS::Text->new($_)->encode() } @arg ); } sub _base64 { my @arg = @_; return _presentation( map { MIME::Base64::decode($_) } @arg ); } sub _integer16 { my @arg = @_; return _presentation( map { pack( 'n', $_ ) } @arg ); } sub _ipv4 { my @arg = @_; return _presentation( map { Net::DNS::RR::A::address( {}, $_ ) } @arg ); } sub _ipv6 { my @arg = @_; return _presentation( map { Net::DNS::RR::AAAA::address( {}, $_ ) } @arg ); } sub AUTOLOAD { ## Dynamic constructor/accessor methods my ( $self, @argument ) = @_; our $AUTOLOAD; my ($method) = reverse split /::/, $AUTOLOAD; my $super = "SUPER::$method"; return $self->$super(@argument) unless $method =~ /^key[0]*(\d+)$/i; my $key = $1; my $paramsref = $self->{SvcParams} || []; my %svcparams = @$paramsref; if ( scalar @argument ) { my $arg = shift @argument; # keyNN($value); delete $svcparams{$key} unless defined $arg; die( $self->type . qq[: duplicate SvcParam "key$key"] ) if defined $svcparams{$key}; die( $self->type . qq[: invalid SvcParam "key$key"] ) if $key > 65534; die( $self->type . qq[: unexpected "key$key" value] ) if scalar @argument; delete $self->{rdata}; $svcparams{$key} = Net::DNS::Text->new("$arg")->raw if defined $arg; $self->{SvcParams} = [map { ( $_, $svcparams{$_} ) } sort { $a <=> $b } keys %svcparams]; } else { die( $self->type . qq[: no value specified for "key$key"] ) unless defined wantarray; } return $svcparams{$key}; } ######################################## 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SVCB SvcPriority TargetName SvcParams'); =head1 DESCRIPTION DNS Service Binding (SVCB) resource record Service binding and parameter specification via the DNS (SVCB and HTTPS RRs) =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 SvcPriority $svcpriority = $rr->svcpriority; $rr->svcpriority( $svcpriority ); The priority of this record (relative to others, with lower values preferred). A value of 0 indicates AliasMode. =head2 TargetName $rr->targetname( $targetname ); $effecivetarget = $rr->targetname; The domain name of either the alias target (for AliasMode) or the alternative endpoint (for ServiceMode). For AliasMode SVCB RRs, a TargetName of "." indicates that the service is not available or does not exist. For ServiceMode SVCB RRs, a TargetName of "." indicates that the owner name of this record must be used as the effective TargetName. =head2 mandatory, alpn, no-default-alpn, port, ipv4hint, ech, ipv6hint $rr = Net::DNS::RR->new( 'svcb.example. SVCB 1 svcb.example. port=1234' ); $rr->port(1234); $octets = $rr->port(); # 0x04 0xD2 $octets = $rr->key3(); Constructor methods for mnemonic SvcParams prescribed by RFC9460. When invoked without arguments, the methods return the value of the underlying key as an uninterpreted octet string. The behaviour with undefined arguments is not specified. =head2 keyNN $keynn = $rr->keyNN; $rr->keyNN( $keynn ); $rr->keyNN( undef ); Generic constructor and accessor methods for SvcParams. The key index NN is a decimal integer in the range 0 .. 65535. The method argument is a presentation format character string. The returned value is an uninterpreted octet string. The method returns the undefined value if the key is not present. The specified key will be deleted if the argument is undefined. =head1 COPYRIGHT Copyright (c)2020-2024 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/RR/SRV.pm000044400000010625152345050350006527 0ustar00package Net::DNS::RR::SRV; use strict; use warnings; our $VERSION = (qw$Id: SRV.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::SRV - DNS SRV resource record =cut use integer; use Net::DNS::DomainName; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset, @opaque ) = @_; @{$self}{qw(priority weight port)} = unpack( "\@$offset n3", $$data ); $self->{target} = Net::DNS::DomainName2535->decode( $data, $offset + 6, @opaque ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my ( $self, $offset, @opaque ) = @_; my $target = $self->{target}; my @nums = ( $self->priority, $self->weight, $self->port ); return pack 'n3 a*', @nums, $target->encode( $offset + 6, @opaque ); } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; my @rdata = ( $self->priority, $self->weight, $self->port, $target->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; foreach my $attr (qw(priority weight port target)) { $self->$attr( shift @argument ); } return; } sub priority { my ( $self, @value ) = @_; for (@value) { $self->{priority} = 0 + $_ } return $self->{priority} || 0; } sub weight { my ( $self, @value ) = @_; for (@value) { $self->{weight} = 0 + $_ } return $self->{weight} || 0; } sub port { my ( $self, @value ) = @_; for (@value) { $self->{port} = 0 + $_ } return $self->{port} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::DomainName2535->new($_) } return $self->{target} ? $self->{target}->name : undef; } # order RRs by numerically increasing priority, decreasing weight my $function = sub { my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); return $a->{priority} <=> $b->{priority} || $b->{weight} <=> $a->{weight}; }; __PACKAGE__->set_rrsort_func( 'priority', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name SRV priority weight port target'); =head1 DESCRIPTION Class for DNS Service (SRV) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 priority $priority = $rr->priority; $rr->priority( $priority ); Returns the priority for this target host. =head2 weight $weight = $rr->weight; $rr->weight( $weight ); Returns the weight for this target host. =head2 port $port = $rr->port; $rr->port( $port ); Returns the port number for the service on this target host. =head2 target $target = $rr->target; $rr->target( $target ); Returns the domain name of the target host. =head1 Sorting of SRV Records By default, rrsort() returns the SRV records sorted from lowest to highest priority and for equal priorities from highest to lowest weight. Note: This is NOT the order in which connections should be attempted. =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2005 Olaf Kolkman, NLnet Labs. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/RR/URI.pm000044400000010360152345050350006510 0ustar00package Net::DNS::RR::URI; use strict; use warnings; our $VERSION = (qw$Id: URI.pm 2003 2025-01-21 12:06:06Z willem $)[2]; use base qw(Net::DNS::RR); =head1 NAME Net::DNS::RR::URI - DNS URI resource record =cut use integer; use Net::DNS::Text; sub _decode_rdata { ## decode rdata from wire-format octet string my ( $self, $data, $offset ) = @_; my $limit = $offset + $self->{rdlength}; @{$self}{qw(priority weight)} = unpack( "\@$offset n2", $$data ); $offset += 4; $self->{target} = Net::DNS::Text->decode( $data, $offset, $limit - $offset ); return; } sub _encode_rdata { ## encode rdata as wire-format octet string my $self = shift; my $target = $self->{target}; return pack 'n2 a*', @{$self}{qw(priority weight)}, $target->raw; } sub _format_rdata { ## format rdata portion of RR string. my $self = shift; my $target = $self->{target}; my @rdata = ( $self->priority, $self->weight, $target->string ); return @rdata; } sub _parse_rdata { ## populate RR from rdata in argument list my ( $self, @argument ) = @_; for (qw(priority weight target)) { $self->$_( shift @argument ) } return; } sub priority { my ( $self, @value ) = @_; for (@value) { $self->{priority} = 0 + $_ } return $self->{priority} || 0; } sub weight { my ( $self, @value ) = @_; for (@value) { $self->{weight} = 0 + $_ } return $self->{weight} || 0; } sub target { my ( $self, @value ) = @_; for (@value) { $self->{target} = Net::DNS::Text->new($_) } return $self->{target} ? $self->{target}->value : undef; } # order RRs by numerically increasing priority, decreasing weight my $function = sub { my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); return $a->{priority} <=> $b->{priority} || $b->{weight} <=> $a->{weight}; }; __PACKAGE__->set_rrsort_func( 'priority', $function ); __PACKAGE__->set_rrsort_func( 'default_sort', $function ); 1; __END__ =head1 SYNOPSIS use Net::DNS; $rr = Net::DNS::RR->new('name URI priority weight target'); =head1 DESCRIPTION Class for DNS Service (URI) resource records. =head1 METHODS The available methods are those inherited from the base class augmented by the type-specific methods defined in this package. Use of undocumented package features or direct access to internal data structures is discouraged and could result in program termination or other unpredictable behaviour. =head2 priority $priority = $rr->priority; $rr->priority( $priority ); The priority of the target URI in this RR. The range of this number is 0-65535. A client MUST attempt to contact the URI with the lowest-numbered priority it can reach; weighted selection being used to distribute load across targets with equal priority. =head2 weight $weight = $rr->weight; $rr->weight( $weight ); A server selection mechanism. The weight field specifies a relative weight for entries with the same priority. Larger weights SHOULD be given a proportionately higher probability of being selected. The range of this number is 0-65535. =head2 target $target = $rr->target; $rr->target( $target ); The URI of the target. Resolution of the URI is according to the definitions for the Scheme of the URI. =head1 COPYRIGHT Copyright (c)2015 Dick Franks. All rights reserved. Package template (c)2009,2012 O.M.Kolkman and R.W.Franks. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L =cut DNS/Header.pm000044400000024435152345050350006726 0ustar00package Net::DNS::Header; use strict; use warnings; our $VERSION = (qw$Id: Header.pm 2002 2025-01-07 09:57:46Z willem $)[2]; =head1 NAME Net::DNS::Header - DNS packet header =head1 SYNOPSIS use Net::DNS; $packet = Net::DNS::Packet->new(); $header = $packet->header; =head1 DESCRIPTION C represents the header portion of a DNS packet. =cut use integer; use Carp; use Net::DNS::Parameters qw(:opcode :rcode); =head1 METHODS =head2 $packet->header $packet = Net::DNS::Packet->new(); $header = $packet->header; Net::DNS::Header objects emanate from the Net::DNS::Packet header() method, and contain an opaque reference to the parent Packet object. Header objects may be assigned to suitably scoped lexical variables. They should never be stored in global variables or persistent data structures. =head2 string print $packet->header->string; Returns a string representation of the packet header. =cut sub string { my $self = shift; my $id = $self->id; my $qr = $self->qr; my $opcode = $self->opcode; my $rcode = $self->rcode; my $qd = $self->qdcount; my $an = $self->ancount; my $ns = $self->nscount; my $ar = $self->arcount; my $dispid = defined $id ? $id : 'undef'; return <<"QQ" if $opcode eq 'DSO'; ;; id = $dispid qr = $qr ;; opcode = $opcode rcode = $rcode QQ return <<"QQ" if $opcode eq 'UPDATE'; ;; id = $dispid qr = $qr ;; opcode = $opcode rcode = $rcode ;; zocount = $qd prcount = $an ;; upcount = $ns adcount = $ar QQ my $aa = $self->aa; my $tc = $self->tc; my $rd = $self->rd; my $ra = $self->ra; my $zz = $self->z; my $ad = $self->ad; my $cd = $self->cd; my $do = $self->do; my $co = $self->co; return <<"QQ"; ;; id = $dispid ;; qr = $qr aa = $aa tc = $tc rd = $rd opcode = $opcode ;; ra = $ra z = $zz ad = $ad cd = $cd rcode = $rcode ;; do = $do co = $co ;; qdcount = $qd ancount = $an ;; nscount = $ns arcount = $ar QQ } =head2 print $packet->header->print; Prints the string representation of the packet header. =cut sub print { print &string; return; } =head2 id print "query id = ", $packet->header->id, "\n"; $packet->header->id(1234); Gets or sets the query identification number. =cut sub id { my ( $self, @value ) = @_; for (@value) { $$self->{id} = $_ } return $$self->{id}; } =head2 opcode print "query opcode = ", $packet->header->opcode, "\n"; $packet->header->opcode("UPDATE"); Gets or sets the query opcode (the purpose of the query). =cut sub opcode { my ( $self, $arg ) = @_; my $opcode; for ( $$self->{status} ) { return opcodebyval( ( $_ >> 11 ) & 0x0f ) unless defined $arg; $opcode = opcodebyname($arg); $_ = ( $_ & 0x87ff ) | ( $opcode << 11 ); } return $opcode; } =head2 rcode print "query response code = ", $packet->header->rcode, "\n"; $packet->header->rcode("SERVFAIL"); Gets or sets the query response code (the status of the query). =cut sub rcode { my ( $self, $arg ) = @_; my $rcode; for ( $$self->{status} ) { my $opt = $$self->edns; unless ( defined $arg ) { $rcode = ( $opt->rcode & 0xff0 ) | ( $_ & 0x00f ); $opt->rcode($rcode); # write back full 12-bit rcode return $rcode == 16 ? 'BADVERS' : rcodebyval($rcode); } $rcode = rcodebyname($arg); $opt->rcode($rcode); # full 12-bit rcode $_ &= 0xfff0; # low 4-bit rcode $_ |= ( $rcode & 0x000f ); } return $rcode; } =head2 qr print "query response flag = ", $packet->header->qr, "\n"; $packet->header->qr(0); Gets or sets the query response flag. =cut sub qr { my ( $self, @value ) = @_; return $self->_dnsflag( 0x8000, @value ); } =head2 aa print "response is ", $packet->header->aa ? "" : "non-", "authoritative\n"; $packet->header->aa(0); Gets or sets the authoritative answer flag. =cut sub aa { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0400, @value ); } =head2 tc print "packet is ", $packet->header->tc ? "" : "not ", "truncated\n"; $packet->header->tc(0); Gets or sets the truncated packet flag. =cut sub tc { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0200, @value ); } =head2 rd print "recursion was ", $packet->header->rd ? "" : "not ", "desired\n"; $packet->header->rd(0); Gets or sets the recursion desired flag. =cut sub rd { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0100, @value ); } =head2 ra print "recursion is ", $packet->header->ra ? "" : "not ", "available\n"; $packet->header->ra(0); Gets or sets the recursion available flag. =cut sub ra { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0080, @value ); } =head2 z Unassigned bit, should always be zero. =cut sub z { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0040, @value ); } =head2 ad print "The response has ", $packet->header->ad ? "" : "not", "been verified\n"; Relevant in DNSSEC context. (The AD bit is only set on a response where signatures have been cryptographically verified or the server is authoritative for the data and is allowed to set the bit by policy.) =cut sub ad { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0020, @value ); } =head2 cd print "checking was ", $packet->header->cd ? "not" : "", "desired\n"; $packet->header->cd(0); Gets or sets the checking disabled flag. =cut sub cd { my ( $self, @value ) = @_; return $self->_dnsflag( 0x0010, @value ); } =head2 qdcount, zocount print "# of question records: ", $packet->header->qdcount, "\n"; Returns the number of records in the question section of the packet. In dynamic update packets, this field is known as C and refers to the number of RRs in the zone section. =cut sub qdcount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->qdcount is read-only') } return $$self->{count}[0] || scalar @{$$self->{question}}; } =head2 ancount, prcount print "# of answer records: ", $packet->header->ancount, "\n"; Returns the number of records in the answer section of the packet which may, in the case of corrupt packets, differ from the actual number of records. In dynamic update packets, this field is known as C and refers to the number of RRs in the prerequisite section. =cut sub ancount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->ancount is read-only') } return $$self->{count}[1] || scalar @{$$self->{answer}}; } =head2 nscount, upcount print "# of authority records: ", $packet->header->nscount, "\n"; Returns the number of records in the authority section of the packet which may, in the case of corrupt packets, differ from the actual number of records. In dynamic update packets, this field is known as C and refers to the number of RRs in the update section. =cut sub nscount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->nscount is read-only') } return $$self->{count}[2] || scalar @{$$self->{authority}}; } =head2 arcount, adcount print "# of additional records: ", $packet->header->arcount, "\n"; Returns the number of records in the additional section of the packet which may, in the case of corrupt packets, differ from the actual number of records. In dynamic update packets, this field is known as C. =cut sub arcount { my ( $self, @value ) = @_; for (@value) { $self->_warn('packet->header->arcount is read-only') } return $$self->{count}[3] || scalar @{$$self->{additional}}; } sub zocount { return &qdcount; } sub prcount { return &ancount; } sub upcount { return &nscount; } sub adcount { return &arcount; } =head1 EDNS Protocol Extensions =head2 do, co print "DNSSEC_OK flag was ", $packet->header->do ? "not" : "", "set\n"; $packet->header->do(1); Gets or sets the named EDNS flag. =cut sub do { my ( $self, @value ) = @_; return $self->_ednsflag( 0x8000, @value ); } sub co { my ( $self, @value ) = @_; return $self->_ednsflag( 0x4000, @value ); } =head2 Extended rcode EDNS extended rcodes are handled transparently by $packet->header->rcode(). =head2 UDP packet size $udp_max = $packet->edns->UDPsize; EDNS offers a mechanism to advertise the maximum UDP packet size which can be assembled by the local network stack. =cut sub size { ## historical my ( $self, @value ) = @_; return $$self->edns->UDPsize(@value); } =head2 edns $header = $packet->header; $version = $header->edns->version; @options = $header->edns->options; $option = $header->edns->option(n); $udp_max = $packet->edns->UDPsize; Auxiliary function which provides access to the EDNS protocol extension OPT RR. =cut sub edns { my $self = shift; return $$self->edns; } ######################################## sub _dnsflag { my ( $self, $flag, @value ) = @_; for ( $$self->{status} ) { my $set = $_ | $flag; $_ = ( shift @value ) ? $set : ( $set ^ $flag ) if @value; $flag &= $_; } return $flag ? 1 : 0; } sub _ednsflag { my ( $self, $flag, @value ) = @_; my $edns = $$self->edns; for ( $edns->flags ) { my $set = $_ | $flag; $edns->flags( $_ = ( shift @value ) ? $set : ( $set ^ $flag ) ) if @value; $flag &= $_; } return $flag ? 1 : 0; } my %warned; sub _warn { my ( undef, @note ) = @_; return carp "usage; @note" unless $warned{"@note"}++; } 1; __END__ ######################################## =head1 COPYRIGHT Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2012,2022 Dick Franks. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L =cut DNS/Packet.pm000044400000053647152345050350006754 0ustar00package Net::DNS::Packet; use strict; use warnings; our $VERSION = (qw$Id: Packet.pm 2003 2025-01-21 12:06:06Z willem $)[2]; =head1 NAME Net::DNS::Packet - DNS protocol packet =head1 SYNOPSIS use Net::DNS::Packet; $query = Net::DNS::Packet->new( 'example.com', 'MX', 'IN' ); $reply = $resolver->send( $query ); =head1 DESCRIPTION A Net::DNS::Packet object represents a DNS protocol packet. =cut use integer; use Carp; use Net::DNS::Parameters qw(:dsotype); use constant UDPSZ => 512; BEGIN { require Net::DNS::Header; require Net::DNS::Question; require Net::DNS::RR; } =head1 METHODS =head2 new $packet = Net::DNS::Packet->new( 'example.com' ); $packet = Net::DNS::Packet->new( 'example.com', 'MX', 'IN' ); $packet = Net::DNS::Packet->new(); If passed a domain, type, and class, new() creates a Net::DNS::Packet object which is suitable for making a DNS query for the specified information. The type and class may be omitted; they default to A and IN. If called with an empty argument list, new() creates an empty packet. =cut sub new { my ( $class, @arg ) = @_; return &decode if ref $arg[0]; my $self = bless { status => 0, question => [], answer => [], authority => [], additional => [], }, $class; $self->{question} = [Net::DNS::Question->new(@arg)] if scalar @arg; return $self; } =head2 decode $packet = Net::DNS::Packet->decode( \$data ); $packet = Net::DNS::Packet->decode( \$data, 1 ); # debug $packet = Net::DNS::Packet->new( \$data ... ); A new packet object is created by decoding the DNS packet data contained in the scalar referenced by the first argument. The optional second boolean argument enables debugging output. Returns undef if unable to create a packet object. Decoding errors, including data corruption and truncation, are collected in the $@ ($EVAL_ERROR) variable. ( $packet, $length ) = Net::DNS::Packet->decode( \$data ); If called in array context, returns a packet object and the number of octets successfully decoded. Note that the number of RRs in each section of the packet may differ from the corresponding header value if the data has been truncated or corrupted during transmission. =cut use constant HEADER_LENGTH => length pack 'n6', (0) x 6; sub decode { my $class = shift; my $data = shift; my $debug = shift || 0; my $offset = 0; my $self; eval { local $SIG{__DIE__}; my $length = length $$data; die 'corrupt wire-format data' if $length < HEADER_LENGTH; # header section my ( $id, $status, @count ) = unpack 'n6', $$data; my ( $qd, $an, $ns, $ar ) = @count; $self = bless { id => $id, status => $status, count => [@count], question => [], answer => [], authority => [], additional => [], replysize => $length }, $class; # question/zone section my $hash = {}; my $record; $offset = HEADER_LENGTH; while ( $qd-- ) { ( $record, $offset ) = Net::DNS::Question->decode( $data, $offset, $hash ); CORE::push( @{$self->{question}}, $record ); } # RR sections while ( $an-- ) { ( $record, $offset ) = Net::DNS::RR->decode( $data, $offset, $hash ); CORE::push( @{$self->{answer}}, $record ); } while ( $ns-- ) { ( $record, $offset ) = Net::DNS::RR->decode( $data, $offset, $hash ); CORE::push( @{$self->{authority}}, $record ); } while ( $ar-- ) { ( $record, $offset ) = Net::DNS::RR->decode( $data, $offset, $hash ); CORE::push( @{$self->{additional}}, $record ); } return unless $offset == HEADER_LENGTH; return unless $self->header->opcode eq 'DSO'; $self->{dso} = []; my $limit = $length - 4; while ( $offset < $limit ) { my ( $t, $l, $v ) = unpack "\@$offset n2a*", $$data; CORE::push( @{$self->{dso}}, [$t, substr( $v, 0, $l )] ); $offset += ( $l + 4 ); } }; if ($debug) { local $@ = $@; print $@ if $@; eval { $self->print }; } return wantarray ? ( $self, $offset ) : $self; } =head2 encode $data = $packet->encode; $data = $packet->encode( $size ); Returns the packet data in binary format, suitable for sending as a query or update request to a nameserver. Truncation may be specified using a non-zero optional size argument. =cut sub data { return &encode; # uncoverable pod } sub encode { my ( $self, $size ) = @_; my $edns = $self->edns; # EDNS support my @addl = grep { !$_->isa('Net::DNS::RR::OPT') } @{$self->{additional}}; $self->{additional} = [$edns, @addl] if $edns->_specified; return $self->truncate($size) if $size; my @part = qw(question answer authority additional); my @size = map { scalar @{$self->{$_}} } @part; my $data = pack 'n6', $self->_quid, $self->{status}, @size; $self->{count} = []; my $hash = {}; # packet body foreach my $component ( map { @{$self->{$_}} } @part ) { $data .= $component->encode( length $data, $hash, $self ); } return $data; } =head2 header $header = $packet->header; Constructor method which returns a Net::DNS::Header object which represents the header section of the packet. =cut sub header { my $self = shift; return bless \$self, q(Net::DNS::Header); } =head2 edns $version = $packet->edns->version; $UDPsize = $packet->edns->size; Auxiliary function which provides access to the EDNS protocol extension OPT RR. =cut sub edns { my $self = shift; my $link = \$self->{xedns}; ($$link) = grep { $_->isa(qw(Net::DNS::RR::OPT)) } @{$self->{additional}} unless $$link; $$link = Net::DNS::RR->new( type => 'OPT' ) unless $$link; return $$link; } =head2 reply $reply = $query->reply( $UDPmax ); Constructor method which returns a new reply packet. The optional UDPsize argument is the maximum UDP packet size which can be reassembled by the local network stack, and is advertised in response to an EDNS query. =cut sub reply { my ( $query, @UDPmax ) = @_; my $qheadr = $query->header; croak 'erroneous qr flag in query packet' if $qheadr->qr; my $reply = Net::DNS::Packet->new(); my $header = $reply->header; $header->qr(1); # reply with same id, opcode and question $header->id( $qheadr->id ); $header->opcode( $qheadr->opcode ); my @question = $query->question; $reply->{question} = [@question]; $header->rcode('FORMERR'); # no RCODE considered sinful! $header->rd( $qheadr->rd ); # copy these flags into reply $header->cd( $qheadr->cd ); return $reply unless grep { $_->isa('Net::DNS::RR::OPT') } @{$query->{additional}}; my $edns = $reply->edns(); CORE::push( @{$reply->{additional}}, $edns ); $edns->udpsize(@UDPmax); return $reply; } =head2 question, zone @question = $packet->question; Returns a list of Net::DNS::Question objects representing the question section of the packet. In dynamic update packets, this section is known as zone() and specifies the DNS zone to be updated. =cut sub question { my @qr = @{shift->{question}}; return @qr; } sub zone { return &question } =head2 answer, pre, prerequisite @answer = $packet->answer; Returns a list of Net::DNS::RR objects representing the answer section of the packet. In dynamic update packets, this section is known as pre() or prerequisite() and specifies the RRs or RRsets which must or must not preexist. =cut sub answer { my @rr = @{shift->{answer}}; return @rr; } sub pre { return &answer } sub prerequisite { return &answer } =head2 authority, update @authority = $packet->authority; Returns a list of Net::DNS::RR objects representing the authority section of the packet. In dynamic update packets, this section is known as update() and specifies the RRs or RRsets to be added or deleted. =cut sub authority { my @rr = @{shift->{authority}}; return @rr; } sub update { return &authority } =head2 additional @additional = $packet->additional; Returns a list of Net::DNS::RR objects representing the additional section of the packet. =cut sub additional { my @rr = @{shift->{additional}}; return @rr; } =head2 print $packet->print; Prints the entire packet to the currently selected output filehandle using the master file format mandated by RFC1035. =cut sub print { print &string; return; } =head2 string print $packet->string; Returns a string representation of the packet. =cut sub string { my $self = shift; my $header = $self->header; my $opcode = $header->opcode; my $packet = $header->qr ? 'Response' : 'Query'; my $server = $self->{replyfrom}; my $length = $self->{replysize}; my $origin = $server ? ";; $packet received from [$server] $length octets\n" : ""; my @record = ( "$origin;; HEADER SECTION", $header->string ); if ( $opcode eq 'DSO' ) { CORE::push( @record, ";; DSO SECTION" ); foreach ( @{$self->{dso}} ) { my ( $t, $v ) = @$_; CORE::push( @record, sprintf( ";;\t%s\t%s", dsotypebyval($t), unpack( 'H*', $v ) ) ); } return join "\n", @record, "\n"; } my $edns = $self->edns; CORE::push( @record, $edns->string ) if $edns->_specified; my @section = $opcode eq 'UPDATE' ? qw(ZONE PREREQUISITE UPDATE) : qw(QUESTION ANSWER AUTHORITY); my @question = $self->question; my $qdcount = scalar @question; my $qds = $qdcount != 1 ? 's' : ''; CORE::push( @record, ";; $section[0] SECTION ($qdcount record$qds)", map { ';; ' . $_->string } @question ); my @answer = $self->answer; my $ancount = scalar @answer; my $ans = $ancount != 1 ? 's' : ''; CORE::push( @record, "\n;; $section[1] SECTION ($ancount record$ans)", map { $_->string } @answer ); my @authority = $self->authority; my $nscount = scalar @authority; my $nss = $nscount != 1 ? 's' : ''; CORE::push( @record, "\n;; $section[2] SECTION ($nscount record$nss)", map { $_->string } @authority ); my @additional = $self->additional; my $arcount = scalar @additional; my $ars = $arcount != 1 ? 's' : ''; my $EDNSmarker = join ' ', qq[;; {\t"EDNS-VERSION":], $edns->version, qq[}]; CORE::push( @record, "\n;; ADDITIONAL SECTION ($arcount record$ars)" ); CORE::push( @record, map { ( $_ eq $edns ) ? $EDNSmarker : $_->string } @additional ); return join "\n", @record, "\n"; } =head2 from print "packet received from ", $packet->from, "\n"; Returns the IP address from which this packet was received. This method will return undef for user-created packets. =cut sub from { my ( $self, @argument ) = @_; for (@argument) { $self->{replyfrom} = $_ } return $self->{replyfrom}; } sub answerfrom { return &from; } # uncoverable pod =head2 size print "packet size: ", $packet->size, " octets\n"; Returns the size of the packet in octets as it was received from a nameserver. This method will return undef for user-created packets (use length($packet->data) instead). =cut sub size { return shift->{replysize}; } sub answersize { return &size; } # uncoverable pod =head2 push $ancount = $packet->push( prereq => $rr ); $nscount = $packet->push( update => $rr ); $arcount = $packet->push( additional => $rr ); $nscount = $packet->push( update => $rr1, $rr2, $rr3 ); $nscount = $packet->push( update => @rr ); Adds RRs to the specified section of the packet. Returns the number of resource records in the specified section. Section names may be abbreviated to the first three characters. =cut sub push { my ( $self, $section, @rr ) = @_; my $list = $self->_section($section); return CORE::push( @$list, @rr ); } =head2 unique_push $ancount = $packet->unique_push( prereq => $rr ); $nscount = $packet->unique_push( update => $rr ); $arcount = $packet->unique_push( additional => $rr ); $nscount = $packet->unique_push( update => $rr1, $rr2, $rr3 ); $nscount = $packet->unique_push( update => @rr ); Adds RRs to the specified section of the packet provided that the RRs are not already present in the same section. Returns the number of resource records in the specified section. Section names may be abbreviated to the first three characters. =cut sub unique_push { my ( $self, $section, @rr ) = @_; my $list = $self->_section($section); my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list; return scalar( @$list = values %unique ); } =head2 pop my $rr = $packet->pop( 'pre' ); my $rr = $packet->pop( 'update' ); my $rr = $packet->pop( 'additional' ); Removes a single RR from the specified section of the packet. =cut sub pop { my $self = shift; my $list = $self->_section(shift); return CORE::pop(@$list); } my %_section = ( ## section name abbreviation table 'ans' => 'answer', 'pre' => 'answer', 'aut' => 'authority', 'upd' => 'authority', 'add' => 'additional' ); sub _section { ## returns array reference for section my $self = shift; my $name = shift; my $list = $_section{unpack 'a3', $name} || $name; return $self->{$list} ||= []; } =head2 sign_tsig $query = Net::DNS::Packet->new( 'www.example.com', 'A' ); $query->sign_tsig( $keyfile, fudge => 60 ); $reply = $res->send( $query ); $reply->verify( $query ) || die $reply->verifyerr; Attaches a TSIG resource record object, which will be used to sign the packet (see RFC 2845). The TSIG record can be customised by optional additional arguments to sign_tsig() or by calling the appropriate Net::DNS::RR::TSIG methods. If you wish to create a TSIG record using a non-standard algorithm, you will have to create it yourself. In all cases, the TSIG name must uniquely identify the key shared between the parties, and the algorithm name must identify the signing function to be used with the specified key. $tsig = Net::DNS::RR->new( name => 'tsig.example', type => 'TSIG', algorithm => 'custom-algorithm', key => '', sig_function => sub { my ($key, $data) = @_; ... } ); $query->sign_tsig( $tsig ); The response to an inbound request is signed by presenting the request in place of the key parameter. $response = $request->reply; $response->sign_tsig( $request, @options ); Multi-packet transactions are signed by chaining the sign_tsig() calls together as follows: $opaque = $packet1->sign_tsig( 'Kexample.+165+13281.private' ); $opaque = $packet2->sign_tsig( $opaque ); $opaque = $packet3->sign_tsig( $opaque ); The opaque intermediate object references returned during multi-packet signing are not intended to be accessed by the end-user application. Any such access is expressly forbidden. Note that a TSIG record is added to every packet; this implementation does not support the suppressed signature scheme described in RFC2845. =cut sub sign_tsig { my ( $self, @argument ) = @_; return eval { local $SIG{__DIE__}; require Net::DNS::RR::TSIG; my $tsig = Net::DNS::RR::TSIG->create(@argument); $self->push( 'additional' => $tsig ); return $tsig; } || return croak "$@\nTSIG: unable to sign packet"; } =head2 verify and verifyerr $reply->verify($query) || die $reply->verifyerr; Verify TSIG signature of a reply to the corresponding query. $opaque = $packet1->verify( $query ) || die $packet1->verifyerr; $opaque = $packet2->verify( $opaque ); $verifed = $packet3->verify( $opaque ) || die $packet3->verifyerr; Verify TSIG signature of a multi-packet reply to the corresponding query. The opaque intermediate object references returned by verify() at each stage will be undefined (Boolean false) if verification fails. Testing at every stage is not necessary, which produces a BADSIG error on the final packet in the absence of more specific information. Access to the objects themselves, if they exist, is expressly forbidden. =cut sub verify { my ( $self, @argument ) = @_; my $sig = $self->sigrr; return $sig ? $sig->verify( $self, @argument ) : shift @argument; } sub verifyerr { my $sig = shift->sigrr; return $sig ? $sig->vrfyerrstr : 'not signed'; } =head2 sign_sig0 SIG0 support is provided through the Net::DNS::RR::SIG class. The requisite cryptographic components are not integrated into Net::DNS but reside in the Net::DNS::SEC distribution available from CPAN. $update = Net::DNS::Update->new('example.com'); $update->push( update => rr_add('foo.example.com A 10.1.2.3')); $update->sign_sig0('Kexample.com+003+25317.private'); Execution will be terminated if Net::DNS::SEC is not available. =head2 verify SIG0 $packet->verify( $keyrr ) || die $packet->verifyerr; $packet->verify( [$keyrr, ...] ) || die $packet->verifyerr; Verify SIG0 packet signature against one or more specified KEY RRs. =cut sub sign_sig0 { my $self = shift; my $karg = shift; return eval { local $SIG{__DIE__}; my $sig0; if ( ref($karg) eq 'Net::DNS::RR::SIG' ) { $sig0 = $karg; } else { require Net::DNS::RR::SIG; $sig0 = Net::DNS::RR::SIG->create( '', $karg ); } $self->push( 'additional' => $sig0 ); return $sig0; } || return croak "$@\nSIG0: unable to sign packet"; } =head2 sigrr $sigrr = $packet->sigrr() || die 'unsigned packet'; The sigrr method returns the signature RR from a signed packet or undefined if the signature is absent. =cut sub sigrr { my $self = shift; my ($sig) = reverse $self->additional; return unless $sig; for ( $sig->type ) { return $sig if /TSIG|SIG/; } return; } ######################################## =head2 truncate The truncate method takes a maximum length as argument and then tries to truncate the packet and set the TC bit according to the rules of RFC2181 Section 9. The smallest length limit that is honoured is 512 octets. =cut # From RFC2181: # # 9. The TC (truncated) header bit # # The TC bit should be set in responses only when an RRSet is required # as a part of the response, but could not be included in its entirety. # The TC bit should not be set merely because some extra information # could have been included, for which there was insufficient room. This # includes the results of additional section processing. In such cases # the entire RRSet that will not fit in the response should be omitted, # and the reply sent as is, with the TC bit clear. If the recipient of # the reply needs the omitted data, it can construct a query for that # data and send that separately. # # Where TC is set, the partial RRSet that would not completely fit may # be left in the response. When a DNS client receives a reply with TC # set, it should ignore that response, and query again, using a # mechanism, such as a TCP connection, that will permit larger replies. # Code developed from a contribution by Aaron Crane via rt.cpan.org 33547 sub truncate { my $self = shift; my $size = shift || UDPSZ; my $sigrr = $self->sigrr; $size = UDPSZ unless $size > UDPSZ; $size -= $sigrr->_size if $sigrr; my $data = pack 'x' x HEADER_LENGTH; # header placeholder $self->{count} = []; my $tc; my $hash = {}; foreach my $section ( map { $self->{$_} } qw(question answer authority) ) { my @list; foreach my $item (@$section) { my $component = $item->encode( length $data, $hash ); last if length($data) + length($component) > $size; last if $tc; $data .= $component; CORE::push @list, $item; } $tc++ if scalar(@list) < scalar(@$section); @$section = @list; } $self->header->tc(1) if $tc; # only set if truncated here my %rrset; my @order; foreach my $item ( grep { ref($_) ne ref($sigrr) } $self->additional ) { my $name = $item->{owner}->canonical; my $class = $item->{class} || 0; my $key = pack 'nna*', $class, $item->{type}, $name; CORE::push @order, $key unless $rrset{$key}; CORE::push @{$rrset{$key}}, $item; } my @list; foreach my $key (@order) { my $component = ''; my @item = @{$rrset{$key}}; foreach my $item (@item) { $component .= $item->encode( length $data, $hash ); } last if length($data) + length($component) > $size; $data .= $component; CORE::push @list, @item; } if ($sigrr) { $data .= $sigrr->encode( length $data, $hash, $self ); CORE::push @list, $sigrr; } $self->{'additional'} = \@list; my @part = qw(question answer authority additional); my @size = map { scalar @{$self->{$_}} } @part; return pack 'n6 a*', $self->_quid, $self->{status}, @size, substr( $data, HEADER_LENGTH ); } ######################################## sub dump { ## print internal data structure my @data = @_; # uncoverable pod require Data::Dumper; local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 3; local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; local $Data::Dumper::Useqq = $Data::Dumper::Useqq || 1; print Data::Dumper::Dumper(@data); return; } my ( $cache1, $cache2, $limit ); sub _quid { ## generate (short-term) unique query ID my $self = shift; my $id = $self->{id}; $cache1->{$id}++ if $id; # cache non-zero ID return $id if defined $id; ( $cache2, $cache1, $limit ) = ( $cache1, {0 => 1}, 50 ) unless $limit--; $id = int rand(0xffff); # two layer ID cache $id = int rand(0xffff) while $cache1->{$id}++ + exists( $cache2->{$id} ); return $self->{id} = $id; } 1; __END__ =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002-2004 Chris Reinhardt. Portions Copyright (c)2002-2009 Olaf Kolkman Portions Copyright (c)2007-2019 Dick Franks All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L L L L L L L L L L =cut DNS/Parameters.pm000044400000035770152345050350007645 0ustar00package Net::DNS::Parameters; ################################################ ## ## Domain Name System (DNS) Parameters ## (last updated 2024-12-10) ## ################################################ use strict; use warnings; our $VERSION = (qw$Id: Parameters.pm 2002 2025-01-07 09:57:46Z willem $)[2]; use integer; use Carp; use base qw(Exporter); our @EXPORT_OK = qw( classbyname classbyval %classbyname typebyname typebyval %typebyname opcodebyname opcodebyval rcodebyname rcodebyval ednsoptionbyname ednsoptionbyval dsotypebyname dsotypebyval ); our %EXPORT_TAGS = ( class => [qw(classbyname classbyval)], type => [qw(typebyname typebyval)], opcode => [qw(opcodebyname opcodebyval)], rcode => [qw(rcodebyname rcodebyval)], ednsoption => [qw(ednsoptionbyname ednsoptionbyval)], dsotype => [qw(dsotypebyname dsotypebyval)], ); # Registry: DNS CLASSes my @classbyname = ( IN => 1, # RFC1035 CH => 3, # Chaosnet HS => 4, # Hesiod NONE => 254, # RFC2136 ANY => 255, # RFC1035 ); our %classbyval = reverse( CLASS0 => 0, @classbyname ); push @classbyname, map { /^\d/ ? $_ : lc($_) } @classbyname; our %classbyname = ( '*' => 255, @classbyname ); # Registry: Resource Record (RR) TYPEs my @typebyname = ( A => 1, # RFC1035 NS => 2, # RFC1035 MD => 3, # RFC1035 MF => 4, # RFC1035 CNAME => 5, # RFC1035 SOA => 6, # RFC1035 MB => 7, # RFC1035 MG => 8, # RFC1035 MR => 9, # RFC1035 NULL => 10, # RFC1035 WKS => 11, # RFC1035 PTR => 12, # RFC1035 HINFO => 13, # RFC1035 MINFO => 14, # RFC1035 MX => 15, # RFC1035 TXT => 16, # RFC1035 RP => 17, # RFC1183 AFSDB => 18, # RFC1183 RFC5864 X25 => 19, # RFC1183 ISDN => 20, # RFC1183 RT => 21, # RFC1183 NSAP => 22, # RFC1706 https://datatracker.ietf.org/doc/status-change-int-tlds-to-historic 'NSAP-PTR' => 23, # RFC1706 https://datatracker.ietf.org/doc/status-change-int-tlds-to-historic SIG => 24, # RFC2536 RFC2931 RFC3110 RFC4034 KEY => 25, # RFC2536 RFC2539 RFC3110 RFC4034 PX => 26, # RFC2163 GPOS => 27, # RFC1712 AAAA => 28, # RFC3596 LOC => 29, # RFC1876 NXT => 30, # RFC2535 RFC3755 EID => 31, # http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt NIMLOC => 32, # http://ana-3.lcs.mit.edu/~jnc/nimrod/dns.txt SRV => 33, # RFC2782 ATMA => 34, # http://www.broadband-forum.org/ftp/pub/approved-specs/af-dans-0152.000.pdf NAPTR => 35, # RFC3403 KX => 36, # RFC2230 CERT => 37, # RFC4398 A6 => 38, # RFC2874 RFC3226 RFC6563 DNAME => 39, # RFC6672 SINK => 40, # draft-eastlake-kitchen-sink-02 OPT => 41, # RFC3225 RFC6891 APL => 42, # RFC3123 DS => 43, # RFC4034 SSHFP => 44, # RFC4255 IPSECKEY => 45, # RFC4025 RRSIG => 46, # RFC4034 NSEC => 47, # RFC4034 RFC9077 DNSKEY => 48, # RFC4034 DHCID => 49, # RFC4701 NSEC3 => 50, # RFC5155 RFC9077 NSEC3PARAM => 51, # RFC5155 TLSA => 52, # RFC6698 SMIMEA => 53, # RFC8162 HIP => 55, # RFC8005 NINFO => 56, # RKEY => 57, # TALINK => 58, # CDS => 59, # RFC7344 CDNSKEY => 60, # RFC7344 OPENPGPKEY => 61, # RFC7929 CSYNC => 62, # RFC7477 ZONEMD => 63, # RFC8976 SVCB => 64, # RFC9460 HTTPS => 65, # RFC9460 DSYNC => 66, # draft-ietf-dnsop-generalized-notify-03 SPF => 99, # RFC7208 UINFO => 100, # IANA-Reserved UID => 101, # IANA-Reserved GID => 102, # IANA-Reserved UNSPEC => 103, # IANA-Reserved NID => 104, # RFC6742 L32 => 105, # RFC6742 L64 => 106, # RFC6742 LP => 107, # RFC6742 EUI48 => 108, # RFC7043 EUI64 => 109, # RFC7043 NXNAME => 128, # draft-ietf-dnsop-compact-denial-of-existence-04 TKEY => 249, # RFC2930 TSIG => 250, # RFC8945 IXFR => 251, # RFC1995 AXFR => 252, # RFC1035 RFC5936 MAILB => 253, # RFC1035 MAILA => 254, # RFC1035 ANY => 255, # RFC1035 RFC6895 RFC8482 URI => 256, # RFC7553 CAA => 257, # RFC8659 AVC => 258, # DOA => 259, # draft-durand-doa-over-dns-02 AMTRELAY => 260, # RFC8777 RESINFO => 261, # RFC9606 WALLET => 262, # CLA => 263, # draft-johnson-dns-ipn-cla-07 IPN => 264, # draft-johnson-dns-ipn-cla-07 TA => 32768, # http://www.watson.org/~weiler/INI1999-19.pdf DLV => 32769, # RFC8749 RFC4431 ); our %typebyval = reverse( TYPE0 => 0, @typebyname ); push @typebyname, map { /^\d/ ? $_ : lc($_) } @typebyname; our %typebyname = ( '*' => 255, @typebyname ); # Registry: DNS OpCodes my @opcodebyname = ( QUERY => 0, # RFC1035 IQUERY => 1, # RFC3425 STATUS => 2, # RFC1035 NOTIFY => 4, # RFC1996 UPDATE => 5, # RFC2136 DSO => 6, # RFC8490 ); our %opcodebyval = reverse @opcodebyname; push @opcodebyname, map { /^\d/ ? $_ : lc($_) } @opcodebyname; our %opcodebyname = ( NS_NOTIFY_OP => 4, @opcodebyname ); # Registry: DNS RCODEs my @rcodebyname = ( NOERROR => 0, # RFC1035 FORMERR => 1, # RFC1035 SERVFAIL => 2, # RFC1035 NXDOMAIN => 3, # RFC1035 NOTIMP => 4, # RFC1035 REFUSED => 5, # RFC1035 YXDOMAIN => 6, # RFC2136 RFC6672 YXRRSET => 7, # RFC2136 NXRRSET => 8, # RFC2136 NOTAUTH => 9, # RFC2136 NOTAUTH => 9, # RFC8945 NOTZONE => 10, # RFC2136 DSOTYPENI => 11, # RFC8490 BADVERS => 16, # RFC6891 BADSIG => 16, # RFC8945 BADKEY => 17, # RFC8945 BADTIME => 18, # RFC8945 BADMODE => 19, # RFC2930 BADNAME => 20, # RFC2930 BADALG => 21, # RFC2930 BADTRUNC => 22, # RFC8945 BADCOOKIE => 23, # RFC7873 ); our %rcodebyval = reverse( BADSIG => 16, @rcodebyname ); push @rcodebyname, map { /^\d/ ? $_ : lc($_) } @rcodebyname; our %rcodebyname = @rcodebyname; # Registry: DNS EDNS0 Option Codes (OPT) my @ednsoptionbyname = ( LLQ => 1, # RFC8764 'UPDATE-LEASE' => 2, # RFC-ietf-dnssd-update-lease-08 NSID => 3, # RFC5001 DAU => 5, # RFC6975 DHU => 6, # RFC6975 N3U => 7, # RFC6975 'CLIENT-SUBNET' => 8, # RFC7871 EXPIRE => 9, # RFC7314 COOKIE => 10, # RFC7873 'TCP-KEEPALIVE' => 11, # RFC7828 PADDING => 12, # RFC7830 CHAIN => 13, # RFC7901 'KEY-TAG' => 14, # RFC8145 'EXTENDED-ERROR' => 15, # RFC8914 'CLIENT-TAG' => 16, # draft-bellis-dnsop-edns-tags-01 'SERVER-TAG' => 17, # draft-bellis-dnsop-edns-tags-01 'REPORT-CHANNEL' => 18, # RFC9567 ZONEVERSION => 19, # RFC9660 'UMBRELLA-IDENT' => 20292, # https://developer.cisco.com/docs/cloud-security/#!integrating-network-devic DEVICEID => 26946, # https://developer.cisco.com/docs/cloud-security/#!network-devices-getting-s ); our %ednsoptionbyval = reverse @ednsoptionbyname; push @ednsoptionbyname, map { /^\d/ ? $_ : lc($_) } @ednsoptionbyname; our %ednsoptionbyname = @ednsoptionbyname; # Registry: DNS Header Flags my @dnsflagbyname = ( AA => 0x0400, # RFC1035 TC => 0x0200, # RFC1035 RD => 0x0100, # RFC1035 RA => 0x0080, # RFC1035 AD => 0x0020, # RFC4035 RFC6840 CD => 0x0010, # RFC4035 RFC6840 ); push @dnsflagbyname, map { /^\d/ ? $_ : lc($_) } @dnsflagbyname; our %dnsflagbyname = @dnsflagbyname; # Registry: EDNS Header Flags (16 bits) my @ednsflagbyname = ( DO => 0x8000, # RFC4035 RFC3225 RFC6840 ); push @ednsflagbyname, map { /^\d/ ? $_ : lc($_) } @ednsflagbyname; our %ednsflagbyname = @ednsflagbyname; # Registry: DSO Type Codes my @dsotypebyname = ( KEEPALIVE => 0x0001, # RFC8490 RETRYDELAY => 0x0002, # RFC8490 ENCRYPTIONPADDING => 0x0003, # RFC8490 SUBSCRIBE => 0x0040, # RFC8765 PUSH => 0x0041, # RFC8765 UNSUBSCRIBE => 0x0042, # RFC8765 RECONFIRM => 0x0043, # RFC8765 ); our %dsotypebyval = reverse @dsotypebyname; push @dsotypebyname, map { /^\d/ ? $_ : lc($_) } @dsotypebyname; our %dsotypebyname = @dsotypebyname; # Registry: Extended DNS Error Codes my @dnserrorbyval = ( 0 => 'Other Error', # RFC8914 1 => 'Unsupported DNSKEY Algorithm', # RFC8914 2 => 'Unsupported DS Digest Type', # RFC8914 3 => 'Stale Answer', # RFC8914 RFC8767 4 => 'Forged Answer', # RFC8914 5 => 'DNSSEC Indeterminate', # RFC8914 6 => 'DNSSEC Bogus', # RFC8914 7 => 'Signature Expired', # RFC8914 8 => 'Signature Not Yet Valid', # RFC8914 9 => 'DNSKEY Missing', # RFC8914 10 => 'RRSIGs Missing', # RFC8914 11 => 'No Zone Key Bit Set', # RFC8914 12 => 'NSEC Missing', # RFC8914 13 => 'Cached Error', # RFC8914 14 => 'Not Ready', # RFC8914 15 => 'Blocked', # RFC8914 16 => 'Censored', # RFC8914 17 => 'Filtered', # RFC8914 18 => 'Prohibited', # RFC8914 19 => 'Stale NXDomain Answer', # RFC8914 20 => 'Not Authoritative', # RFC8914 21 => 'Not Supported', # RFC8914 22 => 'No Reachable Authority', # RFC8914 23 => 'Network Error', # RFC8914 24 => 'Invalid Data', # RFC8914 25 => 'Signature Expired before Valid', # https://github.com/NLnetLabs/unbound/pull/604#discussion_r802678343 26 => 'Too Early', # RFC9250 27 => 'Unsupported NSEC3 Iterations Value', # RFC9276 28 => 'Unable to conform to policy', # draft-homburg-dnsop-codcp-00 29 => 'Synthesized', # https://github.com/PowerDNS/pdns/pull/12334 30 => 'Invalid Query Type', # draft-ietf-dnsop-compact-denial-of-existence-04 ); our %dnserrorbyval = @dnserrorbyval; ######## # The following functions are wrappers around similarly named hashes. sub classbyname { my $name = shift; return $classbyname{$name} || $classbyname{uc $name} || return do { croak qq[unknown class "$name"] unless $name =~ m/^(CLASS)?(\d+)/i; my $val = 0 + $2; croak qq[classbyname("$name") out of range] if $val > 0x7fff; return $val; } } sub classbyval { my $arg = shift; return $classbyval{$arg} || return do { my $val = ( $arg += 0 ) & 0x7fff; # MSB used by mDNS croak qq[classbyval($arg) out of range] if $arg > 0xffff; return $classbyval{$arg} = $classbyval{$val} || "CLASS$val"; } } sub typebyname { my $name = shift; return $typebyname{$name} || return do { if ( $name =~ m/^(TYPE)?(\d+)/i ) { my $val = 0 + $2; croak qq[typebyname("$name") out of range] if $val > 0xffff; return $val; } _typespec("$name.RRNAME") unless $typebyname{uc $name}; return $typebyname{uc $name} || croak qq[unknown type "$name"]; } } sub typebyval { my $val = shift; return $typebyval{$val} || return do { $val += 0; croak qq[typebyval($val) out of range] if $val > 0xffff; $typebyval{$val} = "TYPE$val"; _typespec("$val.RRTYPE"); return $typebyval{$val}; } } sub opcodebyname { my $arg = shift; my $val = $opcodebyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown opcode "$arg"]; } sub opcodebyval { my $val = shift; return $opcodebyval{$val} || return "$val"; } sub rcodebyname { my $arg = shift; my $val = $rcodebyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown rcode "$arg"]; } sub rcodebyval { my $val = shift; return $rcodebyval{$val} || return "$val"; } sub ednsoptionbyname { my $arg = shift; my $val = $ednsoptionbyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown option "$arg"]; } sub ednsoptionbyval { my $val = shift; return $ednsoptionbyval{$val} || return "$val"; } sub dsotypebyname { my $arg = shift; my $val = $dsotypebyname{$arg}; return $val if defined $val; return $arg if $arg =~ /^\d/; croak qq[unknown DSO type "$arg"]; } sub dsotypebyval { my $val = shift; return $dsotypebyval{$val} || return "$val"; } use constant EXTLANG => defined eval { require Net::DNS::Extlang }; sub _typespec { my $generate = defined wantarray; return EXTLANG ? eval <<'END' : ''; ## no critic my ($node) = @_; ## draft-levine-dnsextlang my $instance = Net::DNS::Extlang->new(); my $basename = $instance->domain || return ''; require Net::DNS::Resolver; my $resolver = Net::DNS::Resolver->new(); my $response = $resolver->send( "$node.$basename", 'TXT' ) || return ''; foreach my $txt ( grep { $_->type eq 'TXT' } $response->answer ) { my @stanza = $txt->txtdata; my ( $tag, $identifier, @attribute ) = @stanza; next unless defined($tag) && $tag =~ /^RRTYPE=\d+$/; if ( $identifier =~ /^(\w+):(\d+)\W*/ ) { my ( $mnemonic, $rrtype ) = ( uc($1), $2 ); croak qq["$mnemonic" is a CLASS identifier] if $classbyname{$mnemonic}; for ( typebyval($rrtype) ) { next if /^$mnemonic$/i; # duplicate registration croak qq["$mnemonic" conflicts with TYPE$rrtype ($_)] unless /^TYPE\d+$/; my $known = $typebyname{$mnemonic}; croak qq["$mnemonic" conflicts with TYPE$known] if $known; $typebyval{$rrtype} = $mnemonic; $typebyname{$mnemonic} = $rrtype; } } return unless $generate; my $recipe = $instance->xlstorerecord( $identifier, @attribute ); return $instance->compilerr($recipe); } END } 1; __END__ =head1 NAME Net::DNS::Parameters - DNS parameter assignments =head1 SYNOPSIS use Net::DNS::Parameters; =head1 DESCRIPTION Net::DNS::Parameters is a Perl package representing the DNS parameter allocation (key,value) tables as recorded in the definitive registry maintained and published by IANA. =head1 FUNCTIONS =head2 classbyname, typebyname, opcodebyname, rcodebyname, ednsoptionbyname, dsotypebyname Access functions which return the numerical code corresponding to the given mnemonic. =head2 classbyval, typebyval, opcodebyval, rcodebyval, ednsoptionbyval, dsotypebyval Access functions which return the canonical mnemonic corresponding to the given numerical code. =head1 COPYRIGHT Copyright (c)2012,2016 Dick Franks. Portions Copyright (c)1997 Michael Fuhr. Portions Copyright (c)2003 Olaf Kolkman. All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 SEE ALSO L, L, L =cut IDN/Punycode.xs000044400000015404152345050350007324 0ustar00#include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef XS_VERSION #undef XS_VERSION #endif #define XS_VERSION "2.500" #define BASE 36 #define TMIN 1 #define TMAX 26 #define SKEW 38 #define DAMP 700 #define INITIAL_BIAS 72 #define INITIAL_N 128 #define isBASE(x) UTF8_IS_INVARIANT((unsigned char)x) #define DELIM '-' #define TMIN_MAX(t) (((t) < TMIN) ? (TMIN) : ((t) > TMAX) ? (TMAX) : (t)) #ifndef utf8_to_uvchr_buf #define utf8_to_uvchr_buf(in_p,in_e,u8) utf8_to_uvchr(in_p,u8); #endif static char enc_digit[BASE] = { 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', }; static IV dec_digit[0x80] = { -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 00..0F */ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 10..1F */ -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, /* 20..2F */ 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, -1, -1, -1, -1, -1, -1, /* 30..3F */ -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 40..4F */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, -1, -1, -1, -1, -1, /* 50..5F */ -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, /* 60..6F */ 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, -1, -1, -1, -1, -1, /* 70..7F */ }; static int adapt(int delta, int numpoints, int first) { int k; delta /= first ? DAMP : 2; delta += delta/numpoints; for(k=0; delta > ((BASE-TMIN) * TMAX)/2; k += BASE) delta /= BASE-TMIN; return k + (((BASE-TMIN+1) * delta) / (delta+SKEW)); }; static void grow_string(SV *const sv, char **start, char **current, char **end, STRLEN add) { STRLEN len; if(*current + add <= *end) return; len = (*current - *start); *start = SvGROW(sv, (len + add + 15) & ~15); *current = *start + len; *end = *start + SvLEN(sv); } MODULE = Net::IDN::Punycode PACKAGE = Net::IDN::Punycode SV* encode_punycode(input) SV * input PREINIT: UV c, m, n = INITIAL_N; int k, q, t; int bias = INITIAL_BIAS; int delta = 0, skip_delta; const char *in_s, *in_p, *in_e, *skip_p; char *re_s, *re_p, *re_e; int first = 1; STRLEN length_guess, len, h, u8; CODE: in_s = in_p = SvPVutf8(input, len); in_e = in_s + len; length_guess = len; if(length_guess < 64) length_guess = 64; /* optimise for maximum length of domain names */ length_guess += 2; /* plus DELIM + '\0' */ RETVAL = NEWSV('P',length_guess); SvPOK_only(RETVAL); re_s = re_p = SvPV_nolen(RETVAL); re_e = re_s + SvLEN(RETVAL); h = 0; /* copy basic code points */ while(in_p < in_e) { if( isBASE(*in_p) ) { grow_string(RETVAL, &re_s, &re_p, &re_e, sizeof(char)); *re_p++ = *in_p; h++; } in_p++; } /* add DELIM if needed */ if(h) { grow_string(RETVAL, &re_s, &re_p, &re_e, sizeof(char)); *re_p++ = DELIM; } for(;;) { /* find smallest code point not yet handled */ m = UV_MAX; q = skip_delta = 0; for(in_p = skip_p = in_s; in_p < in_e;) { c = utf8_to_uvchr_buf((U8*)in_p, (U8*)in_e, &u8); c = NATIVE_TO_UNI(c); if(c >= n && c < m) { m = c; skip_p = in_p; skip_delta = q; } if(c < n) ++q; in_p += u8; } if(m == UV_MAX) break; /* increase delta to the state corresponding to the m code point at the beginning of the string */ delta += (m-n) * (h+1); n = m; /* now find the chars to be encoded in this round */ delta += skip_delta; for(in_p = skip_p; in_p < in_e;) { c = utf8_to_uvchr_buf((U8*)in_p, (U8*)in_e, &u8); c = NATIVE_TO_UNI(c); if(c < n) { ++delta; } else if( c == n ) { q = delta; for(k = BASE;; k += BASE) { t = TMIN_MAX(k - bias); if(q < t) break; grow_string(RETVAL, &re_s, &re_p, &re_e, sizeof(char)); *re_p++ = enc_digit[t + ((q-t) % (BASE-t))]; q = (q-t) / (BASE-t); } if(q > BASE) croak("input exceeds punycode limit"); grow_string(RETVAL, &re_s, &re_p, &re_e, sizeof(char)); *re_p++ = enc_digit[q]; bias = adapt(delta, h+1, first); delta = first = 0; ++h; } in_p += u8; } ++delta; ++n; } grow_string(RETVAL, &re_s, &re_p, &re_e, sizeof(char)); *re_p = 0; SvCUR_set(RETVAL, re_p - re_s); OUTPUT: RETVAL SV* decode_punycode(input) SV * input PREINIT: UV c, n = INITIAL_N; IV dc; int i = 0, oldi, j, k, t, w; int bias = INITIAL_BIAS; int delta = 0, skip_delta; const char *in_s, *in_p, *in_e, *skip_p; char *re_s, *re_p, *re_e; int first = 1; STRLEN length_guess, len, h, u8; CODE: in_s = in_p = SvPV_nolen(input); in_e = SvEND(input); length_guess = SvCUR(input) * 2; if(length_guess < 256) length_guess = 256; RETVAL = NEWSV('D',length_guess); SvPOK_only(RETVAL); re_s = re_p = SvPV_nolen(RETVAL); re_e = re_s + SvLEN(RETVAL); skip_p = NULL; for(in_p = in_s; in_p < in_e; in_p++) { c = *in_p; /* we don't care whether it's UTF-8 */ if(!isBASE(c)) croak("non-base character in input for decode_punycode"); if(c == DELIM) skip_p = in_p; grow_string(RETVAL, &re_s, &re_p, &re_e, 1); *re_p++ = c; /* copy it */ } if(skip_p) { h = skip_p - in_s; /* base chars handled */ re_p = re_s + h; /* points to end of base chars */ skip_p++; /* skip over DELIM */ } else { h = 0; /* no base chars */ re_p = re_s; skip_p = in_s; /* read everything */ } for(in_p = skip_p; in_p < in_e; i++) { oldi = i; w = 1; for(k = BASE;; k+= BASE) { if(!(in_p < in_e)) croak("incomplete encoded code point in decode_punycode"); dc = dec_digit[*in_p++]; /* we already know it's in 0..127 */ if(dc < 0) croak("invalid digit in input for decode_punycode"); c = (UV)dc; i += c * w; t = TMIN_MAX(k - bias); if(c < t) break; w *= BASE-t; } h++; bias = adapt(i-oldi, h, first); first = 0; n += i / h; /* code point n to insert */ i = i % h; /* at position i */ u8 = UNISKIP(n); /* how many bytes we need */ j = i; for(skip_p = re_s; j > 0; j--) /* find position in UTF-8 */ skip_p+=UTF8SKIP(skip_p); grow_string(RETVAL, &re_s, &re_p, &re_e, u8); if(skip_p < re_p) /* move succeeding chars */ Move(skip_p, skip_p + u8, re_p - skip_p, char); re_p += u8; uvuni_to_utf8_flags((U8*)skip_p, n, UNICODE_ALLOW_ANY); } if(!first) SvUTF8_on(RETVAL); /* UTF-8 chars have been inserted */ grow_string(RETVAL, &re_s, &re_p, &re_e, 1); *re_p = 0; SvCUR_set(RETVAL, re_p - re_s); OUTPUT: RETVAL IDN/Standards.pod000055500000007034152345050350007614 0ustar00=encoding utf8 =head1 NAME Net::IDN::Standards -- Internationalized Domain Names for Applications (IDNA) =head1 INTRODUCTION Historically, domain names and host names were restricted to a limited repertoire of ASCII characters, i.e. letters, digits and the hyphen (i.e. C). Words and names from languages that require additional characters (such as diacritics or special characters) or other scripts could not be used. Internationalized Domain Names (IDNs) extend the character repertoire for domain names from ASCII to Unicode while maintaining backwards compatibility with software that only expects and handles ASCII characters. In order to do so, Unicode domain names are converted to ASCII using an ASCII-compatible encoding (ACE) called Punycode. On the wire, converted domain names start with C, followed by the ASCII encoding of the Unicode string. The Unicode version is typically only shown in applications presenting the domain to the user (hence Internationalized Domain Names for Applications, IDNA). Internationalized Resource Identifiers (IRIs), the Unicode version of URLs, may also include domain names in their Unicode form. The IDNA specifications, however, do not only cover the actual Punycode conversion but also include extensive rules for preparation (mapping and/or validation) of input strings. They typically define two functions, C and C, which prepare and convert a domain name to the ACE version or the Unicode version. =head1 DIFFERENT STANDARDS "The nice thing about standards is that you have so many to choose from." -- Andrew S. Tanenbaum While the actual Punycode conversion is stable, there are different specifications regarding mapping and/or validation (preparation): =head2 IDNA2003 IDNA2003, which is defined in S (L) and related documents, was the original specification for the internationalization of domain names. However, some issues were subsequently identified with IDNA2003: The specification was tied to Unicode 3.2 and therefore did not allow characters added in newer versions of Unicode (without updating the specifications). Furthermore, a few characters were mapped to other characters or deleted although they would carry meaning in some languages (i.e. 'ß' and 'ς' were mapped to 'ss' and 'σ'; ZWJ and ZWNJ were always mapped to nothing, although some scripts like Arabic require them for correct display). =head2 IDNA2008 IDNA2008, which is defined in S (L) and related documents, resolves the issues found in IDNA2003. This was done by allowing some characters that would either be mapped to other characters, mapped to zero and/or cause the preparation to fail. The new domain names would not be accessible by IDNA2003 implementations, of course. However, IDNA2008 also disallowed a large number of characters that had been allowed in IDNA2003 (mostly symbols). An implementation of IDNA2008 would therefore no longer be able to access domain names such as C<√.com>, which had been registered under IDNA2003. =head2 UTS #46 Unicode Technical Standard #46 (UTS #46, L) solves this problem by allowing domain names that are valid in either IDNA2003 or IDNA2008. This makes UTS #46 the perfect fit for domain lookup (be liberal in what you accept) but unsuitable for validating domain names prior to registration (be conservative in what you send). =head1 AUTHOR Claus FErber =cut IDN/UTS46/_Mapping.pm000044400000577146152345050350010117 0ustar00# *** DO NOT EDIT *** generated file *** DO NOT EDIT *** # # generated by lib/Net/IDN/UTS46/_Mapping.PL from IdnaMappingTable.txt # see repository at http://github.com/cfaerber/Net-IDN-Encode for source files # package Net::IDN::UTS46::_Mapping; require 5.006; use strict; use utf8; use warnings; our $VERSION = 10.000_000_000; our $UNICODE_VERSION = 10.000_000; our $UNICODE_DATE = "20170223"; our @ISA = qw(Exporter); our @EXPORT = (); our @EXPORT_OK = qw(IsDeviation IsDisallowed IsDisallowedSTD3Mapped IsDisallowedSTD3Valid IsIgnored IsMapped IsValid Is_DisallowedAssigned MapDeviation MapDisallowedSTD3Mapped MapIgnored MapMapped); sub _mk_prop { my @ll; while( my(@c) = splice(@_,0,2) ) { push @ll, join ' ', map { sprintf "%04X", $_ } grep { defined $_ } @c; } return join "\n", @ll; } 1; our @DISALLOWED = ( 0x0080, 0x009F, 0x0378, 0x0379, 0x0380, 0x0383, 0x038B, undef, 0x038D, undef, 0x03A2, undef, 0x04C0, undef, 0x0530, undef, 0x0557, 0x0558, 0x0560, undef, 0x0588, undef, 0x058B, 0x058C, 0x0590, undef, 0x05C8, 0x05CF, 0x05EB, 0x05EF, 0x05F5, 0x0605, 0x061C, 0x061D, 0x06DD, undef, 0x070E, 0x070F, 0x074B, 0x074C, 0x07B2, 0x07BF, 0x07FB, 0x07FF, 0x082E, 0x082F, 0x083F, undef, 0x085C, 0x085D, 0x085F, undef, 0x086B, 0x089F, 0x08B5, undef, 0x08BE, 0x08D3, 0x08E2, undef, 0x0984, undef, 0x098D, 0x098E, 0x0991, 0x0992, 0x09A9, undef, 0x09B1, undef, 0x09B3, 0x09B5, 0x09BA, 0x09BB, 0x09C5, 0x09C6, 0x09C9, 0x09CA, 0x09CF, 0x09D6, 0x09D8, 0x09DB, 0x09DE, undef, 0x09E4, 0x09E5, 0x09FE, 0x0A00, 0x0A04, undef, 0x0A0B, 0x0A0E, 0x0A11, 0x0A12, 0x0A29, undef, 0x0A31, undef, 0x0A34, undef, 0x0A37, undef, 0x0A3A, 0x0A3B, 0x0A3D, undef, 0x0A43, 0x0A46, 0x0A49, 0x0A4A, 0x0A4E, 0x0A50, 0x0A52, 0x0A58, 0x0A5D, undef, 0x0A5F, 0x0A65, 0x0A76, 0x0A80, 0x0A84, undef, 0x0A8E, undef, 0x0A92, undef, 0x0AA9, undef, 0x0AB1, undef, 0x0AB4, undef, 0x0ABA, 0x0ABB, 0x0AC6, undef, 0x0ACA, undef, 0x0ACE, 0x0ACF, 0x0AD1, 0x0ADF, 0x0AE4, 0x0AE5, 0x0AF2, 0x0AF8, 0x0B00, undef, 0x0B04, undef, 0x0B0D, 0x0B0E, 0x0B11, 0x0B12, 0x0B29, undef, 0x0B31, undef, 0x0B34, undef, 0x0B3A, 0x0B3B, 0x0B45, 0x0B46, 0x0B49, 0x0B4A, 0x0B4E, 0x0B55, 0x0B58, 0x0B5B, 0x0B5E, undef, 0x0B64, 0x0B65, 0x0B78, 0x0B81, 0x0B84, undef, 0x0B8B, 0x0B8D, 0x0B91, undef, 0x0B96, 0x0B98, 0x0B9B, undef, 0x0B9D, undef, 0x0BA0, 0x0BA2, 0x0BA5, 0x0BA7, 0x0BAB, 0x0BAD, 0x0BBA, 0x0BBD, 0x0BC3, 0x0BC5, 0x0BC9, undef, 0x0BCE, 0x0BCF, 0x0BD1, 0x0BD6, 0x0BD8, 0x0BE5, 0x0BFB, 0x0BFF, 0x0C04, undef, 0x0C0D, undef, 0x0C11, undef, 0x0C29, undef, 0x0C3A, 0x0C3C, 0x0C45, undef, 0x0C49, undef, 0x0C4E, 0x0C54, 0x0C57, undef, 0x0C5B, 0x0C5F, 0x0C64, 0x0C65, 0x0C70, 0x0C77, 0x0C84, undef, 0x0C8D, undef, 0x0C91, undef, 0x0CA9, undef, 0x0CB4, undef, 0x0CBA, 0x0CBB, 0x0CC5, undef, 0x0CC9, undef, 0x0CCE, 0x0CD4, 0x0CD7, 0x0CDD, 0x0CDF, undef, 0x0CE4, 0x0CE5, 0x0CF0, undef, 0x0CF3, 0x0CFF, 0x0D04, undef, 0x0D0D, undef, 0x0D11, undef, 0x0D45, undef, 0x0D49, undef, 0x0D50, 0x0D53, 0x0D64, 0x0D65, 0x0D80, 0x0D81, 0x0D84, undef, 0x0D97, 0x0D99, 0x0DB2, undef, 0x0DBC, undef, 0x0DBE, 0x0DBF, 0x0DC7, 0x0DC9, 0x0DCB, 0x0DCE, 0x0DD5, undef, 0x0DD7, undef, 0x0DE0, 0x0DE5, 0x0DF0, 0x0DF1, 0x0DF5, 0x0E00, 0x0E3B, 0x0E3E, 0x0E5C, 0x0E80, 0x0E83, undef, 0x0E85, 0x0E86, 0x0E89, undef, 0x0E8B, 0x0E8C, 0x0E8E, 0x0E93, 0x0E98, undef, 0x0EA0, undef, 0x0EA4, undef, 0x0EA6, undef, 0x0EA8, 0x0EA9, 0x0EAC, undef, 0x0EBA, undef, 0x0EBE, 0x0EBF, 0x0EC5, undef, 0x0EC7, undef, 0x0ECE, 0x0ECF, 0x0EDA, 0x0EDB, 0x0EE0, 0x0EFF, 0x0F48, undef, 0x0F6D, 0x0F70, 0x0F98, undef, 0x0FBD, undef, 0x0FCD, undef, 0x0FDB, 0x0FFF, 0x10A0, 0x10C6, 0x10C8, 0x10CC, 0x10CE, 0x10CF, 0x115F, 0x1160, 0x1249, undef, 0x124E, 0x124F, 0x1257, undef, 0x1259, undef, 0x125E, 0x125F, 0x1289, undef, 0x128E, 0x128F, 0x12B1, undef, 0x12B6, 0x12B7, 0x12BF, undef, 0x12C1, undef, 0x12C6, 0x12C7, 0x12D7, undef, 0x1311, undef, 0x1316, 0x1317, 0x135B, 0x135C, 0x137D, 0x137F, 0x139A, 0x139F, 0x13F6, 0x13F7, 0x13FE, 0x13FF, 0x1680, undef, 0x169D, 0x169F, 0x16F9, 0x16FF, 0x170D, undef, 0x1715, 0x171F, 0x1737, 0x173F, 0x1754, 0x175F, 0x176D, undef, 0x1771, undef, 0x1774, 0x177F, 0x17B4, 0x17B5, 0x17DE, 0x17DF, 0x17EA, 0x17EF, 0x17FA, 0x17FF, 0x1806, undef, 0x180E, 0x180F, 0x181A, 0x181F, 0x1878, 0x187F, 0x18AB, 0x18AF, 0x18F6, 0x18FF, 0x191F, undef, 0x192C, 0x192F, 0x193C, 0x193F, 0x1941, 0x1943, 0x196E, 0x196F, 0x1975, 0x197F, 0x19AC, 0x19AF, 0x19CA, 0x19CF, 0x19DB, 0x19DD, 0x1A1C, 0x1A1D, 0x1A5F, undef, 0x1A7D, 0x1A7E, 0x1A8A, 0x1A8F, 0x1A9A, 0x1A9F, 0x1AAE, 0x1AAF, 0x1ABF, 0x1AFF, 0x1B4C, 0x1B4F, 0x1B7D, 0x1B7F, 0x1BF4, 0x1BFB, 0x1C38, 0x1C3A, 0x1C4A, 0x1C4C, 0x1C89, 0x1CBF, 0x1CC8, 0x1CCF, 0x1CFA, 0x1CFF, 0x1DFA, undef, 0x1F16, 0x1F17, 0x1F1E, 0x1F1F, 0x1F46, 0x1F47, 0x1F4E, 0x1F4F, 0x1F58, undef, 0x1F5A, undef, 0x1F5C, undef, 0x1F5E, undef, 0x1F7E, 0x1F7F, 0x1FB5, undef, 0x1FC5, undef, 0x1FD4, 0x1FD5, 0x1FDC, undef, 0x1FF0, 0x1FF1, 0x1FF5, undef, 0x1FFF, undef, 0x200E, 0x200F, 0x2024, 0x2026, 0x2028, 0x202E, 0x2061, 0x2063, 0x2065, 0x206F, 0x2072, 0x2073, 0x208F, undef, 0x209D, 0x209F, 0x20C0, 0x20CF, 0x20F1, 0x20FF, 0x2132, undef, 0x2183, undef, 0x218C, 0x218F, 0x2427, 0x243F, 0x244B, 0x245F, 0x2488, 0x249B, 0x2B74, 0x2B75, 0x2B96, 0x2B97, 0x2BBA, 0x2BBC, 0x2BC9, undef, 0x2BD3, 0x2BEB, 0x2BF0, 0x2BFF, 0x2C2F, undef, 0x2C5F, undef, 0x2CF4, 0x2CF8, 0x2D26, undef, 0x2D28, 0x2D2C, 0x2D2E, 0x2D2F, 0x2D68, 0x2D6E, 0x2D71, 0x2D7E, 0x2D97, 0x2D9F, 0x2DA7, undef, 0x2DAF, undef, 0x2DB7, undef, 0x2DBF, undef, 0x2DC7, undef, 0x2DCF, undef, 0x2DD7, undef, 0x2DDF, undef, 0x2E4A, 0x2E7F, 0x2E9A, undef, 0x2EF4, 0x2EFF, 0x2FD6, 0x2FFF, 0x3040, undef, 0x3097, 0x3098, 0x3100, 0x3104, 0x312F, 0x3130, 0x3164, undef, 0x318F, undef, 0x31BB, 0x31BF, 0x31E4, 0x31EF, 0x321F, undef, 0x32FF, undef, 0x33C2, undef, 0x33C7, undef, 0x33D8, undef, 0x4DB6, 0x4DBF, 0x9FEB, 0x9FFF, 0xA48D, 0xA48F, 0xA4C7, 0xA4CF, 0xA62C, 0xA63F, 0xA6F8, 0xA6FF, 0xA7AF, undef, 0xA7B8, 0xA7F6, 0xA82C, 0xA82F, 0xA83A, 0xA83F, 0xA878, 0xA87F, 0xA8C6, 0xA8CD, 0xA8DA, 0xA8DF, 0xA8FE, 0xA8FF, 0xA954, 0xA95E, 0xA97D, 0xA97F, 0xA9CE, undef, 0xA9DA, 0xA9DD, 0xA9FF, undef, 0xAA37, 0xAA3F, 0xAA4E, 0xAA4F, 0xAA5A, 0xAA5B, 0xAAC3, 0xAADA, 0xAAF7, 0xAB00, 0xAB07, 0xAB08, 0xAB0F, 0xAB10, 0xAB17, 0xAB1F, 0xAB27, undef, 0xAB2F, undef, 0xAB66, 0xAB6F, 0xABEE, 0xABEF, 0xABFA, 0xABFF, 0xD7A4, 0xD7AF, 0xD7C7, 0xD7CA, 0xD7FC, 0xF8FF, 0xFA6E, 0xFA6F, 0xFADA, 0xFAFF, 0xFB07, 0xFB12, 0xFB18, 0xFB1C, 0xFB37, undef, 0xFB3D, undef, 0xFB3F, undef, 0xFB42, undef, 0xFB45, undef, 0xFBC2, 0xFBD2, 0xFD40, 0xFD4F, 0xFD90, 0xFD91, 0xFDC8, 0xFDEF, 0xFDFE, 0xFDFF, 0xFE12, undef, 0xFE19, 0xFE1F, 0xFE30, undef, 0xFE52, 0xFE53, 0xFE67, undef, 0xFE6C, 0xFE6F, 0xFE75, undef, 0xFEFD, 0xFEFE, 0xFF00, undef, 0xFFA0, undef, 0xFFBF, 0xFFC1, 0xFFC8, 0xFFC9, 0xFFD0, 0xFFD1, 0xFFD8, 0xFFD9, 0xFFDD, 0xFFDF, 0xFFE7, undef, 0xFFEF, 0xFFFF, 0x1000C, undef, 0x10027, undef, 0x1003B, undef, 0x1003E, undef, 0x1004E, 0x1004F, 0x1005E, 0x1007F, 0x100FB, 0x100FF, 0x10103, 0x10106, 0x10134, 0x10136, 0x1018F, undef, 0x1019C, 0x1019F, 0x101A1, 0x101CF, 0x101FE, 0x1027F, 0x1029D, 0x1029F, 0x102D1, 0x102DF, 0x102FC, 0x102FF, 0x10324, 0x1032C, 0x1034B, 0x1034F, 0x1037B, 0x1037F, 0x1039E, undef, 0x103C4, 0x103C7, 0x103D6, 0x103FF, 0x1049E, 0x1049F, 0x104AA, 0x104AF, 0x104D4, 0x104D7, 0x104FC, 0x104FF, 0x10528, 0x1052F, 0x10564, 0x1056E, 0x10570, 0x105FF, 0x10737, 0x1073F, 0x10756, 0x1075F, 0x10768, 0x107FF, 0x10806, 0x10807, 0x10809, undef, 0x10836, undef, 0x10839, 0x1083B, 0x1083D, 0x1083E, 0x10856, undef, 0x1089F, 0x108A6, 0x108B0, 0x108DF, 0x108F3, undef, 0x108F6, 0x108FA, 0x1091C, 0x1091E, 0x1093A, 0x1093E, 0x10940, 0x1097F, 0x109B8, 0x109BB, 0x109D0, 0x109D1, 0x10A04, undef, 0x10A07, 0x10A0B, 0x10A14, undef, 0x10A18, undef, 0x10A34, 0x10A37, 0x10A3B, 0x10A3E, 0x10A48, 0x10A4F, 0x10A59, 0x10A5F, 0x10AA0, 0x10ABF, 0x10AE7, 0x10AEA, 0x10AF7, 0x10AFF, 0x10B36, 0x10B38, 0x10B56, 0x10B57, 0x10B73, 0x10B77, 0x10B92, 0x10B98, 0x10B9D, 0x10BA8, 0x10BB0, 0x10BFF, 0x10C49, 0x10C7F, 0x10CB3, 0x10CBF, 0x10CF3, 0x10CF9, 0x10D00, 0x10E5F, 0x10E7F, 0x10FFF, 0x1104E, 0x11051, 0x11070, 0x1107E, 0x110BD, undef, 0x110C2, 0x110CF, 0x110E9, 0x110EF, 0x110FA, 0x110FF, 0x11135, undef, 0x11144, 0x1114F, 0x11177, 0x1117F, 0x111CE, 0x111CF, 0x111E0, undef, 0x111F5, 0x111FF, 0x11212, undef, 0x1123F, 0x1127F, 0x11287, undef, 0x11289, undef, 0x1128E, undef, 0x1129E, undef, 0x112AA, 0x112AF, 0x112EB, 0x112EF, 0x112FA, 0x112FF, 0x11304, undef, 0x1130D, 0x1130E, 0x11311, 0x11312, 0x11329, undef, 0x11331, undef, 0x11334, undef, 0x1133A, 0x1133B, 0x11345, 0x11346, 0x11349, 0x1134A, 0x1134E, 0x1134F, 0x11351, 0x11356, 0x11358, 0x1135C, 0x11364, 0x11365, 0x1136D, 0x1136F, 0x11375, 0x113FF, 0x1145A, undef, 0x1145C, undef, 0x1145E, 0x1147F, 0x114C8, 0x114CF, 0x114DA, 0x1157F, 0x115B6, 0x115B7, 0x115DE, 0x115FF, 0x11645, 0x1164F, 0x1165A, 0x1165F, 0x1166D, 0x1167F, 0x116B8, 0x116BF, 0x116CA, 0x116FF, 0x1171A, 0x1171C, 0x1172C, 0x1172F, 0x11740, 0x1189F, 0x118F3, 0x118FE, 0x11900, 0x119FF, 0x11A48, 0x11A4F, 0x11A84, 0x11A85, 0x11A9D, undef, 0x11AA3, 0x11ABF, 0x11AF9, 0x11BFF, 0x11C09, undef, 0x11C37, undef, 0x11C46, 0x11C4F, 0x11C6D, 0x11C6F, 0x11C90, 0x11C91, 0x11CA8, undef, 0x11CB7, 0x11CFF, 0x11D07, undef, 0x11D0A, undef, 0x11D37, 0x11D39, 0x11D3B, undef, 0x11D3E, undef, 0x11D48, 0x11D4F, 0x11D5A, 0x11FFF, 0x1239A, 0x123FF, 0x1246F, undef, 0x12475, 0x1247F, 0x12544, 0x12FFF, 0x1342F, 0x143FF, 0x14647, 0x167FF, 0x16A39, 0x16A3F, 0x16A5F, undef, 0x16A6A, 0x16A6D, 0x16A70, 0x16ACF, 0x16AEE, 0x16AEF, 0x16AF6, 0x16AFF, 0x16B46, 0x16B4F, 0x16B5A, undef, 0x16B62, undef, 0x16B78, 0x16B7C, 0x16B90, 0x16EFF, 0x16F45, 0x16F4F, 0x16F7F, 0x16F8E, 0x16FA0, 0x16FDF, 0x16FE2, 0x16FFF, 0x187ED, 0x187FF, 0x18AF3, 0x1AFFF, 0x1B11F, 0x1B16F, 0x1B2FC, 0x1BBFF, 0x1BC6B, 0x1BC6F, 0x1BC7D, 0x1BC7F, 0x1BC89, 0x1BC8F, 0x1BC9A, 0x1BC9B, 0x1BCA4, 0x1CFFF, 0x1D0F6, 0x1D0FF, 0x1D127, 0x1D128, 0x1D173, 0x1D17A, 0x1D1E9, 0x1D1FF, 0x1D246, 0x1D2FF, 0x1D357, 0x1D35F, 0x1D372, 0x1D3FF, 0x1D455, undef, 0x1D49D, undef, 0x1D4A0, 0x1D4A1, 0x1D4A3, 0x1D4A4, 0x1D4A7, 0x1D4A8, 0x1D4AD, undef, 0x1D4BA, undef, 0x1D4BC, undef, 0x1D4C4, undef, 0x1D506, undef, 0x1D50B, 0x1D50C, 0x1D515, undef, 0x1D51D, undef, 0x1D53A, undef, 0x1D53F, undef, 0x1D545, undef, 0x1D547, 0x1D549, 0x1D551, undef, 0x1D6A6, 0x1D6A7, 0x1D7CC, 0x1D7CD, 0x1DA8C, 0x1DA9A, 0x1DAA0, undef, 0x1DAB0, 0x1DFFF, 0x1E007, undef, 0x1E019, 0x1E01A, 0x1E022, undef, 0x1E025, undef, 0x1E02B, 0x1E7FF, 0x1E8C5, 0x1E8C6, 0x1E8D7, 0x1E8FF, 0x1E94B, 0x1E94F, 0x1E95A, 0x1E95D, 0x1E960, 0x1EDFF, 0x1EE04, undef, 0x1EE20, undef, 0x1EE23, undef, 0x1EE25, 0x1EE26, 0x1EE28, undef, 0x1EE33, undef, 0x1EE38, undef, 0x1EE3A, undef, 0x1EE3C, 0x1EE41, 0x1EE43, 0x1EE46, 0x1EE48, undef, 0x1EE4A, undef, 0x1EE4C, undef, 0x1EE50, undef, 0x1EE53, undef, 0x1EE55, 0x1EE56, 0x1EE58, undef, 0x1EE5A, undef, 0x1EE5C, undef, 0x1EE5E, undef, 0x1EE60, undef, 0x1EE63, undef, 0x1EE65, 0x1EE66, 0x1EE6B, undef, 0x1EE73, undef, 0x1EE78, undef, 0x1EE7D, undef, 0x1EE7F, undef, 0x1EE8A, undef, 0x1EE9C, 0x1EEA0, 0x1EEA4, undef, 0x1EEAA, undef, 0x1EEBC, 0x1EEEF, 0x1EEF2, 0x1EFFF, 0x1F02C, 0x1F02F, 0x1F094, 0x1F09F, 0x1F0AF, 0x1F0B0, 0x1F0C0, undef, 0x1F0D0, undef, 0x1F0F6, 0x1F100, 0x1F10D, 0x1F10F, 0x1F12F, undef, 0x1F16C, 0x1F16F, 0x1F1AD, 0x1F1E5, 0x1F203, 0x1F20F, 0x1F23C, 0x1F23F, 0x1F249, 0x1F24F, 0x1F252, 0x1F25F, 0x1F266, 0x1F2FF, 0x1F6D5, 0x1F6DF, 0x1F6ED, 0x1F6EF, 0x1F6F9, 0x1F6FF, 0x1F774, 0x1F77F, 0x1F7D5, 0x1F7FF, 0x1F80C, 0x1F80F, 0x1F848, 0x1F84F, 0x1F85A, 0x1F85F, 0x1F888, 0x1F88F, 0x1F8AE, 0x1F8FF, 0x1F90C, 0x1F90F, 0x1F93F, undef, 0x1F94D, 0x1F94F, 0x1F96C, 0x1F97F, 0x1F998, 0x1F9BF, 0x1F9C1, 0x1F9CF, 0x1F9E7, 0x1FFFF, 0x2A6D7, 0x2A6FF, 0x2B735, 0x2B73F, 0x2B81E, 0x2B81F, 0x2CEA2, 0x2CEAF, 0x2EBE1, 0x2F7FF, 0x2F868, undef, 0x2F874, undef, 0x2F91F, undef, 0x2F95F, undef, 0x2F9BF, undef, 0x2FA1E, 0xE00FF, 0xE01F0, 0x10FFFF, ); sub IsDisallowed { return _mk_prop(@DISALLOWED); }; our @DISALLOWEDSTD3VALID = ( 0x0000, 0x002C, 0x002F, undef, 0x003A, 0x0040, 0x005B, 0x0060, 0x007B, 0x007F, 0x2260, undef, 0x226E, 0x226F, ); sub IsDisallowedSTD3Valid { return _mk_prop(@DISALLOWEDSTD3VALID); }; our @VALID = ( 0x002D, 0x002E, 0x0030, 0x0039, 0x0061, 0x007A, 0x00A1, 0x00A7, 0x00A9, undef, 0x00AB, 0x00AC, 0x00AE, undef, 0x00B0, 0x00B1, 0x00B6, 0x00B7, 0x00BB, undef, 0x00BF, undef, 0x00D7, undef, 0x00E0, 0x00FF, 0x0101, undef, 0x0103, undef, 0x0105, undef, 0x0107, undef, 0x0109, undef, 0x010B, undef, 0x010D, undef, 0x010F, undef, 0x0111, undef, 0x0113, undef, 0x0115, undef, 0x0117, undef, 0x0119, undef, 0x011B, undef, 0x011D, undef, 0x011F, undef, 0x0121, undef, 0x0123, undef, 0x0125, undef, 0x0127, undef, 0x0129, undef, 0x012B, undef, 0x012D, undef, 0x012F, undef, 0x0131, undef, 0x0135, undef, 0x0137, 0x0138, 0x013A, undef, 0x013C, undef, 0x013E, undef, 0x0142, undef, 0x0144, undef, 0x0146, undef, 0x0148, undef, 0x014B, undef, 0x014D, undef, 0x014F, undef, 0x0151, undef, 0x0153, undef, 0x0155, undef, 0x0157, undef, 0x0159, undef, 0x015B, undef, 0x015D, undef, 0x015F, undef, 0x0161, undef, 0x0163, undef, 0x0165, undef, 0x0167, undef, 0x0169, undef, 0x016B, undef, 0x016D, undef, 0x016F, undef, 0x0171, undef, 0x0173, undef, 0x0175, undef, 0x0177, undef, 0x017A, undef, 0x017C, undef, 0x017E, undef, 0x0180, undef, 0x0183, undef, 0x0185, undef, 0x0188, undef, 0x018C, 0x018D, 0x0192, undef, 0x0195, undef, 0x0199, 0x019B, 0x019E, undef, 0x01A1, undef, 0x01A3, undef, 0x01A5, undef, 0x01A8, undef, 0x01AA, 0x01AB, 0x01AD, undef, 0x01B0, undef, 0x01B4, undef, 0x01B6, undef, 0x01B9, 0x01BB, 0x01BD, 0x01C3, 0x01CE, undef, 0x01D0, undef, 0x01D2, undef, 0x01D4, undef, 0x01D6, undef, 0x01D8, undef, 0x01DA, undef, 0x01DC, 0x01DD, 0x01DF, undef, 0x01E1, undef, 0x01E3, undef, 0x01E5, undef, 0x01E7, undef, 0x01E9, undef, 0x01EB, undef, 0x01ED, undef, 0x01EF, 0x01F0, 0x01F5, undef, 0x01F9, undef, 0x01FB, undef, 0x01FD, undef, 0x01FF, undef, 0x0201, undef, 0x0203, undef, 0x0205, undef, 0x0207, undef, 0x0209, undef, 0x020B, undef, 0x020D, undef, 0x020F, undef, 0x0211, undef, 0x0213, undef, 0x0215, undef, 0x0217, undef, 0x0219, undef, 0x021B, undef, 0x021D, undef, 0x021F, undef, 0x0221, undef, 0x0223, undef, 0x0225, undef, 0x0227, undef, 0x0229, undef, 0x022B, undef, 0x022D, undef, 0x022F, undef, 0x0231, undef, 0x0233, 0x0239, 0x023C, undef, 0x023F, 0x0240, 0x0242, undef, 0x0247, undef, 0x0249, undef, 0x024B, undef, 0x024D, undef, 0x024F, 0x02AF, 0x02B9, 0x02D7, 0x02DE, 0x02DF, 0x02E5, 0x033F, 0x0342, undef, 0x0346, 0x034E, 0x0350, 0x036F, 0x0371, undef, 0x0373, undef, 0x0375, undef, 0x0377, undef, 0x037B, 0x037D, 0x0390, undef, 0x03AC, 0x03C1, 0x03C3, 0x03CE, 0x03D7, undef, 0x03D9, undef, 0x03DB, undef, 0x03DD, undef, 0x03DF, undef, 0x03E1, undef, 0x03E3, undef, 0x03E5, undef, 0x03E7, undef, 0x03E9, undef, 0x03EB, undef, 0x03ED, undef, 0x03EF, undef, 0x03F3, undef, 0x03F6, undef, 0x03F8, undef, 0x03FB, 0x03FC, 0x0430, 0x045F, 0x0461, undef, 0x0463, undef, 0x0465, undef, 0x0467, undef, 0x0469, undef, 0x046B, undef, 0x046D, undef, 0x046F, undef, 0x0471, undef, 0x0473, undef, 0x0475, undef, 0x0477, undef, 0x0479, undef, 0x047B, undef, 0x047D, undef, 0x047F, undef, 0x0481, 0x0489, 0x048B, undef, 0x048D, undef, 0x048F, undef, 0x0491, undef, 0x0493, undef, 0x0495, undef, 0x0497, undef, 0x0499, undef, 0x049B, undef, 0x049D, undef, 0x049F, undef, 0x04A1, undef, 0x04A3, undef, 0x04A5, undef, 0x04A7, undef, 0x04A9, undef, 0x04AB, undef, 0x04AD, undef, 0x04AF, undef, 0x04B1, undef, 0x04B3, undef, 0x04B5, undef, 0x04B7, undef, 0x04B9, undef, 0x04BB, undef, 0x04BD, undef, 0x04BF, undef, 0x04C2, undef, 0x04C4, undef, 0x04C6, undef, 0x04C8, undef, 0x04CA, undef, 0x04CC, undef, 0x04CE, 0x04CF, 0x04D1, undef, 0x04D3, undef, 0x04D5, undef, 0x04D7, undef, 0x04D9, undef, 0x04DB, undef, 0x04DD, undef, 0x04DF, undef, 0x04E1, undef, 0x04E3, undef, 0x04E5, undef, 0x04E7, undef, 0x04E9, undef, 0x04EB, undef, 0x04ED, undef, 0x04EF, undef, 0x04F1, undef, 0x04F3, undef, 0x04F5, undef, 0x04F7, undef, 0x04F9, undef, 0x04FB, undef, 0x04FD, undef, 0x04FF, undef, 0x0501, undef, 0x0503, undef, 0x0505, undef, 0x0507, undef, 0x0509, undef, 0x050B, undef, 0x050D, undef, 0x050F, undef, 0x0511, undef, 0x0513, undef, 0x0515, undef, 0x0517, undef, 0x0519, undef, 0x051B, undef, 0x051D, undef, 0x051F, undef, 0x0521, undef, 0x0523, undef, 0x0525, undef, 0x0527, undef, 0x0529, undef, 0x052B, undef, 0x052D, undef, 0x052F, undef, 0x0559, 0x055F, 0x0561, 0x0586, 0x0589, 0x058A, 0x058D, 0x058F, 0x0591, 0x05C7, 0x05D0, 0x05EA, 0x05F0, 0x05F4, 0x0606, 0x061B, 0x061E, 0x0674, 0x0679, 0x06DC, 0x06DE, 0x070D, 0x0710, 0x074A, 0x074D, 0x07B1, 0x07C0, 0x07FA, 0x0800, 0x082D, 0x0830, 0x083E, 0x0840, 0x085B, 0x085E, undef, 0x0860, 0x086A, 0x08A0, 0x08B4, 0x08B6, 0x08BD, 0x08D4, 0x08E1, 0x08E3, 0x0957, 0x0960, 0x0983, 0x0985, 0x098C, 0x098F, 0x0990, 0x0993, 0x09A8, 0x09AA, 0x09B0, 0x09B2, undef, 0x09B6, 0x09B9, 0x09BC, 0x09C4, 0x09C7, 0x09C8, 0x09CB, 0x09CE, 0x09D7, undef, 0x09E0, 0x09E3, 0x09E6, 0x09FD, 0x0A01, 0x0A03, 0x0A05, 0x0A0A, 0x0A0F, 0x0A10, 0x0A13, 0x0A28, 0x0A2A, 0x0A30, 0x0A32, undef, 0x0A35, undef, 0x0A38, 0x0A39, 0x0A3C, undef, 0x0A3E, 0x0A42, 0x0A47, 0x0A48, 0x0A4B, 0x0A4D, 0x0A51, undef, 0x0A5C, undef, 0x0A66, 0x0A75, 0x0A81, 0x0A83, 0x0A85, 0x0A8D, 0x0A8F, 0x0A91, 0x0A93, 0x0AA8, 0x0AAA, 0x0AB0, 0x0AB2, 0x0AB3, 0x0AB5, 0x0AB9, 0x0ABC, 0x0AC5, 0x0AC7, 0x0AC9, 0x0ACB, 0x0ACD, 0x0AD0, undef, 0x0AE0, 0x0AE3, 0x0AE6, 0x0AF1, 0x0AF9, 0x0AFF, 0x0B01, 0x0B03, 0x0B05, 0x0B0C, 0x0B0F, 0x0B10, 0x0B13, 0x0B28, 0x0B2A, 0x0B30, 0x0B32, 0x0B33, 0x0B35, 0x0B39, 0x0B3C, 0x0B44, 0x0B47, 0x0B48, 0x0B4B, 0x0B4D, 0x0B56, 0x0B57, 0x0B5F, 0x0B63, 0x0B66, 0x0B77, 0x0B82, 0x0B83, 0x0B85, 0x0B8A, 0x0B8E, 0x0B90, 0x0B92, 0x0B95, 0x0B99, 0x0B9A, 0x0B9C, undef, 0x0B9E, 0x0B9F, 0x0BA3, 0x0BA4, 0x0BA8, 0x0BAA, 0x0BAE, 0x0BB9, 0x0BBE, 0x0BC2, 0x0BC6, 0x0BC8, 0x0BCA, 0x0BCD, 0x0BD0, undef, 0x0BD7, undef, 0x0BE6, 0x0BFA, 0x0C00, 0x0C03, 0x0C05, 0x0C0C, 0x0C0E, 0x0C10, 0x0C12, 0x0C28, 0x0C2A, 0x0C39, 0x0C3D, 0x0C44, 0x0C46, 0x0C48, 0x0C4A, 0x0C4D, 0x0C55, 0x0C56, 0x0C58, 0x0C5A, 0x0C60, 0x0C63, 0x0C66, 0x0C6F, 0x0C78, 0x0C83, 0x0C85, 0x0C8C, 0x0C8E, 0x0C90, 0x0C92, 0x0CA8, 0x0CAA, 0x0CB3, 0x0CB5, 0x0CB9, 0x0CBC, 0x0CC4, 0x0CC6, 0x0CC8, 0x0CCA, 0x0CCD, 0x0CD5, 0x0CD6, 0x0CDE, undef, 0x0CE0, 0x0CE3, 0x0CE6, 0x0CEF, 0x0CF1, 0x0CF2, 0x0D00, 0x0D03, 0x0D05, 0x0D0C, 0x0D0E, 0x0D10, 0x0D12, 0x0D44, 0x0D46, 0x0D48, 0x0D4A, 0x0D4F, 0x0D54, 0x0D63, 0x0D66, 0x0D7F, 0x0D82, 0x0D83, 0x0D85, 0x0D96, 0x0D9A, 0x0DB1, 0x0DB3, 0x0DBB, 0x0DBD, undef, 0x0DC0, 0x0DC6, 0x0DCA, undef, 0x0DCF, 0x0DD4, 0x0DD6, undef, 0x0DD8, 0x0DDF, 0x0DE6, 0x0DEF, 0x0DF2, 0x0DF4, 0x0E01, 0x0E32, 0x0E34, 0x0E3A, 0x0E3F, 0x0E5B, 0x0E81, 0x0E82, 0x0E84, undef, 0x0E87, 0x0E88, 0x0E8A, undef, 0x0E8D, undef, 0x0E94, 0x0E97, 0x0E99, 0x0E9F, 0x0EA1, 0x0EA3, 0x0EA5, undef, 0x0EA7, undef, 0x0EAA, 0x0EAB, 0x0EAD, 0x0EB2, 0x0EB4, 0x0EB9, 0x0EBB, 0x0EBD, 0x0EC0, 0x0EC4, 0x0EC6, undef, 0x0EC8, 0x0ECD, 0x0ED0, 0x0ED9, 0x0EDE, 0x0EDF, 0x0F00, 0x0F0B, 0x0F0D, 0x0F42, 0x0F44, 0x0F47, 0x0F49, 0x0F4C, 0x0F4E, 0x0F51, 0x0F53, 0x0F56, 0x0F58, 0x0F5B, 0x0F5D, 0x0F68, 0x0F6A, 0x0F6C, 0x0F71, 0x0F72, 0x0F74, undef, 0x0F7A, 0x0F80, 0x0F82, 0x0F92, 0x0F94, 0x0F97, 0x0F99, 0x0F9C, 0x0F9E, 0x0FA1, 0x0FA3, 0x0FA6, 0x0FA8, 0x0FAB, 0x0FAD, 0x0FB8, 0x0FBA, 0x0FBC, 0x0FBE, 0x0FCC, 0x0FCE, 0x0FDA, 0x1000, 0x109F, 0x10D0, 0x10FB, 0x10FD, 0x115E, 0x1161, 0x1248, 0x124A, 0x124D, 0x1250, 0x1256, 0x1258, undef, 0x125A, 0x125D, 0x1260, 0x1288, 0x128A, 0x128D, 0x1290, 0x12B0, 0x12B2, 0x12B5, 0x12B8, 0x12BE, 0x12C0, undef, 0x12C2, 0x12C5, 0x12C8, 0x12D6, 0x12D8, 0x1310, 0x1312, 0x1315, 0x1318, 0x135A, 0x135D, 0x137C, 0x1380, 0x1399, 0x13A0, 0x13F5, 0x1400, 0x167F, 0x1681, 0x169C, 0x16A0, 0x16F8, 0x1700, 0x170C, 0x170E, 0x1714, 0x1720, 0x1736, 0x1740, 0x1753, 0x1760, 0x176C, 0x176E, 0x1770, 0x1772, 0x1773, 0x1780, 0x17B3, 0x17B6, 0x17DD, 0x17E0, 0x17E9, 0x17F0, 0x17F9, 0x1800, 0x1805, 0x1807, 0x180A, 0x1810, 0x1819, 0x1820, 0x1877, 0x1880, 0x18AA, 0x18B0, 0x18F5, 0x1900, 0x191E, 0x1920, 0x192B, 0x1930, 0x193B, 0x1940, undef, 0x1944, 0x196D, 0x1970, 0x1974, 0x1980, 0x19AB, 0x19B0, 0x19C9, 0x19D0, 0x19DA, 0x19DE, 0x1A1B, 0x1A1E, 0x1A5E, 0x1A60, 0x1A7C, 0x1A7F, 0x1A89, 0x1A90, 0x1A99, 0x1AA0, 0x1AAD, 0x1AB0, 0x1ABE, 0x1B00, 0x1B4B, 0x1B50, 0x1B7C, 0x1B80, 0x1BF3, 0x1BFC, 0x1C37, 0x1C3B, 0x1C49, 0x1C4D, 0x1C7F, 0x1CC0, 0x1CC7, 0x1CD0, 0x1CF9, 0x1D00, 0x1D2B, 0x1D2F, undef, 0x1D3B, undef, 0x1D4E, undef, 0x1D6B, 0x1D77, 0x1D79, 0x1D9A, 0x1DC0, 0x1DF9, 0x1DFB, 0x1DFF, 0x1E01, undef, 0x1E03, undef, 0x1E05, undef, 0x1E07, undef, 0x1E09, undef, 0x1E0B, undef, 0x1E0D, undef, 0x1E0F, undef, 0x1E11, undef, 0x1E13, undef, 0x1E15, undef, 0x1E17, undef, 0x1E19, undef, 0x1E1B, undef, 0x1E1D, undef, 0x1E1F, undef, 0x1E21, undef, 0x1E23, undef, 0x1E25, undef, 0x1E27, undef, 0x1E29, undef, 0x1E2B, undef, 0x1E2D, undef, 0x1E2F, undef, 0x1E31, undef, 0x1E33, undef, 0x1E35, undef, 0x1E37, undef, 0x1E39, undef, 0x1E3B, undef, 0x1E3D, undef, 0x1E3F, undef, 0x1E41, undef, 0x1E43, undef, 0x1E45, undef, 0x1E47, undef, 0x1E49, undef, 0x1E4B, undef, 0x1E4D, undef, 0x1E4F, undef, 0x1E51, undef, 0x1E53, undef, 0x1E55, undef, 0x1E57, undef, 0x1E59, undef, 0x1E5B, undef, 0x1E5D, undef, 0x1E5F, undef, 0x1E61, undef, 0x1E63, undef, 0x1E65, undef, 0x1E67, undef, 0x1E69, undef, 0x1E6B, undef, 0x1E6D, undef, 0x1E6F, undef, 0x1E71, undef, 0x1E73, undef, 0x1E75, undef, 0x1E77, undef, 0x1E79, undef, 0x1E7B, undef, 0x1E7D, undef, 0x1E7F, undef, 0x1E81, undef, 0x1E83, undef, 0x1E85, undef, 0x1E87, undef, 0x1E89, undef, 0x1E8B, undef, 0x1E8D, undef, 0x1E8F, undef, 0x1E91, undef, 0x1E93, undef, 0x1E95, 0x1E99, 0x1E9C, 0x1E9D, 0x1E9F, undef, 0x1EA1, undef, 0x1EA3, undef, 0x1EA5, undef, 0x1EA7, undef, 0x1EA9, undef, 0x1EAB, undef, 0x1EAD, undef, 0x1EAF, undef, 0x1EB1, undef, 0x1EB3, undef, 0x1EB5, undef, 0x1EB7, undef, 0x1EB9, undef, 0x1EBB, undef, 0x1EBD, undef, 0x1EBF, undef, 0x1EC1, undef, 0x1EC3, undef, 0x1EC5, undef, 0x1EC7, undef, 0x1EC9, undef, 0x1ECB, undef, 0x1ECD, undef, 0x1ECF, undef, 0x1ED1, undef, 0x1ED3, undef, 0x1ED5, undef, 0x1ED7, undef, 0x1ED9, undef, 0x1EDB, undef, 0x1EDD, undef, 0x1EDF, undef, 0x1EE1, undef, 0x1EE3, undef, 0x1EE5, undef, 0x1EE7, undef, 0x1EE9, undef, 0x1EEB, undef, 0x1EED, undef, 0x1EEF, undef, 0x1EF1, undef, 0x1EF3, undef, 0x1EF5, undef, 0x1EF7, undef, 0x1EF9, undef, 0x1EFB, undef, 0x1EFD, undef, 0x1EFF, 0x1F07, 0x1F10, 0x1F15, 0x1F20, 0x1F27, 0x1F30, 0x1F37, 0x1F40, 0x1F45, 0x1F50, 0x1F57, 0x1F60, 0x1F67, 0x1F70, undef, 0x1F72, undef, 0x1F74, undef, 0x1F76, undef, 0x1F78, undef, 0x1F7A, undef, 0x1F7C, undef, 0x1FB0, 0x1FB1, 0x1FB6, undef, 0x1FC6, undef, 0x1FD0, 0x1FD2, 0x1FD6, 0x1FD7, 0x1FE0, 0x1FE2, 0x1FE4, 0x1FE7, 0x1FF6, undef, 0x2010, undef, 0x2012, 0x2016, 0x2018, 0x2023, 0x2027, undef, 0x2030, 0x2032, 0x2035, undef, 0x2038, 0x203B, 0x203D, undef, 0x203F, 0x2046, 0x204A, 0x2056, 0x2058, 0x205E, 0x20A0, 0x20A7, 0x20A9, 0x20BF, 0x20D0, 0x20F0, 0x2104, undef, 0x2108, undef, 0x2114, undef, 0x2117, 0x2118, 0x211E, 0x211F, 0x2123, undef, 0x2125, undef, 0x2127, undef, 0x2129, undef, 0x212E, undef, 0x213A, undef, 0x2141, 0x2144, 0x214A, 0x214F, 0x2180, 0x2182, 0x2184, 0x2188, 0x218A, 0x218B, 0x2190, 0x222B, 0x222E, undef, 0x2231, 0x225F, 0x2261, 0x226D, 0x2270, 0x2328, 0x232B, 0x2426, 0x2440, 0x244A, 0x24EB, 0x2A0B, 0x2A0D, 0x2A73, 0x2A77, 0x2ADB, 0x2ADD, 0x2B73, 0x2B76, 0x2B95, 0x2B98, 0x2BB9, 0x2BBD, 0x2BC8, 0x2BCA, 0x2BD2, 0x2BEC, 0x2BEF, 0x2C30, 0x2C5E, 0x2C61, undef, 0x2C65, 0x2C66, 0x2C68, undef, 0x2C6A, undef, 0x2C6C, undef, 0x2C71, undef, 0x2C73, 0x2C74, 0x2C76, 0x2C7B, 0x2C81, undef, 0x2C83, undef, 0x2C85, undef, 0x2C87, undef, 0x2C89, undef, 0x2C8B, undef, 0x2C8D, undef, 0x2C8F, undef, 0x2C91, undef, 0x2C93, undef, 0x2C95, undef, 0x2C97, undef, 0x2C99, undef, 0x2C9B, undef, 0x2C9D, undef, 0x2C9F, undef, 0x2CA1, undef, 0x2CA3, undef, 0x2CA5, undef, 0x2CA7, undef, 0x2CA9, undef, 0x2CAB, undef, 0x2CAD, undef, 0x2CAF, undef, 0x2CB1, undef, 0x2CB3, undef, 0x2CB5, undef, 0x2CB7, undef, 0x2CB9, undef, 0x2CBB, undef, 0x2CBD, undef, 0x2CBF, undef, 0x2CC1, undef, 0x2CC3, undef, 0x2CC5, undef, 0x2CC7, undef, 0x2CC9, undef, 0x2CCB, undef, 0x2CCD, undef, 0x2CCF, undef, 0x2CD1, undef, 0x2CD3, undef, 0x2CD5, undef, 0x2CD7, undef, 0x2CD9, undef, 0x2CDB, undef, 0x2CDD, undef, 0x2CDF, undef, 0x2CE1, undef, 0x2CE3, 0x2CEA, 0x2CEC, undef, 0x2CEE, 0x2CF1, 0x2CF3, undef, 0x2CF9, 0x2D25, 0x2D27, undef, 0x2D2D, undef, 0x2D30, 0x2D67, 0x2D70, undef, 0x2D7F, 0x2D96, 0x2DA0, 0x2DA6, 0x2DA8, 0x2DAE, 0x2DB0, 0x2DB6, 0x2DB8, 0x2DBE, 0x2DC0, 0x2DC6, 0x2DC8, 0x2DCE, 0x2DD0, 0x2DD6, 0x2DD8, 0x2DDE, 0x2DE0, 0x2E49, 0x2E80, 0x2E99, 0x2E9B, 0x2E9E, 0x2EA0, 0x2EF2, 0x3001, undef, 0x3003, 0x3035, 0x3037, undef, 0x303B, 0x303F, 0x3041, 0x3096, 0x3099, 0x309A, 0x309D, 0x309E, 0x30A0, 0x30FE, 0x3105, 0x312E, 0x3190, 0x3191, 0x31A0, 0x31BA, 0x31C0, 0x31E3, 0x31F0, 0x31FF, 0x3248, 0x324F, 0x327F, undef, 0x3400, 0x4DB5, 0x4DC0, 0x9FEA, 0xA000, 0xA48C, 0xA490, 0xA4C6, 0xA4D0, 0xA62B, 0xA641, undef, 0xA643, undef, 0xA645, undef, 0xA647, undef, 0xA649, undef, 0xA64B, undef, 0xA64D, undef, 0xA64F, undef, 0xA651, undef, 0xA653, undef, 0xA655, undef, 0xA657, undef, 0xA659, undef, 0xA65B, undef, 0xA65D, undef, 0xA65F, undef, 0xA661, undef, 0xA663, undef, 0xA665, undef, 0xA667, undef, 0xA669, undef, 0xA66B, undef, 0xA66D, 0xA67F, 0xA681, undef, 0xA683, undef, 0xA685, undef, 0xA687, undef, 0xA689, undef, 0xA68B, undef, 0xA68D, undef, 0xA68F, undef, 0xA691, undef, 0xA693, undef, 0xA695, undef, 0xA697, undef, 0xA699, undef, 0xA69B, undef, 0xA69E, 0xA6F7, 0xA700, 0xA721, 0xA723, undef, 0xA725, undef, 0xA727, undef, 0xA729, undef, 0xA72B, undef, 0xA72D, undef, 0xA72F, 0xA731, 0xA733, undef, 0xA735, undef, 0xA737, undef, 0xA739, undef, 0xA73B, undef, 0xA73D, undef, 0xA73F, undef, 0xA741, undef, 0xA743, undef, 0xA745, undef, 0xA747, undef, 0xA749, undef, 0xA74B, undef, 0xA74D, undef, 0xA74F, undef, 0xA751, undef, 0xA753, undef, 0xA755, undef, 0xA757, undef, 0xA759, undef, 0xA75B, undef, 0xA75D, undef, 0xA75F, undef, 0xA761, undef, 0xA763, undef, 0xA765, undef, 0xA767, undef, 0xA769, undef, 0xA76B, undef, 0xA76D, undef, 0xA76F, undef, 0xA771, 0xA778, 0xA77A, undef, 0xA77C, undef, 0xA77F, undef, 0xA781, undef, 0xA783, undef, 0xA785, undef, 0xA787, 0xA78A, 0xA78C, undef, 0xA78E, 0xA78F, 0xA791, undef, 0xA793, 0xA795, 0xA797, undef, 0xA799, undef, 0xA79B, undef, 0xA79D, undef, 0xA79F, undef, 0xA7A1, undef, 0xA7A3, undef, 0xA7A5, undef, 0xA7A7, undef, 0xA7A9, undef, 0xA7B5, undef, 0xA7B7, undef, 0xA7F7, undef, 0xA7FA, 0xA82B, 0xA830, 0xA839, 0xA840, 0xA877, 0xA880, 0xA8C5, 0xA8CE, 0xA8D9, 0xA8E0, 0xA8FD, 0xA900, 0xA953, 0xA95F, 0xA97C, 0xA980, 0xA9CD, 0xA9CF, 0xA9D9, 0xA9DE, 0xA9FE, 0xAA00, 0xAA36, 0xAA40, 0xAA4D, 0xAA50, 0xAA59, 0xAA5C, 0xAAC2, 0xAADB, 0xAAF6, 0xAB01, 0xAB06, 0xAB09, 0xAB0E, 0xAB11, 0xAB16, 0xAB20, 0xAB26, 0xAB28, 0xAB2E, 0xAB30, 0xAB5B, 0xAB60, 0xAB65, 0xABC0, 0xABED, 0xABF0, 0xABF9, 0xAC00, 0xD7A3, 0xD7B0, 0xD7C6, 0xD7CB, 0xD7FB, 0xFA0E, 0xFA0F, 0xFA11, undef, 0xFA13, 0xFA14, 0xFA1F, undef, 0xFA21, undef, 0xFA23, 0xFA24, 0xFA27, 0xFA29, 0xFB1E, undef, 0xFBB2, 0xFBC1, 0xFD3E, 0xFD3F, 0xFDFD, undef, 0xFE20, 0xFE2F, 0xFE45, 0xFE46, 0xFE73, undef, 0x10000, 0x1000B, 0x1000D, 0x10026, 0x10028, 0x1003A, 0x1003C, 0x1003D, 0x1003F, 0x1004D, 0x10050, 0x1005D, 0x10080, 0x100FA, 0x10100, 0x10102, 0x10107, 0x10133, 0x10137, 0x1018E, 0x10190, 0x1019B, 0x101A0, undef, 0x101D0, 0x101FD, 0x10280, 0x1029C, 0x102A0, 0x102D0, 0x102E0, 0x102FB, 0x10300, 0x10323, 0x1032D, 0x1034A, 0x10350, 0x1037A, 0x10380, 0x1039D, 0x1039F, 0x103C3, 0x103C8, 0x103D5, 0x10428, 0x1049D, 0x104A0, 0x104A9, 0x104D8, 0x104FB, 0x10500, 0x10527, 0x10530, 0x10563, 0x1056F, undef, 0x10600, 0x10736, 0x10740, 0x10755, 0x10760, 0x10767, 0x10800, 0x10805, 0x10808, undef, 0x1080A, 0x10835, 0x10837, 0x10838, 0x1083C, undef, 0x1083F, 0x10855, 0x10857, 0x1089E, 0x108A7, 0x108AF, 0x108E0, 0x108F2, 0x108F4, 0x108F5, 0x108FB, 0x1091B, 0x1091F, 0x10939, 0x1093F, undef, 0x10980, 0x109B7, 0x109BC, 0x109CF, 0x109D2, 0x10A03, 0x10A05, 0x10A06, 0x10A0C, 0x10A13, 0x10A15, 0x10A17, 0x10A19, 0x10A33, 0x10A38, 0x10A3A, 0x10A3F, 0x10A47, 0x10A50, 0x10A58, 0x10A60, 0x10A9F, 0x10AC0, 0x10AE6, 0x10AEB, 0x10AF6, 0x10B00, 0x10B35, 0x10B39, 0x10B55, 0x10B58, 0x10B72, 0x10B78, 0x10B91, 0x10B99, 0x10B9C, 0x10BA9, 0x10BAF, 0x10C00, 0x10C48, 0x10CC0, 0x10CF2, 0x10CFA, 0x10CFF, 0x10E60, 0x10E7E, 0x11000, 0x1104D, 0x11052, 0x1106F, 0x1107F, 0x110BC, 0x110BE, 0x110C1, 0x110D0, 0x110E8, 0x110F0, 0x110F9, 0x11100, 0x11134, 0x11136, 0x11143, 0x11150, 0x11176, 0x11180, 0x111CD, 0x111D0, 0x111DF, 0x111E1, 0x111F4, 0x11200, 0x11211, 0x11213, 0x1123E, 0x11280, 0x11286, 0x11288, undef, 0x1128A, 0x1128D, 0x1128F, 0x1129D, 0x1129F, 0x112A9, 0x112B0, 0x112EA, 0x112F0, 0x112F9, 0x11300, 0x11303, 0x11305, 0x1130C, 0x1130F, 0x11310, 0x11313, 0x11328, 0x1132A, 0x11330, 0x11332, 0x11333, 0x11335, 0x11339, 0x1133C, 0x11344, 0x11347, 0x11348, 0x1134B, 0x1134D, 0x11350, undef, 0x11357, undef, 0x1135D, 0x11363, 0x11366, 0x1136C, 0x11370, 0x11374, 0x11400, 0x11459, 0x1145B, undef, 0x1145D, undef, 0x11480, 0x114C7, 0x114D0, 0x114D9, 0x11580, 0x115B5, 0x115B8, 0x115DD, 0x11600, 0x11644, 0x11650, 0x11659, 0x11660, 0x1166C, 0x11680, 0x116B7, 0x116C0, 0x116C9, 0x11700, 0x11719, 0x1171D, 0x1172B, 0x11730, 0x1173F, 0x118C0, 0x118F2, 0x118FF, undef, 0x11A00, 0x11A47, 0x11A50, 0x11A83, 0x11A86, 0x11A9C, 0x11A9E, 0x11AA2, 0x11AC0, 0x11AF8, 0x11C00, 0x11C08, 0x11C0A, 0x11C36, 0x11C38, 0x11C45, 0x11C50, 0x11C6C, 0x11C70, 0x11C8F, 0x11C92, 0x11CA7, 0x11CA9, 0x11CB6, 0x11D00, 0x11D06, 0x11D08, 0x11D09, 0x11D0B, 0x11D36, 0x11D3A, undef, 0x11D3C, 0x11D3D, 0x11D3F, 0x11D47, 0x11D50, 0x11D59, 0x12000, 0x12399, 0x12400, 0x1246E, 0x12470, 0x12474, 0x12480, 0x12543, 0x13000, 0x1342E, 0x14400, 0x14646, 0x16800, 0x16A38, 0x16A40, 0x16A5E, 0x16A60, 0x16A69, 0x16A6E, 0x16A6F, 0x16AD0, 0x16AED, 0x16AF0, 0x16AF5, 0x16B00, 0x16B45, 0x16B50, 0x16B59, 0x16B5B, 0x16B61, 0x16B63, 0x16B77, 0x16B7D, 0x16B8F, 0x16F00, 0x16F44, 0x16F50, 0x16F7E, 0x16F8F, 0x16F9F, 0x16FE0, 0x16FE1, 0x17000, 0x187EC, 0x18800, 0x18AF2, 0x1B000, 0x1B11E, 0x1B170, 0x1B2FB, 0x1BC00, 0x1BC6A, 0x1BC70, 0x1BC7C, 0x1BC80, 0x1BC88, 0x1BC90, 0x1BC99, 0x1BC9C, 0x1BC9F, 0x1D000, 0x1D0F5, 0x1D100, 0x1D126, 0x1D129, 0x1D15D, 0x1D165, 0x1D172, 0x1D17B, 0x1D1BA, 0x1D1C1, 0x1D1E8, 0x1D200, 0x1D245, 0x1D300, 0x1D356, 0x1D360, 0x1D371, 0x1D800, 0x1DA8B, 0x1DA9B, 0x1DA9F, 0x1DAA1, 0x1DAAF, 0x1E000, 0x1E006, 0x1E008, 0x1E018, 0x1E01B, 0x1E021, 0x1E023, 0x1E024, 0x1E026, 0x1E02A, 0x1E800, 0x1E8C4, 0x1E8C7, 0x1E8D6, 0x1E922, 0x1E94A, 0x1E950, 0x1E959, 0x1E95E, 0x1E95F, 0x1EEF0, 0x1EEF1, 0x1F000, 0x1F02B, 0x1F030, 0x1F093, 0x1F0A0, 0x1F0AE, 0x1F0B1, 0x1F0BF, 0x1F0C1, 0x1F0CF, 0x1F0D1, 0x1F0F5, 0x1F10B, 0x1F10C, 0x1F150, 0x1F169, 0x1F170, 0x1F18F, 0x1F191, 0x1F1AC, 0x1F1E6, 0x1F1FF, 0x1F260, 0x1F265, 0x1F300, 0x1F6D4, 0x1F6E0, 0x1F6EC, 0x1F6F0, 0x1F6F8, 0x1F700, 0x1F773, 0x1F780, 0x1F7D4, 0x1F800, 0x1F80B, 0x1F810, 0x1F847, 0x1F850, 0x1F859, 0x1F860, 0x1F887, 0x1F890, 0x1F8AD, 0x1F900, 0x1F90B, 0x1F910, 0x1F93E, 0x1F940, 0x1F94C, 0x1F950, 0x1F96B, 0x1F980, 0x1F997, 0x1F9C0, undef, 0x1F9D0, 0x1F9E6, 0x20000, 0x2A6D6, 0x2A700, 0x2B734, 0x2B740, 0x2B81D, 0x2B820, 0x2CEA1, 0x2CEB0, 0x2EBE0, ); sub IsValid { return _mk_prop(@VALID); }; our @_DISALLOWEDASSIGNED = ( 0x0080, 0x009F, 0x04C0, undef, 0x0600, 0x0605, 0x061C, undef, 0x06DD, undef, 0x070F, undef, 0x08E2, undef, 0x10A0, 0x10C5, 0x115F, 0x1160, 0x1680, undef, 0x17B4, 0x17B5, 0x1806, undef, 0x180E, undef, 0x200E, 0x200F, 0x2024, 0x2026, 0x2028, 0x202E, 0x2061, 0x2063, 0x2066, 0x206F, 0x2132, undef, 0x2183, undef, 0x2488, 0x249B, 0x2FF0, 0x2FFB, 0x3164, undef, 0x33C2, undef, 0x33C7, undef, 0x33D8, undef, 0xD800, 0xF8FF, 0xFDD0, 0xFDEF, 0xFE12, undef, 0xFE19, undef, 0xFE30, undef, 0xFE52, undef, 0xFFA0, undef, 0xFFF9, 0xFFFF, 0x110BD, undef, 0x1D173, 0x1D17A, 0x1F100, undef, 0x1FFFE, 0x1FFFF, 0x2F868, undef, 0x2F874, undef, 0x2F91F, undef, 0x2F95F, undef, 0x2F9BF, undef, 0x2FFFE, 0x2FFFF, 0x3FFFE, 0x3FFFF, 0x4FFFE, 0x4FFFF, 0x5FFFE, 0x5FFFF, 0x6FFFE, 0x6FFFF, 0x7FFFE, 0x7FFFF, 0x8FFFE, 0x8FFFF, 0x9FFFE, 0x9FFFF, 0xAFFFE, 0xAFFFF, 0xBFFFE, 0xBFFFF, 0xCFFFE, 0xCFFFF, 0xDFFFE, 0xDFFFF, 0xE0001, undef, 0xE0020, 0xE007F, 0xEFFFE, 0x10FFFF, ); sub Is_DisallowedAssigned { return _mk_prop(@_DISALLOWEDASSIGNED); }; our %DEVIATION = ( 0x00DF => "ss", 0x03C2 => "σ", 0x200C => "", 0x200D => "",); our @DEVIATION = ( 0x00DF, undef, 0x03C2, undef, 0x200C, 0x200D, ); sub IsDeviation { return _mk_prop(@DEVIATION); }; sub MapDeviation { my $l = shift; $l =~ s/[\x{200C}\x{200D}]//g; $l =~ s/ß/ss/g; $l =~ s/ς/σ/g; return $l; }; our %DISALLOWEDSTD3MAPPED = ( 0x00A0 => " ", 0x00A8 => " \x{0308}", 0x00AF => " \x{0304}", 0x00B4 => " \x{0301}", 0x00B8 => " \x{0327}", 0x02D8 => " \x{0306}", 0x02D9 => " \x{0307}", 0x02DA => " \x{030A}", 0x02DB => " \x{0328}", 0x02DC => " \x{0303}", 0x02DD => " \x{030B}", 0x037A => " ι", 0x037E => "\;", 0x0384 => " \x{0301}", 0x0385 => " \x{0308}\x{0301}", 0x1FBD => " \x{0313}", 0x1FBF => " \x{0313}", 0x1FC0 => " \x{0342}", 0x1FC1 => " \x{0308}\x{0342}", 0x1FCD => " \x{0313}\x{0300}", 0x1FCE => " \x{0313}\x{0301}", 0x1FCF => " \x{0313}\x{0342}", 0x1FDD => " \x{0314}\x{0300}", 0x1FDE => " \x{0314}\x{0301}", 0x1FDF => " \x{0314}\x{0342}", 0x1FED => " \x{0308}\x{0300}", 0x1FEE => " \x{0308}\x{0301}", 0x1FEF => "\`", 0x1FFD => " \x{0301}", 0x1FFE => " \x{0314}", 0x2000 => " ", 0x2001 => " ", 0x2002 => " ", 0x2003 => " ", 0x2004 => " ", 0x2005 => " ", 0x2006 => " ", 0x2007 => " ", 0x2008 => " ", 0x2009 => " ", 0x200A => " ", 0x2017 => " \x{0333}", 0x202F => " ", 0x203C => "\!\!", 0x203E => " \x{0305}", 0x2047 => "\?\?", 0x2048 => "\?\!", 0x2049 => "\!\?", 0x205F => " ", 0x207A => "\+", 0x207C => "\=", 0x207D => "\(", 0x207E => "\)", 0x208A => "\+", 0x208C => "\=", 0x208D => "\(", 0x208E => "\)", 0x2100 => "a\/c", 0x2101 => "a\/s", 0x2105 => "c\/o", 0x2106 => "c\/u", 0x2474 => "\(1\)", 0x2475 => "\(2\)", 0x2476 => "\(3\)", 0x2477 => "\(4\)", 0x2478 => "\(5\)", 0x2479 => "\(6\)", 0x247A => "\(7\)", 0x247B => "\(8\)", 0x247C => "\(9\)", 0x247D => "\(10\)", 0x247E => "\(11\)", 0x247F => "\(12\)", 0x2480 => "\(13\)", 0x2481 => "\(14\)", 0x2482 => "\(15\)", 0x2483 => "\(16\)", 0x2484 => "\(17\)", 0x2485 => "\(18\)", 0x2486 => "\(19\)", 0x2487 => "\(20\)", 0x249C => "\(a\)", 0x249D => "\(b\)", 0x249E => "\(c\)", 0x249F => "\(d\)", 0x24A0 => "\(e\)", 0x24A1 => "\(f\)", 0x24A2 => "\(g\)", 0x24A3 => "\(h\)", 0x24A4 => "\(i\)", 0x24A5 => "\(j\)", 0x24A6 => "\(k\)", 0x24A7 => "\(l\)", 0x24A8 => "\(m\)", 0x24A9 => "\(n\)", 0x24AA => "\(o\)", 0x24AB => "\(p\)", 0x24AC => "\(q\)", 0x24AD => "\(r\)", 0x24AE => "\(s\)", 0x24AF => "\(t\)", 0x24B0 => "\(u\)", 0x24B1 => "\(v\)", 0x24B2 => "\(w\)", 0x24B3 => "\(x\)", 0x24B4 => "\(y\)", 0x24B5 => "\(z\)", 0x2A74 => "\:\:\=", 0x2A75 => "\=\=", 0x2A76 => "\=\=\=", 0x3000 => " ", 0x309B => " \x{3099}", 0x309C => " \x{309A}", 0x3200 => "\(ᄀ\)", 0x3201 => "\(ᄂ\)", 0x3202 => "\(ᄃ\)", 0x3203 => "\(ᄅ\)", 0x3204 => "\(ᄆ\)", 0x3205 => "\(ᄇ\)", 0x3206 => "\(ᄉ\)", 0x3207 => "\(ᄋ\)", 0x3208 => "\(ᄌ\)", 0x3209 => "\(ᄎ\)", 0x320A => "\(ᄏ\)", 0x320B => "\(ᄐ\)", 0x320C => "\(ᄑ\)", 0x320D => "\(ᄒ\)", 0x320E => "\(가\)", 0x320F => "\(나\)", 0x3210 => "\(다\)", 0x3211 => "\(라\)", 0x3212 => "\(마\)", 0x3213 => "\(바\)", 0x3214 => "\(사\)", 0x3215 => "\(아\)", 0x3216 => "\(자\)", 0x3217 => "\(차\)", 0x3218 => "\(카\)", 0x3219 => "\(타\)", 0x321A => "\(파\)", 0x321B => "\(하\)", 0x321C => "\(주\)", 0x321D => "\(오전\)", 0x321E => "\(오후\)", 0x3220 => "\(一\)", 0x3221 => "\(二\)", 0x3222 => "\(三\)", 0x3223 => "\(四\)", 0x3224 => "\(五\)", 0x3225 => "\(六\)", 0x3226 => "\(七\)", 0x3227 => "\(八\)", 0x3228 => "\(九\)", 0x3229 => "\(十\)", 0x322A => "\(月\)", 0x322B => "\(火\)", 0x322C => "\(水\)", 0x322D => "\(木\)", 0x322E => "\(金\)", 0x322F => "\(土\)", 0x3230 => "\(日\)", 0x3231 => "\(株\)", 0x3232 => "\(有\)", 0x3233 => "\(社\)", 0x3234 => "\(名\)", 0x3235 => "\(特\)", 0x3236 => "\(財\)", 0x3237 => "\(祝\)", 0x3238 => "\(労\)", 0x3239 => "\(代\)", 0x323A => "\(呼\)", 0x323B => "\(学\)", 0x323C => "\(監\)", 0x323D => "\(企\)", 0x323E => "\(資\)", 0x323F => "\(協\)", 0x3240 => "\(祭\)", 0x3241 => "\(休\)", 0x3242 => "\(自\)", 0x3243 => "\(至\)", 0xFB29 => "\+", 0xFC5E => " ٌّ", 0xFC5F => " ٍّ", 0xFC60 => " َّ", 0xFC61 => " ُّ", 0xFC62 => " ِّ", 0xFC63 => " ّٰ", 0xFDFA => "صلى الله عليه وسلم", 0xFDFB => "جل جلاله", 0xFE10 => "\,", 0xFE13 => "\:", 0xFE14 => "\;", 0xFE15 => "\!", 0xFE16 => "\?", 0xFE33 => "_", 0xFE34 => "_", 0xFE35 => "\(", 0xFE36 => "\)", 0xFE37 => "\{", 0xFE38 => "\}", 0xFE47 => "\[", 0xFE48 => "\]", 0xFE49 => " \x{0305}", 0xFE4A => " \x{0305}", 0xFE4B => " \x{0305}", 0xFE4C => " \x{0305}", 0xFE4D => "_", 0xFE4E => "_", 0xFE4F => "_", 0xFE50 => "\,", 0xFE54 => "\;", 0xFE55 => "\:", 0xFE56 => "\?", 0xFE57 => "\!", 0xFE59 => "\(", 0xFE5A => "\)", 0xFE5B => "\{", 0xFE5C => "\}", 0xFE5F => "\#", 0xFE60 => "\&", 0xFE61 => "\*", 0xFE62 => "\+", 0xFE64 => "\<", 0xFE65 => "\>", 0xFE66 => "\=", 0xFE68 => "\\", 0xFE69 => "\$", 0xFE6A => "\%", 0xFE6B => "\@", 0xFE70 => " ً", 0xFE72 => " ٌ", 0xFE74 => " ٍ", 0xFE76 => " َ", 0xFE78 => " ُ", 0xFE7A => " ِ", 0xFE7C => " ّ", 0xFE7E => " ْ", 0xFF01 => "\!", 0xFF02 => "\"", 0xFF03 => "\#", 0xFF04 => "\$", 0xFF05 => "\%", 0xFF06 => "\&", 0xFF07 => "\'", 0xFF08 => "\(", 0xFF09 => "\)", 0xFF0A => "\*", 0xFF0B => "\+", 0xFF0C => "\,", 0xFF0F => "\/", 0xFF1A => "\:", 0xFF1B => "\;", 0xFF1C => "\<", 0xFF1D => "\=", 0xFF1E => "\>", 0xFF1F => "\?", 0xFF20 => "\@", 0xFF3B => "\[", 0xFF3C => "\\", 0xFF3D => "\]", 0xFF3E => "\^", 0xFF3F => "_", 0xFF40 => "\`", 0xFF5B => "\{", 0xFF5C => "\|", 0xFF5D => "\}", 0xFF5E => "\~", 0xFFE3 => " \x{0304}", 0x1F101 => "0\,", 0x1F102 => "1\,", 0x1F103 => "2\,", 0x1F104 => "3\,", 0x1F105 => "4\,", 0x1F106 => "5\,", 0x1F107 => "6\,", 0x1F108 => "7\,", 0x1F109 => "8\,", 0x1F10A => "9\,", 0x1F110 => "\(a\)", 0x1F111 => "\(b\)", 0x1F112 => "\(c\)", 0x1F113 => "\(d\)", 0x1F114 => "\(e\)", 0x1F115 => "\(f\)", 0x1F116 => "\(g\)", 0x1F117 => "\(h\)", 0x1F118 => "\(i\)", 0x1F119 => "\(j\)", 0x1F11A => "\(k\)", 0x1F11B => "\(l\)", 0x1F11C => "\(m\)", 0x1F11D => "\(n\)", 0x1F11E => "\(o\)", 0x1F11F => "\(p\)", 0x1F120 => "\(q\)", 0x1F121 => "\(r\)", 0x1F122 => "\(s\)", 0x1F123 => "\(t\)", 0x1F124 => "\(u\)", 0x1F125 => "\(v\)", 0x1F126 => "\(w\)", 0x1F127 => "\(x\)", 0x1F128 => "\(y\)", 0x1F129 => "\(z\)",); our @DISALLOWEDSTD3MAPPED = ( 0x00A0, undef, 0x00A8, undef, 0x00AF, undef, 0x00B4, undef, 0x00B8, undef, 0x02D8, 0x02DD, 0x037A, undef, 0x037E, undef, 0x0384, 0x0385, 0x1FBD, undef, 0x1FBF, 0x1FC1, 0x1FCD, 0x1FCF, 0x1FDD, 0x1FDF, 0x1FED, 0x1FEF, 0x1FFD, 0x1FFE, 0x2000, 0x200A, 0x2017, undef, 0x202F, undef, 0x203C, undef, 0x203E, undef, 0x2047, 0x2049, 0x205F, undef, 0x207A, undef, 0x207C, 0x207E, 0x208A, undef, 0x208C, 0x208E, 0x2100, 0x2101, 0x2105, 0x2106, 0x2474, 0x2487, 0x249C, 0x24B5, 0x2A74, 0x2A76, 0x3000, undef, 0x309B, 0x309C, 0x3200, 0x321E, 0x3220, 0x3243, 0xFB29, undef, 0xFC5E, 0xFC63, 0xFDFA, 0xFDFB, 0xFE10, undef, 0xFE13, 0xFE16, 0xFE33, 0xFE38, 0xFE47, 0xFE50, 0xFE54, 0xFE57, 0xFE59, 0xFE5C, 0xFE5F, 0xFE62, 0xFE64, 0xFE66, 0xFE68, 0xFE6B, 0xFE70, undef, 0xFE72, undef, 0xFE74, undef, 0xFE76, undef, 0xFE78, undef, 0xFE7A, undef, 0xFE7C, undef, 0xFE7E, undef, 0xFF01, 0xFF0C, 0xFF0F, undef, 0xFF1A, 0xFF20, 0xFF3B, 0xFF40, 0xFF5B, 0xFF5E, 0xFFE3, undef, 0x1F101, 0x1F10A, 0x1F110, 0x1F129, ); sub IsDisallowedSTD3Mapped { return _mk_prop(@DISALLOWEDSTD3MAPPED); }; sub MapDisallowedSTD3Mapped { my $l = shift; $l =~ tr/\x{00A0}\x{037E}\x{1FEF}\x{2000}\x{2001}\x{2002}\x{2003}\x{2004}\x{2005}\x{2006}\x{2007}\x{2008}\x{2009}\x{200A}\x{202F}\x{205F}\x{207A}\x{207C}\x{207D}\x{207E}\x{208A}\x{208C}\x{208D}\x{208E}\x{3000}\x{FB29}\x{FE10}\x{FE13}\x{FE14}\x{FE15}\x{FE16}\x{FE33}\x{FE34}\x{FE35}\x{FE36}\x{FE37}\x{FE38}\x{FE47}\x{FE48}\x{FE4D}\x{FE4E}\x{FE4F}\x{FE50}\x{FE54}\x{FE55}\x{FE56}\x{FE57}\x{FE59}\x{FE5A}\x{FE5B}\x{FE5C}\x{FE5F}\x{FE60}\x{FE61}\x{FE62}\x{FE64}\x{FE65}\x{FE66}\x{FE68}\x{FE69}\x{FE6A}\x{FE6B}\x{FF01}\x{FF02}\x{FF03}\x{FF04}\x{FF05}\x{FF06}\x{FF07}\x{FF08}\x{FF09}\x{FF0A}\x{FF0B}\x{FF0C}\x{FF0F}\x{FF1A}\x{FF1B}\x{FF1C}\x{FF1D}\x{FF1E}\x{FF1F}\x{FF20}\x{FF3B}\x{FF3C}\x{FF3D}\x{FF3E}\x{FF3F}\x{FF40}\x{FF5B}\x{FF5C}\x{FF5D}\x{FF5E}/ \;\` \+\=\(\)\+\=\(\) \+\,\:\;\!\?__\(\)\{\}\[\]___\,\;\:\?\!\(\)\{\}\#\&\*\+\<\>\=\\\$\%\@\!\"\#\$\%\&\'\(\)\*\+\,\/\:\;\<\=\>\?\@\[\\\]\^_\`\{\|\}\~/; $l =~ s/([\x{00A8}\x{00AF}\x{00B4}\x{00B8}\x{02D8}\x{02D9}\x{02DA}\x{02DB}\x{02DC}\x{02DD}ͺ\x{0384}\x{0385}\x{1FBD}\x{1FBF}\x{1FC0}\x{1FC1}\x{1FCD}\x{1FCE}\x{1FCF}\x{1FDD}\x{1FDE}\x{1FDF}\x{1FED}\x{1FEE}\x{1FFD}\x{1FFE}\x{2017}\x{203C}\x{203E}\x{2047}\x{2048}\x{2049}\x{2100}\x{2101}\x{2105}\x{2106}\x{2474}\x{2475}\x{2476}\x{2477}\x{2478}\x{2479}\x{247A}\x{247B}\x{247C}\x{247D}\x{247E}\x{247F}\x{2480}\x{2481}\x{2482}\x{2483}\x{2484}\x{2485}\x{2486}\x{2487}\x{249C}\x{249D}\x{249E}\x{249F}\x{24A0}\x{24A1}\x{24A2}\x{24A3}\x{24A4}\x{24A5}\x{24A6}\x{24A7}\x{24A8}\x{24A9}\x{24AA}\x{24AB}\x{24AC}\x{24AD}\x{24AE}\x{24AF}\x{24B0}\x{24B1}\x{24B2}\x{24B3}\x{24B4}\x{24B5}\x{2A74}\x{2A75}\x{2A76}\x{309B}\x{309C}\x{3200}\x{3201}\x{3202}\x{3203}\x{3204}\x{3205}\x{3206}\x{3207}\x{3208}\x{3209}\x{320A}\x{320B}\x{320C}\x{320D}\x{320E}\x{320F}\x{3210}\x{3211}\x{3212}\x{3213}\x{3214}\x{3215}\x{3216}\x{3217}\x{3218}\x{3219}\x{321A}\x{321B}\x{321C}\x{321D}\x{321E}\x{3220}\x{3221}\x{3222}\x{3223}\x{3224}\x{3225}\x{3226}\x{3227}\x{3228}\x{3229}\x{322A}\x{322B}\x{322C}\x{322D}\x{322E}\x{322F}\x{3230}\x{3231}\x{3232}\x{3233}\x{3234}\x{3235}\x{3236}\x{3237}\x{3238}\x{3239}\x{323A}\x{323B}\x{323C}\x{323D}\x{323E}\x{323F}\x{3240}\x{3241}\x{3242}\x{3243}ﱞﱟﱠﱡﱢﱣﷺﷻ\x{FE49}\x{FE4A}\x{FE4B}\x{FE4C}ﹰﹲﹴﹶﹸﹺﹼﹾ\x{FFE3}\x{1F101}\x{1F102}\x{1F103}\x{1F104}\x{1F105}\x{1F106}\x{1F107}\x{1F108}\x{1F109}\x{1F10A}\x{1F110}\x{1F111}\x{1F112}\x{1F113}\x{1F114}\x{1F115}\x{1F116}\x{1F117}\x{1F118}\x{1F119}\x{1F11A}\x{1F11B}\x{1F11C}\x{1F11D}\x{1F11E}\x{1F11F}\x{1F120}\x{1F121}\x{1F122}\x{1F123}\x{1F124}\x{1F125}\x{1F126}\x{1F127}\x{1F128}\x{1F129}])/$DISALLOWEDSTD3MAPPED{ord($1)}/eg; return $l; }; our %IGNORED = ( 0x00AD => "", 0x034F => "", 0x180B => "", 0x180C => "", 0x180D => "", 0x200B => "", 0x2060 => "", 0x2064 => "", 0xFE00 => "", 0xFE01 => "", 0xFE02 => "", 0xFE03 => "", 0xFE04 => "", 0xFE05 => "", 0xFE06 => "", 0xFE07 => "", 0xFE08 => "", 0xFE09 => "", 0xFE0A => "", 0xFE0B => "", 0xFE0C => "", 0xFE0D => "", 0xFE0E => "", 0xFE0F => "", 0xFEFF => "", 0x1BCA0 => "", 0x1BCA1 => "", 0x1BCA2 => "", 0x1BCA3 => "", 0xE0100 => "", 0xE0101 => "", 0xE0102 => "", 0xE0103 => "", 0xE0104 => "", 0xE0105 => "", 0xE0106 => "", 0xE0107 => "", 0xE0108 => "", 0xE0109 => "", 0xE010A => "", 0xE010B => "", 0xE010C => "", 0xE010D => "", 0xE010E => "", 0xE010F => "", 0xE0110 => "", 0xE0111 => "", 0xE0112 => "", 0xE0113 => "", 0xE0114 => "", 0xE0115 => "", 0xE0116 => "", 0xE0117 => "", 0xE0118 => "", 0xE0119 => "", 0xE011A => "", 0xE011B => "", 0xE011C => "", 0xE011D => "", 0xE011E => "", 0xE011F => "", 0xE0120 => "", 0xE0121 => "", 0xE0122 => "", 0xE0123 => "", 0xE0124 => "", 0xE0125 => "", 0xE0126 => "", 0xE0127 => "", 0xE0128 => "", 0xE0129 => "", 0xE012A => "", 0xE012B => "", 0xE012C => "", 0xE012D => "", 0xE012E => "", 0xE012F => "", 0xE0130 => "", 0xE0131 => "", 0xE0132 => "", 0xE0133 => "", 0xE0134 => "", 0xE0135 => "", 0xE0136 => "", 0xE0137 => "", 0xE0138 => "", 0xE0139 => "", 0xE013A => "", 0xE013B => "", 0xE013C => "", 0xE013D => "", 0xE013E => "", 0xE013F => "", 0xE0140 => "", 0xE0141 => "", 0xE0142 => "", 0xE0143 => "", 0xE0144 => "", 0xE0145 => "", 0xE0146 => "", 0xE0147 => "", 0xE0148 => "", 0xE0149 => "", 0xE014A => "", 0xE014B => "", 0xE014C => "", 0xE014D => "", 0xE014E => "", 0xE014F => "", 0xE0150 => "", 0xE0151 => "", 0xE0152 => "", 0xE0153 => "", 0xE0154 => "", 0xE0155 => "", 0xE0156 => "", 0xE0157 => "", 0xE0158 => "", 0xE0159 => "", 0xE015A => "", 0xE015B => "", 0xE015C => "", 0xE015D => "", 0xE015E => "", 0xE015F => "", 0xE0160 => "", 0xE0161 => "", 0xE0162 => "", 0xE0163 => "", 0xE0164 => "", 0xE0165 => "", 0xE0166 => "", 0xE0167 => "", 0xE0168 => "", 0xE0169 => "", 0xE016A => "", 0xE016B => "", 0xE016C => "", 0xE016D => "", 0xE016E => "", 0xE016F => "", 0xE0170 => "", 0xE0171 => "", 0xE0172 => "", 0xE0173 => "", 0xE0174 => "", 0xE0175 => "", 0xE0176 => "", 0xE0177 => "", 0xE0178 => "", 0xE0179 => "", 0xE017A => "", 0xE017B => "", 0xE017C => "", 0xE017D => "", 0xE017E => "", 0xE017F => "", 0xE0180 => "", 0xE0181 => "", 0xE0182 => "", 0xE0183 => "", 0xE0184 => "", 0xE0185 => "", 0xE0186 => "", 0xE0187 => "", 0xE0188 => "", 0xE0189 => "", 0xE018A => "", 0xE018B => "", 0xE018C => "", 0xE018D => "", 0xE018E => "", 0xE018F => "", 0xE0190 => "", 0xE0191 => "", 0xE0192 => "", 0xE0193 => "", 0xE0194 => "", 0xE0195 => "", 0xE0196 => "", 0xE0197 => "", 0xE0198 => "", 0xE0199 => "", 0xE019A => "", 0xE019B => "", 0xE019C => "", 0xE019D => "", 0xE019E => "", 0xE019F => "", 0xE01A0 => "", 0xE01A1 => "", 0xE01A2 => "", 0xE01A3 => "", 0xE01A4 => "", 0xE01A5 => "", 0xE01A6 => "", 0xE01A7 => "", 0xE01A8 => "", 0xE01A9 => "", 0xE01AA => "", 0xE01AB => "", 0xE01AC => "", 0xE01AD => "", 0xE01AE => "", 0xE01AF => "", 0xE01B0 => "", 0xE01B1 => "", 0xE01B2 => "", 0xE01B3 => "", 0xE01B4 => "", 0xE01B5 => "", 0xE01B6 => "", 0xE01B7 => "", 0xE01B8 => "", 0xE01B9 => "", 0xE01BA => "", 0xE01BB => "", 0xE01BC => "", 0xE01BD => "", 0xE01BE => "", 0xE01BF => "", 0xE01C0 => "", 0xE01C1 => "", 0xE01C2 => "", 0xE01C3 => "", 0xE01C4 => "", 0xE01C5 => "", 0xE01C6 => "", 0xE01C7 => "", 0xE01C8 => "", 0xE01C9 => "", 0xE01CA => "", 0xE01CB => "", 0xE01CC => "", 0xE01CD => "", 0xE01CE => "", 0xE01CF => "", 0xE01D0 => "", 0xE01D1 => "", 0xE01D2 => "", 0xE01D3 => "", 0xE01D4 => "", 0xE01D5 => "", 0xE01D6 => "", 0xE01D7 => "", 0xE01D8 => "", 0xE01D9 => "", 0xE01DA => "", 0xE01DB => "", 0xE01DC => "", 0xE01DD => "", 0xE01DE => "", 0xE01DF => "", 0xE01E0 => "", 0xE01E1 => "", 0xE01E2 => "", 0xE01E3 => "", 0xE01E4 => "", 0xE01E5 => "", 0xE01E6 => "", 0xE01E7 => "", 0xE01E8 => "", 0xE01E9 => "", 0xE01EA => "", 0xE01EB => "", 0xE01EC => "", 0xE01ED => "", 0xE01EE => "", 0xE01EF => "",); our @IGNORED = ( 0x00AD, undef, 0x034F, undef, 0x180B, 0x180D, 0x200B, undef, 0x2060, undef, 0x2064, undef, 0xFE00, 0xFE0F, 0xFEFF, undef, 0x1BCA0, 0x1BCA3, 0xE0100, 0xE01EF, ); sub IsIgnored { return _mk_prop(@IGNORED); }; sub MapIgnored { my $l = shift; $l =~ s/\p{IsIgnored}//g; return $l; }; our %MAPPED = ( 0x0041 => "a", 0x0042 => "b", 0x0043 => "c", 0x0044 => "d", 0x0045 => "e", 0x0046 => "f", 0x0047 => "g", 0x0048 => "h", 0x0049 => "i", 0x004A => "j", 0x004B => "k", 0x004C => "l", 0x004D => "m", 0x004E => "n", 0x004F => "o", 0x0050 => "p", 0x0051 => "q", 0x0052 => "r", 0x0053 => "s", 0x0054 => "t", 0x0055 => "u", 0x0056 => "v", 0x0057 => "w", 0x0058 => "x", 0x0059 => "y", 0x005A => "z", 0x00AA => "a", 0x00B2 => "2", 0x00B3 => "3", 0x00B5 => "μ", 0x00B9 => "1", 0x00BA => "o", 0x00BC => "1\x{2044}4", 0x00BD => "1\x{2044}2", 0x00BE => "3\x{2044}4", 0x00C0 => "à", 0x00C1 => "á", 0x00C2 => "â", 0x00C3 => "ã", 0x00C4 => "ä", 0x00C5 => "å", 0x00C6 => "æ", 0x00C7 => "ç", 0x00C8 => "è", 0x00C9 => "é", 0x00CA => "ê", 0x00CB => "ë", 0x00CC => "ì", 0x00CD => "í", 0x00CE => "î", 0x00CF => "ï", 0x00D0 => "ð", 0x00D1 => "ñ", 0x00D2 => "ò", 0x00D3 => "ó", 0x00D4 => "ô", 0x00D5 => "õ", 0x00D6 => "ö", 0x00D8 => "ø", 0x00D9 => "ù", 0x00DA => "ú", 0x00DB => "û", 0x00DC => "ü", 0x00DD => "ý", 0x00DE => "þ", 0x0100 => "ā", 0x0102 => "ă", 0x0104 => "ą", 0x0106 => "ć", 0x0108 => "ĉ", 0x010A => "ċ", 0x010C => "č", 0x010E => "ď", 0x0110 => "đ", 0x0112 => "ē", 0x0114 => "ĕ", 0x0116 => "ė", 0x0118 => "ę", 0x011A => "ě", 0x011C => "ĝ", 0x011E => "ğ", 0x0120 => "ġ", 0x0122 => "ģ", 0x0124 => "ĥ", 0x0126 => "ħ", 0x0128 => "ĩ", 0x012A => "ī", 0x012C => "ĭ", 0x012E => "į", 0x0130 => "i\x{0307}", 0x0132 => "ij", 0x0133 => "ij", 0x0134 => "ĵ", 0x0136 => "ķ", 0x0139 => "ĺ", 0x013B => "ļ", 0x013D => "ľ", 0x013F => "l\x{00B7}", 0x0140 => "l\x{00B7}", 0x0141 => "ł", 0x0143 => "ń", 0x0145 => "ņ", 0x0147 => "ň", 0x0149 => "ʼn", 0x014A => "ŋ", 0x014C => "ō", 0x014E => "ŏ", 0x0150 => "ő", 0x0152 => "œ", 0x0154 => "ŕ", 0x0156 => "ŗ", 0x0158 => "ř", 0x015A => "ś", 0x015C => "ŝ", 0x015E => "ş", 0x0160 => "š", 0x0162 => "ţ", 0x0164 => "ť", 0x0166 => "ŧ", 0x0168 => "ũ", 0x016A => "ū", 0x016C => "ŭ", 0x016E => "ů", 0x0170 => "ű", 0x0172 => "ų", 0x0174 => "ŵ", 0x0176 => "ŷ", 0x0178 => "ÿ", 0x0179 => "ź", 0x017B => "ż", 0x017D => "ž", 0x017F => "s", 0x0181 => "ɓ", 0x0182 => "ƃ", 0x0184 => "ƅ", 0x0186 => "ɔ", 0x0187 => "ƈ", 0x0189 => "ɖ", 0x018A => "ɗ", 0x018B => "ƌ", 0x018E => "ǝ", 0x018F => "ə", 0x0190 => "ɛ", 0x0191 => "ƒ", 0x0193 => "ɠ", 0x0194 => "ɣ", 0x0196 => "ɩ", 0x0197 => "ɨ", 0x0198 => "ƙ", 0x019C => "ɯ", 0x019D => "ɲ", 0x019F => "ɵ", 0x01A0 => "ơ", 0x01A2 => "ƣ", 0x01A4 => "ƥ", 0x01A6 => "ʀ", 0x01A7 => "ƨ", 0x01A9 => "ʃ", 0x01AC => "ƭ", 0x01AE => "ʈ", 0x01AF => "ư", 0x01B1 => "ʊ", 0x01B2 => "ʋ", 0x01B3 => "ƴ", 0x01B5 => "ƶ", 0x01B7 => "ʒ", 0x01B8 => "ƹ", 0x01BC => "ƽ", 0x01C4 => "dž", 0x01C5 => "dž", 0x01C6 => "dž", 0x01C7 => "lj", 0x01C8 => "lj", 0x01C9 => "lj", 0x01CA => "nj", 0x01CB => "nj", 0x01CC => "nj", 0x01CD => "ǎ", 0x01CF => "ǐ", 0x01D1 => "ǒ", 0x01D3 => "ǔ", 0x01D5 => "ǖ", 0x01D7 => "ǘ", 0x01D9 => "ǚ", 0x01DB => "ǜ", 0x01DE => "ǟ", 0x01E0 => "ǡ", 0x01E2 => "ǣ", 0x01E4 => "ǥ", 0x01E6 => "ǧ", 0x01E8 => "ǩ", 0x01EA => "ǫ", 0x01EC => "ǭ", 0x01EE => "ǯ", 0x01F1 => "dz", 0x01F2 => "dz", 0x01F3 => "dz", 0x01F4 => "ǵ", 0x01F6 => "ƕ", 0x01F7 => "ƿ", 0x01F8 => "ǹ", 0x01FA => "ǻ", 0x01FC => "ǽ", 0x01FE => "ǿ", 0x0200 => "ȁ", 0x0202 => "ȃ", 0x0204 => "ȅ", 0x0206 => "ȇ", 0x0208 => "ȉ", 0x020A => "ȋ", 0x020C => "ȍ", 0x020E => "ȏ", 0x0210 => "ȑ", 0x0212 => "ȓ", 0x0214 => "ȕ", 0x0216 => "ȗ", 0x0218 => "ș", 0x021A => "ț", 0x021C => "ȝ", 0x021E => "ȟ", 0x0220 => "ƞ", 0x0222 => "ȣ", 0x0224 => "ȥ", 0x0226 => "ȧ", 0x0228 => "ȩ", 0x022A => "ȫ", 0x022C => "ȭ", 0x022E => "ȯ", 0x0230 => "ȱ", 0x0232 => "ȳ", 0x023A => "ⱥ", 0x023B => "ȼ", 0x023D => "ƚ", 0x023E => "ⱦ", 0x0241 => "ɂ", 0x0243 => "ƀ", 0x0244 => "ʉ", 0x0245 => "ʌ", 0x0246 => "ɇ", 0x0248 => "ɉ", 0x024A => "ɋ", 0x024C => "ɍ", 0x024E => "ɏ", 0x02B0 => "h", 0x02B1 => "ɦ", 0x02B2 => "j", 0x02B3 => "r", 0x02B4 => "ɹ", 0x02B5 => "ɻ", 0x02B6 => "ʁ", 0x02B7 => "w", 0x02B8 => "y", 0x02E0 => "ɣ", 0x02E1 => "l", 0x02E2 => "s", 0x02E3 => "x", 0x02E4 => "ʕ", 0x0340 => "\x{0300}", 0x0341 => "\x{0301}", 0x0343 => "\x{0313}", 0x0344 => "\x{0308}\x{0301}", 0x0345 => "ι", 0x0370 => "ͱ", 0x0372 => "ͳ", 0x0374 => "ʹ", 0x0376 => "ͷ", 0x037F => "ϳ", 0x0386 => "ά", 0x0387 => "\x{00B7}", 0x0388 => "έ", 0x0389 => "ή", 0x038A => "ί", 0x038C => "ό", 0x038E => "ύ", 0x038F => "ώ", 0x0391 => "α", 0x0392 => "β", 0x0393 => "γ", 0x0394 => "δ", 0x0395 => "ε", 0x0396 => "ζ", 0x0397 => "η", 0x0398 => "θ", 0x0399 => "ι", 0x039A => "κ", 0x039B => "λ", 0x039C => "μ", 0x039D => "ν", 0x039E => "ξ", 0x039F => "ο", 0x03A0 => "π", 0x03A1 => "ρ", 0x03A3 => "σ", 0x03A4 => "τ", 0x03A5 => "υ", 0x03A6 => "φ", 0x03A7 => "χ", 0x03A8 => "ψ", 0x03A9 => "ω", 0x03AA => "ϊ", 0x03AB => "ϋ", 0x03CF => "ϗ", 0x03D0 => "β", 0x03D1 => "θ", 0x03D2 => "υ", 0x03D3 => "ύ", 0x03D4 => "ϋ", 0x03D5 => "φ", 0x03D6 => "π", 0x03D8 => "ϙ", 0x03DA => "ϛ", 0x03DC => "ϝ", 0x03DE => "ϟ", 0x03E0 => "ϡ", 0x03E2 => "ϣ", 0x03E4 => "ϥ", 0x03E6 => "ϧ", 0x03E8 => "ϩ", 0x03EA => "ϫ", 0x03EC => "ϭ", 0x03EE => "ϯ", 0x03F0 => "κ", 0x03F1 => "ρ", 0x03F2 => "σ", 0x03F4 => "θ", 0x03F5 => "ε", 0x03F7 => "ϸ", 0x03F9 => "σ", 0x03FA => "ϻ", 0x03FD => "ͻ", 0x03FE => "ͼ", 0x03FF => "ͽ", 0x0400 => "ѐ", 0x0401 => "ё", 0x0402 => "ђ", 0x0403 => "ѓ", 0x0404 => "є", 0x0405 => "ѕ", 0x0406 => "і", 0x0407 => "ї", 0x0408 => "ј", 0x0409 => "љ", 0x040A => "њ", 0x040B => "ћ", 0x040C => "ќ", 0x040D => "ѝ", 0x040E => "ў", 0x040F => "џ", 0x0410 => "а", 0x0411 => "б", 0x0412 => "в", 0x0413 => "г", 0x0414 => "д", 0x0415 => "е", 0x0416 => "ж", 0x0417 => "з", 0x0418 => "и", 0x0419 => "й", 0x041A => "к", 0x041B => "л", 0x041C => "м", 0x041D => "н", 0x041E => "о", 0x041F => "п", 0x0420 => "р", 0x0421 => "с", 0x0422 => "т", 0x0423 => "у", 0x0424 => "ф", 0x0425 => "х", 0x0426 => "ц", 0x0427 => "ч", 0x0428 => "ш", 0x0429 => "щ", 0x042A => "ъ", 0x042B => "ы", 0x042C => "ь", 0x042D => "э", 0x042E => "ю", 0x042F => "я", 0x0460 => "ѡ", 0x0462 => "ѣ", 0x0464 => "ѥ", 0x0466 => "ѧ", 0x0468 => "ѩ", 0x046A => "ѫ", 0x046C => "ѭ", 0x046E => "ѯ", 0x0470 => "ѱ", 0x0472 => "ѳ", 0x0474 => "ѵ", 0x0476 => "ѷ", 0x0478 => "ѹ", 0x047A => "ѻ", 0x047C => "ѽ", 0x047E => "ѿ", 0x0480 => "ҁ", 0x048A => "ҋ", 0x048C => "ҍ", 0x048E => "ҏ", 0x0490 => "ґ", 0x0492 => "ғ", 0x0494 => "ҕ", 0x0496 => "җ", 0x0498 => "ҙ", 0x049A => "қ", 0x049C => "ҝ", 0x049E => "ҟ", 0x04A0 => "ҡ", 0x04A2 => "ң", 0x04A4 => "ҥ", 0x04A6 => "ҧ", 0x04A8 => "ҩ", 0x04AA => "ҫ", 0x04AC => "ҭ", 0x04AE => "ү", 0x04B0 => "ұ", 0x04B2 => "ҳ", 0x04B4 => "ҵ", 0x04B6 => "ҷ", 0x04B8 => "ҹ", 0x04BA => "һ", 0x04BC => "ҽ", 0x04BE => "ҿ", 0x04C1 => "ӂ", 0x04C3 => "ӄ", 0x04C5 => "ӆ", 0x04C7 => "ӈ", 0x04C9 => "ӊ", 0x04CB => "ӌ", 0x04CD => "ӎ", 0x04D0 => "ӑ", 0x04D2 => "ӓ", 0x04D4 => "ӕ", 0x04D6 => "ӗ", 0x04D8 => "ә", 0x04DA => "ӛ", 0x04DC => "ӝ", 0x04DE => "ӟ", 0x04E0 => "ӡ", 0x04E2 => "ӣ", 0x04E4 => "ӥ", 0x04E6 => "ӧ", 0x04E8 => "ө", 0x04EA => "ӫ", 0x04EC => "ӭ", 0x04EE => "ӯ", 0x04F0 => "ӱ", 0x04F2 => "ӳ", 0x04F4 => "ӵ", 0x04F6 => "ӷ", 0x04F8 => "ӹ", 0x04FA => "ӻ", 0x04FC => "ӽ", 0x04FE => "ӿ", 0x0500 => "ԁ", 0x0502 => "ԃ", 0x0504 => "ԅ", 0x0506 => "ԇ", 0x0508 => "ԉ", 0x050A => "ԋ", 0x050C => "ԍ", 0x050E => "ԏ", 0x0510 => "ԑ", 0x0512 => "ԓ", 0x0514 => "ԕ", 0x0516 => "ԗ", 0x0518 => "ԙ", 0x051A => "ԛ", 0x051C => "ԝ", 0x051E => "ԟ", 0x0520 => "ԡ", 0x0522 => "ԣ", 0x0524 => "ԥ", 0x0526 => "ԧ", 0x0528 => "ԩ", 0x052A => "ԫ", 0x052C => "ԭ", 0x052E => "ԯ", 0x0531 => "ա", 0x0532 => "բ", 0x0533 => "գ", 0x0534 => "դ", 0x0535 => "ե", 0x0536 => "զ", 0x0537 => "է", 0x0538 => "ը", 0x0539 => "թ", 0x053A => "ժ", 0x053B => "ի", 0x053C => "լ", 0x053D => "խ", 0x053E => "ծ", 0x053F => "կ", 0x0540 => "հ", 0x0541 => "ձ", 0x0542 => "ղ", 0x0543 => "ճ", 0x0544 => "մ", 0x0545 => "յ", 0x0546 => "ն", 0x0547 => "շ", 0x0548 => "ո", 0x0549 => "չ", 0x054A => "պ", 0x054B => "ջ", 0x054C => "ռ", 0x054D => "ս", 0x054E => "վ", 0x054F => "տ", 0x0550 => "ր", 0x0551 => "ց", 0x0552 => "ւ", 0x0553 => "փ", 0x0554 => "ք", 0x0555 => "օ", 0x0556 => "ֆ", 0x0587 => "եւ", 0x0675 => "اٴ", 0x0676 => "وٴ", 0x0677 => "ۇٴ", 0x0678 => "يٴ", 0x0958 => "क\x{093C}", 0x0959 => "ख\x{093C}", 0x095A => "ग\x{093C}", 0x095B => "ज\x{093C}", 0x095C => "ड\x{093C}", 0x095D => "ढ\x{093C}", 0x095E => "फ\x{093C}", 0x095F => "य\x{093C}", 0x09DC => "ড\x{09BC}", 0x09DD => "ঢ\x{09BC}", 0x09DF => "য\x{09BC}", 0x0A33 => "ਲ\x{0A3C}", 0x0A36 => "ਸ\x{0A3C}", 0x0A59 => "ਖ\x{0A3C}", 0x0A5A => "ਗ\x{0A3C}", 0x0A5B => "ਜ\x{0A3C}", 0x0A5E => "ਫ\x{0A3C}", 0x0B5C => "ଡ\x{0B3C}", 0x0B5D => "ଢ\x{0B3C}", 0x0E33 => "ํา", 0x0EB3 => "ໍາ", 0x0EDC => "ຫນ", 0x0EDD => "ຫມ", 0x0F0C => "\x{0F0B}", 0x0F43 => "གྷ", 0x0F4D => "ཌྷ", 0x0F52 => "དྷ", 0x0F57 => "བྷ", 0x0F5C => "ཛྷ", 0x0F69 => "ཀྵ", 0x0F73 => "ཱི", 0x0F75 => "ཱུ", 0x0F76 => "ྲྀ", 0x0F77 => "ྲཱྀ", 0x0F78 => "ླྀ", 0x0F79 => "ླཱྀ", 0x0F81 => "ཱྀ", 0x0F93 => "ྒྷ", 0x0F9D => "ྜྷ", 0x0FA2 => "ྡྷ", 0x0FA7 => "ྦྷ", 0x0FAC => "ྫྷ", 0x0FB9 => "ྐྵ", 0x10C7 => "ⴧ", 0x10CD => "ⴭ", 0x10FC => "ნ", 0x13F8 => "Ᏸ", 0x13F9 => "Ᏹ", 0x13FA => "Ᏺ", 0x13FB => "Ᏻ", 0x13FC => "Ᏼ", 0x13FD => "Ᏽ", 0x1C80 => "в", 0x1C81 => "д", 0x1C82 => "о", 0x1C83 => "с", 0x1C84 => "т", 0x1C85 => "т", 0x1C86 => "ъ", 0x1C87 => "ѣ", 0x1C88 => "ꙋ", 0x1D2C => "a", 0x1D2D => "æ", 0x1D2E => "b", 0x1D30 => "d", 0x1D31 => "e", 0x1D32 => "ǝ", 0x1D33 => "g", 0x1D34 => "h", 0x1D35 => "i", 0x1D36 => "j", 0x1D37 => "k", 0x1D38 => "l", 0x1D39 => "m", 0x1D3A => "n", 0x1D3C => "o", 0x1D3D => "ȣ", 0x1D3E => "p", 0x1D3F => "r", 0x1D40 => "t", 0x1D41 => "u", 0x1D42 => "w", 0x1D43 => "a", 0x1D44 => "ɐ", 0x1D45 => "ɑ", 0x1D46 => "ᴂ", 0x1D47 => "b", 0x1D48 => "d", 0x1D49 => "e", 0x1D4A => "ə", 0x1D4B => "ɛ", 0x1D4C => "ɜ", 0x1D4D => "g", 0x1D4F => "k", 0x1D50 => "m", 0x1D51 => "ŋ", 0x1D52 => "o", 0x1D53 => "ɔ", 0x1D54 => "ᴖ", 0x1D55 => "ᴗ", 0x1D56 => "p", 0x1D57 => "t", 0x1D58 => "u", 0x1D59 => "ᴝ", 0x1D5A => "ɯ", 0x1D5B => "v", 0x1D5C => "ᴥ", 0x1D5D => "β", 0x1D5E => "γ", 0x1D5F => "δ", 0x1D60 => "φ", 0x1D61 => "χ", 0x1D62 => "i", 0x1D63 => "r", 0x1D64 => "u", 0x1D65 => "v", 0x1D66 => "β", 0x1D67 => "γ", 0x1D68 => "ρ", 0x1D69 => "φ", 0x1D6A => "χ", 0x1D78 => "н", 0x1D9B => "ɒ", 0x1D9C => "c", 0x1D9D => "ɕ", 0x1D9E => "ð", 0x1D9F => "ɜ", 0x1DA0 => "f", 0x1DA1 => "ɟ", 0x1DA2 => "ɡ", 0x1DA3 => "ɥ", 0x1DA4 => "ɨ", 0x1DA5 => "ɩ", 0x1DA6 => "ɪ", 0x1DA7 => "ᵻ", 0x1DA8 => "ʝ", 0x1DA9 => "ɭ", 0x1DAA => "ᶅ", 0x1DAB => "ʟ", 0x1DAC => "ɱ", 0x1DAD => "ɰ", 0x1DAE => "ɲ", 0x1DAF => "ɳ", 0x1DB0 => "ɴ", 0x1DB1 => "ɵ", 0x1DB2 => "ɸ", 0x1DB3 => "ʂ", 0x1DB4 => "ʃ", 0x1DB5 => "ƫ", 0x1DB6 => "ʉ", 0x1DB7 => "ʊ", 0x1DB8 => "ᴜ", 0x1DB9 => "ʋ", 0x1DBA => "ʌ", 0x1DBB => "z", 0x1DBC => "ʐ", 0x1DBD => "ʑ", 0x1DBE => "ʒ", 0x1DBF => "θ", 0x1E00 => "ḁ", 0x1E02 => "ḃ", 0x1E04 => "ḅ", 0x1E06 => "ḇ", 0x1E08 => "ḉ", 0x1E0A => "ḋ", 0x1E0C => "ḍ", 0x1E0E => "ḏ", 0x1E10 => "ḑ", 0x1E12 => "ḓ", 0x1E14 => "ḕ", 0x1E16 => "ḗ", 0x1E18 => "ḙ", 0x1E1A => "ḛ", 0x1E1C => "ḝ", 0x1E1E => "ḟ", 0x1E20 => "ḡ", 0x1E22 => "ḣ", 0x1E24 => "ḥ", 0x1E26 => "ḧ", 0x1E28 => "ḩ", 0x1E2A => "ḫ", 0x1E2C => "ḭ", 0x1E2E => "ḯ", 0x1E30 => "ḱ", 0x1E32 => "ḳ", 0x1E34 => "ḵ", 0x1E36 => "ḷ", 0x1E38 => "ḹ", 0x1E3A => "ḻ", 0x1E3C => "ḽ", 0x1E3E => "ḿ", 0x1E40 => "ṁ", 0x1E42 => "ṃ", 0x1E44 => "ṅ", 0x1E46 => "ṇ", 0x1E48 => "ṉ", 0x1E4A => "ṋ", 0x1E4C => "ṍ", 0x1E4E => "ṏ", 0x1E50 => "ṑ", 0x1E52 => "ṓ", 0x1E54 => "ṕ", 0x1E56 => "ṗ", 0x1E58 => "ṙ", 0x1E5A => "ṛ", 0x1E5C => "ṝ", 0x1E5E => "ṟ", 0x1E60 => "ṡ", 0x1E62 => "ṣ", 0x1E64 => "ṥ", 0x1E66 => "ṧ", 0x1E68 => "ṩ", 0x1E6A => "ṫ", 0x1E6C => "ṭ", 0x1E6E => "ṯ", 0x1E70 => "ṱ", 0x1E72 => "ṳ", 0x1E74 => "ṵ", 0x1E76 => "ṷ", 0x1E78 => "ṹ", 0x1E7A => "ṻ", 0x1E7C => "ṽ", 0x1E7E => "ṿ", 0x1E80 => "ẁ", 0x1E82 => "ẃ", 0x1E84 => "ẅ", 0x1E86 => "ẇ", 0x1E88 => "ẉ", 0x1E8A => "ẋ", 0x1E8C => "ẍ", 0x1E8E => "ẏ", 0x1E90 => "ẑ", 0x1E92 => "ẓ", 0x1E94 => "ẕ", 0x1E9A => "aʾ", 0x1E9B => "ṡ", 0x1E9E => "ss", 0x1EA0 => "ạ", 0x1EA2 => "ả", 0x1EA4 => "ấ", 0x1EA6 => "ầ", 0x1EA8 => "ẩ", 0x1EAA => "ẫ", 0x1EAC => "ậ", 0x1EAE => "ắ", 0x1EB0 => "ằ", 0x1EB2 => "ẳ", 0x1EB4 => "ẵ", 0x1EB6 => "ặ", 0x1EB8 => "ẹ", 0x1EBA => "ẻ", 0x1EBC => "ẽ", 0x1EBE => "ế", 0x1EC0 => "ề", 0x1EC2 => "ể", 0x1EC4 => "ễ", 0x1EC6 => "ệ", 0x1EC8 => "ỉ", 0x1ECA => "ị", 0x1ECC => "ọ", 0x1ECE => "ỏ", 0x1ED0 => "ố", 0x1ED2 => "ồ", 0x1ED4 => "ổ", 0x1ED6 => "ỗ", 0x1ED8 => "ộ", 0x1EDA => "ớ", 0x1EDC => "ờ", 0x1EDE => "ở", 0x1EE0 => "ỡ", 0x1EE2 => "ợ", 0x1EE4 => "ụ", 0x1EE6 => "ủ", 0x1EE8 => "ứ", 0x1EEA => "ừ", 0x1EEC => "ử", 0x1EEE => "ữ", 0x1EF0 => "ự", 0x1EF2 => "ỳ", 0x1EF4 => "ỵ", 0x1EF6 => "ỷ", 0x1EF8 => "ỹ", 0x1EFA => "ỻ", 0x1EFC => "ỽ", 0x1EFE => "ỿ", 0x1F08 => "ἀ", 0x1F09 => "ἁ", 0x1F0A => "ἂ", 0x1F0B => "ἃ", 0x1F0C => "ἄ", 0x1F0D => "ἅ", 0x1F0E => "ἆ", 0x1F0F => "ἇ", 0x1F18 => "ἐ", 0x1F19 => "ἑ", 0x1F1A => "ἒ", 0x1F1B => "ἓ", 0x1F1C => "ἔ", 0x1F1D => "ἕ", 0x1F28 => "ἠ", 0x1F29 => "ἡ", 0x1F2A => "ἢ", 0x1F2B => "ἣ", 0x1F2C => "ἤ", 0x1F2D => "ἥ", 0x1F2E => "ἦ", 0x1F2F => "ἧ", 0x1F38 => "ἰ", 0x1F39 => "ἱ", 0x1F3A => "ἲ", 0x1F3B => "ἳ", 0x1F3C => "ἴ", 0x1F3D => "ἵ", 0x1F3E => "ἶ", 0x1F3F => "ἷ", 0x1F48 => "ὀ", 0x1F49 => "ὁ", 0x1F4A => "ὂ", 0x1F4B => "ὃ", 0x1F4C => "ὄ", 0x1F4D => "ὅ", 0x1F59 => "ὑ", 0x1F5B => "ὓ", 0x1F5D => "ὕ", 0x1F5F => "ὗ", 0x1F68 => "ὠ", 0x1F69 => "ὡ", 0x1F6A => "ὢ", 0x1F6B => "ὣ", 0x1F6C => "ὤ", 0x1F6D => "ὥ", 0x1F6E => "ὦ", 0x1F6F => "ὧ", 0x1F71 => "ά", 0x1F73 => "έ", 0x1F75 => "ή", 0x1F77 => "ί", 0x1F79 => "ό", 0x1F7B => "ύ", 0x1F7D => "ώ", 0x1F80 => "ἀι", 0x1F81 => "ἁι", 0x1F82 => "ἂι", 0x1F83 => "ἃι", 0x1F84 => "ἄι", 0x1F85 => "ἅι", 0x1F86 => "ἆι", 0x1F87 => "ἇι", 0x1F88 => "ἀι", 0x1F89 => "ἁι", 0x1F8A => "ἂι", 0x1F8B => "ἃι", 0x1F8C => "ἄι", 0x1F8D => "ἅι", 0x1F8E => "ἆι", 0x1F8F => "ἇι", 0x1F90 => "ἠι", 0x1F91 => "ἡι", 0x1F92 => "ἢι", 0x1F93 => "ἣι", 0x1F94 => "ἤι", 0x1F95 => "ἥι", 0x1F96 => "ἦι", 0x1F97 => "ἧι", 0x1F98 => "ἠι", 0x1F99 => "ἡι", 0x1F9A => "ἢι", 0x1F9B => "ἣι", 0x1F9C => "ἤι", 0x1F9D => "ἥι", 0x1F9E => "ἦι", 0x1F9F => "ἧι", 0x1FA0 => "ὠι", 0x1FA1 => "ὡι", 0x1FA2 => "ὢι", 0x1FA3 => "ὣι", 0x1FA4 => "ὤι", 0x1FA5 => "ὥι", 0x1FA6 => "ὦι", 0x1FA7 => "ὧι", 0x1FA8 => "ὠι", 0x1FA9 => "ὡι", 0x1FAA => "ὢι", 0x1FAB => "ὣι", 0x1FAC => "ὤι", 0x1FAD => "ὥι", 0x1FAE => "ὦι", 0x1FAF => "ὧι", 0x1FB2 => "ὰι", 0x1FB3 => "αι", 0x1FB4 => "άι", 0x1FB7 => "ᾶι", 0x1FB8 => "ᾰ", 0x1FB9 => "ᾱ", 0x1FBA => "ὰ", 0x1FBB => "ά", 0x1FBC => "αι", 0x1FBE => "ι", 0x1FC2 => "ὴι", 0x1FC3 => "ηι", 0x1FC4 => "ήι", 0x1FC7 => "ῆι", 0x1FC8 => "ὲ", 0x1FC9 => "έ", 0x1FCA => "ὴ", 0x1FCB => "ή", 0x1FCC => "ηι", 0x1FD3 => "ΐ", 0x1FD8 => "ῐ", 0x1FD9 => "ῑ", 0x1FDA => "ὶ", 0x1FDB => "ί", 0x1FE3 => "ΰ", 0x1FE8 => "ῠ", 0x1FE9 => "ῡ", 0x1FEA => "ὺ", 0x1FEB => "ύ", 0x1FEC => "ῥ", 0x1FF2 => "ὼι", 0x1FF3 => "ωι", 0x1FF4 => "ώι", 0x1FF7 => "ῶι", 0x1FF8 => "ὸ", 0x1FF9 => "ό", 0x1FFA => "ὼ", 0x1FFB => "ώ", 0x1FFC => "ωι", 0x2011 => "\x{2010}", 0x2033 => "\x{2032}\x{2032}", 0x2034 => "\x{2032}\x{2032}\x{2032}", 0x2036 => "\x{2035}\x{2035}", 0x2037 => "\x{2035}\x{2035}\x{2035}", 0x2057 => "\x{2032}\x{2032}\x{2032}\x{2032}", 0x2070 => "0", 0x2071 => "i", 0x2074 => "4", 0x2075 => "5", 0x2076 => "6", 0x2077 => "7", 0x2078 => "8", 0x2079 => "9", 0x207B => "\x{2212}", 0x207F => "n", 0x2080 => "0", 0x2081 => "1", 0x2082 => "2", 0x2083 => "3", 0x2084 => "4", 0x2085 => "5", 0x2086 => "6", 0x2087 => "7", 0x2088 => "8", 0x2089 => "9", 0x208B => "\x{2212}", 0x2090 => "a", 0x2091 => "e", 0x2092 => "o", 0x2093 => "x", 0x2094 => "ə", 0x2095 => "h", 0x2096 => "k", 0x2097 => "l", 0x2098 => "m", 0x2099 => "n", 0x209A => "p", 0x209B => "s", 0x209C => "t", 0x20A8 => "rs", 0x2102 => "c", 0x2103 => "\x{00B0}c", 0x2107 => "ɛ", 0x2109 => "\x{00B0}f", 0x210A => "g", 0x210B => "h", 0x210C => "h", 0x210D => "h", 0x210E => "h", 0x210F => "ħ", 0x2110 => "i", 0x2111 => "i", 0x2112 => "l", 0x2113 => "l", 0x2115 => "n", 0x2116 => "no", 0x2119 => "p", 0x211A => "q", 0x211B => "r", 0x211C => "r", 0x211D => "r", 0x2120 => "sm", 0x2121 => "tel", 0x2122 => "tm", 0x2124 => "z", 0x2126 => "ω", 0x2128 => "z", 0x212A => "k", 0x212B => "å", 0x212C => "b", 0x212D => "c", 0x212F => "e", 0x2130 => "e", 0x2131 => "f", 0x2133 => "m", 0x2134 => "o", 0x2135 => "א", 0x2136 => "ב", 0x2137 => "ג", 0x2138 => "ד", 0x2139 => "i", 0x213B => "fax", 0x213C => "π", 0x213D => "γ", 0x213E => "γ", 0x213F => "π", 0x2140 => "\x{2211}", 0x2145 => "d", 0x2146 => "d", 0x2147 => "e", 0x2148 => "i", 0x2149 => "j", 0x2150 => "1\x{2044}7", 0x2151 => "1\x{2044}9", 0x2152 => "1\x{2044}10", 0x2153 => "1\x{2044}3", 0x2154 => "2\x{2044}3", 0x2155 => "1\x{2044}5", 0x2156 => "2\x{2044}5", 0x2157 => "3\x{2044}5", 0x2158 => "4\x{2044}5", 0x2159 => "1\x{2044}6", 0x215A => "5\x{2044}6", 0x215B => "1\x{2044}8", 0x215C => "3\x{2044}8", 0x215D => "5\x{2044}8", 0x215E => "7\x{2044}8", 0x215F => "1\x{2044}", 0x2160 => "i", 0x2161 => "ii", 0x2162 => "iii", 0x2163 => "iv", 0x2164 => "v", 0x2165 => "vi", 0x2166 => "vii", 0x2167 => "viii", 0x2168 => "ix", 0x2169 => "x", 0x216A => "xi", 0x216B => "xii", 0x216C => "l", 0x216D => "c", 0x216E => "d", 0x216F => "m", 0x2170 => "i", 0x2171 => "ii", 0x2172 => "iii", 0x2173 => "iv", 0x2174 => "v", 0x2175 => "vi", 0x2176 => "vii", 0x2177 => "viii", 0x2178 => "ix", 0x2179 => "x", 0x217A => "xi", 0x217B => "xii", 0x217C => "l", 0x217D => "c", 0x217E => "d", 0x217F => "m", 0x2189 => "0\x{2044}3", 0x222C => "\x{222B}\x{222B}", 0x222D => "\x{222B}\x{222B}\x{222B}", 0x222F => "\x{222E}\x{222E}", 0x2230 => "\x{222E}\x{222E}\x{222E}", 0x2329 => "\x{3008}", 0x232A => "\x{3009}", 0x2460 => "1", 0x2461 => "2", 0x2462 => "3", 0x2463 => "4", 0x2464 => "5", 0x2465 => "6", 0x2466 => "7", 0x2467 => "8", 0x2468 => "9", 0x2469 => "10", 0x246A => "11", 0x246B => "12", 0x246C => "13", 0x246D => "14", 0x246E => "15", 0x246F => "16", 0x2470 => "17", 0x2471 => "18", 0x2472 => "19", 0x2473 => "20", 0x24B6 => "a", 0x24B7 => "b", 0x24B8 => "c", 0x24B9 => "d", 0x24BA => "e", 0x24BB => "f", 0x24BC => "g", 0x24BD => "h", 0x24BE => "i", 0x24BF => "j", 0x24C0 => "k", 0x24C1 => "l", 0x24C2 => "m", 0x24C3 => "n", 0x24C4 => "o", 0x24C5 => "p", 0x24C6 => "q", 0x24C7 => "r", 0x24C8 => "s", 0x24C9 => "t", 0x24CA => "u", 0x24CB => "v", 0x24CC => "w", 0x24CD => "x", 0x24CE => "y", 0x24CF => "z", 0x24D0 => "a", 0x24D1 => "b", 0x24D2 => "c", 0x24D3 => "d", 0x24D4 => "e", 0x24D5 => "f", 0x24D6 => "g", 0x24D7 => "h", 0x24D8 => "i", 0x24D9 => "j", 0x24DA => "k", 0x24DB => "l", 0x24DC => "m", 0x24DD => "n", 0x24DE => "o", 0x24DF => "p", 0x24E0 => "q", 0x24E1 => "r", 0x24E2 => "s", 0x24E3 => "t", 0x24E4 => "u", 0x24E5 => "v", 0x24E6 => "w", 0x24E7 => "x", 0x24E8 => "y", 0x24E9 => "z", 0x24EA => "0", 0x2A0C => "\x{222B}\x{222B}\x{222B}\x{222B}", 0x2ADC => "\x{2ADD}\x{0338}", 0x2C00 => "ⰰ", 0x2C01 => "ⰱ", 0x2C02 => "ⰲ", 0x2C03 => "ⰳ", 0x2C04 => "ⰴ", 0x2C05 => "ⰵ", 0x2C06 => "ⰶ", 0x2C07 => "ⰷ", 0x2C08 => "ⰸ", 0x2C09 => "ⰹ", 0x2C0A => "ⰺ", 0x2C0B => "ⰻ", 0x2C0C => "ⰼ", 0x2C0D => "ⰽ", 0x2C0E => "ⰾ", 0x2C0F => "ⰿ", 0x2C10 => "ⱀ", 0x2C11 => "ⱁ", 0x2C12 => "ⱂ", 0x2C13 => "ⱃ", 0x2C14 => "ⱄ", 0x2C15 => "ⱅ", 0x2C16 => "ⱆ", 0x2C17 => "ⱇ", 0x2C18 => "ⱈ", 0x2C19 => "ⱉ", 0x2C1A => "ⱊ", 0x2C1B => "ⱋ", 0x2C1C => "ⱌ", 0x2C1D => "ⱍ", 0x2C1E => "ⱎ", 0x2C1F => "ⱏ", 0x2C20 => "ⱐ", 0x2C21 => "ⱑ", 0x2C22 => "ⱒ", 0x2C23 => "ⱓ", 0x2C24 => "ⱔ", 0x2C25 => "ⱕ", 0x2C26 => "ⱖ", 0x2C27 => "ⱗ", 0x2C28 => "ⱘ", 0x2C29 => "ⱙ", 0x2C2A => "ⱚ", 0x2C2B => "ⱛ", 0x2C2C => "ⱜ", 0x2C2D => "ⱝ", 0x2C2E => "ⱞ", 0x2C60 => "ⱡ", 0x2C62 => "ɫ", 0x2C63 => "ᵽ", 0x2C64 => "ɽ", 0x2C67 => "ⱨ", 0x2C69 => "ⱪ", 0x2C6B => "ⱬ", 0x2C6D => "ɑ", 0x2C6E => "ɱ", 0x2C6F => "ɐ", 0x2C70 => "ɒ", 0x2C72 => "ⱳ", 0x2C75 => "ⱶ", 0x2C7C => "j", 0x2C7D => "v", 0x2C7E => "ȿ", 0x2C7F => "ɀ", 0x2C80 => "ⲁ", 0x2C82 => "ⲃ", 0x2C84 => "ⲅ", 0x2C86 => "ⲇ", 0x2C88 => "ⲉ", 0x2C8A => "ⲋ", 0x2C8C => "ⲍ", 0x2C8E => "ⲏ", 0x2C90 => "ⲑ", 0x2C92 => "ⲓ", 0x2C94 => "ⲕ", 0x2C96 => "ⲗ", 0x2C98 => "ⲙ", 0x2C9A => "ⲛ", 0x2C9C => "ⲝ", 0x2C9E => "ⲟ", 0x2CA0 => "ⲡ", 0x2CA2 => "ⲣ", 0x2CA4 => "ⲥ", 0x2CA6 => "ⲧ", 0x2CA8 => "ⲩ", 0x2CAA => "ⲫ", 0x2CAC => "ⲭ", 0x2CAE => "ⲯ", 0x2CB0 => "ⲱ", 0x2CB2 => "ⲳ", 0x2CB4 => "ⲵ", 0x2CB6 => "ⲷ", 0x2CB8 => "ⲹ", 0x2CBA => "ⲻ", 0x2CBC => "ⲽ", 0x2CBE => "ⲿ", 0x2CC0 => "ⳁ", 0x2CC2 => "ⳃ", 0x2CC4 => "ⳅ", 0x2CC6 => "ⳇ", 0x2CC8 => "ⳉ", 0x2CCA => "ⳋ", 0x2CCC => "ⳍ", 0x2CCE => "ⳏ", 0x2CD0 => "ⳑ", 0x2CD2 => "ⳓ", 0x2CD4 => "ⳕ", 0x2CD6 => "ⳗ", 0x2CD8 => "ⳙ", 0x2CDA => "ⳛ", 0x2CDC => "ⳝ", 0x2CDE => "ⳟ", 0x2CE0 => "ⳡ", 0x2CE2 => "ⳣ", 0x2CEB => "ⳬ", 0x2CED => "ⳮ", 0x2CF2 => "ⳳ", 0x2D6F => "ⵡ", 0x2E9F => "母", 0x2EF3 => "龟", 0x2F00 => "一", 0x2F01 => "丨", 0x2F02 => "丶", 0x2F03 => "丿", 0x2F04 => "乙", 0x2F05 => "亅", 0x2F06 => "二", 0x2F07 => "亠", 0x2F08 => "人", 0x2F09 => "儿", 0x2F0A => "入", 0x2F0B => "八", 0x2F0C => "冂", 0x2F0D => "冖", 0x2F0E => "冫", 0x2F0F => "几", 0x2F10 => "凵", 0x2F11 => "刀", 0x2F12 => "力", 0x2F13 => "勹", 0x2F14 => "匕", 0x2F15 => "匚", 0x2F16 => "匸", 0x2F17 => "十", 0x2F18 => "卜", 0x2F19 => "卩", 0x2F1A => "厂", 0x2F1B => "厶", 0x2F1C => "又", 0x2F1D => "口", 0x2F1E => "囗", 0x2F1F => "土", 0x2F20 => "士", 0x2F21 => "夂", 0x2F22 => "夊", 0x2F23 => "夕", 0x2F24 => "大", 0x2F25 => "女", 0x2F26 => "子", 0x2F27 => "宀", 0x2F28 => "寸", 0x2F29 => "小", 0x2F2A => "尢", 0x2F2B => "尸", 0x2F2C => "屮", 0x2F2D => "山", 0x2F2E => "巛", 0x2F2F => "工", 0x2F30 => "己", 0x2F31 => "巾", 0x2F32 => "干", 0x2F33 => "幺", 0x2F34 => "广", 0x2F35 => "廴", 0x2F36 => "廾", 0x2F37 => "弋", 0x2F38 => "弓", 0x2F39 => "彐", 0x2F3A => "彡", 0x2F3B => "彳", 0x2F3C => "心", 0x2F3D => "戈", 0x2F3E => "戶", 0x2F3F => "手", 0x2F40 => "支", 0x2F41 => "攴", 0x2F42 => "文", 0x2F43 => "斗", 0x2F44 => "斤", 0x2F45 => "方", 0x2F46 => "无", 0x2F47 => "日", 0x2F48 => "曰", 0x2F49 => "月", 0x2F4A => "木", 0x2F4B => "欠", 0x2F4C => "止", 0x2F4D => "歹", 0x2F4E => "殳", 0x2F4F => "毋", 0x2F50 => "比", 0x2F51 => "毛", 0x2F52 => "氏", 0x2F53 => "气", 0x2F54 => "水", 0x2F55 => "火", 0x2F56 => "爪", 0x2F57 => "父", 0x2F58 => "爻", 0x2F59 => "爿", 0x2F5A => "片", 0x2F5B => "牙", 0x2F5C => "牛", 0x2F5D => "犬", 0x2F5E => "玄", 0x2F5F => "玉", 0x2F60 => "瓜", 0x2F61 => "瓦", 0x2F62 => "甘", 0x2F63 => "生", 0x2F64 => "用", 0x2F65 => "田", 0x2F66 => "疋", 0x2F67 => "疒", 0x2F68 => "癶", 0x2F69 => "白", 0x2F6A => "皮", 0x2F6B => "皿", 0x2F6C => "目", 0x2F6D => "矛", 0x2F6E => "矢", 0x2F6F => "石", 0x2F70 => "示", 0x2F71 => "禸", 0x2F72 => "禾", 0x2F73 => "穴", 0x2F74 => "立", 0x2F75 => "竹", 0x2F76 => "米", 0x2F77 => "糸", 0x2F78 => "缶", 0x2F79 => "网", 0x2F7A => "羊", 0x2F7B => "羽", 0x2F7C => "老", 0x2F7D => "而", 0x2F7E => "耒", 0x2F7F => "耳", 0x2F80 => "聿", 0x2F81 => "肉", 0x2F82 => "臣", 0x2F83 => "自", 0x2F84 => "至", 0x2F85 => "臼", 0x2F86 => "舌", 0x2F87 => "舛", 0x2F88 => "舟", 0x2F89 => "艮", 0x2F8A => "色", 0x2F8B => "艸", 0x2F8C => "虍", 0x2F8D => "虫", 0x2F8E => "血", 0x2F8F => "行", 0x2F90 => "衣", 0x2F91 => "襾", 0x2F92 => "見", 0x2F93 => "角", 0x2F94 => "言", 0x2F95 => "谷", 0x2F96 => "豆", 0x2F97 => "豕", 0x2F98 => "豸", 0x2F99 => "貝", 0x2F9A => "赤", 0x2F9B => "走", 0x2F9C => "足", 0x2F9D => "身", 0x2F9E => "車", 0x2F9F => "辛", 0x2FA0 => "辰", 0x2FA1 => "辵", 0x2FA2 => "邑", 0x2FA3 => "酉", 0x2FA4 => "釆", 0x2FA5 => "里", 0x2FA6 => "金", 0x2FA7 => "長", 0x2FA8 => "門", 0x2FA9 => "阜", 0x2FAA => "隶", 0x2FAB => "隹", 0x2FAC => "雨", 0x2FAD => "靑", 0x2FAE => "非", 0x2FAF => "面", 0x2FB0 => "革", 0x2FB1 => "韋", 0x2FB2 => "韭", 0x2FB3 => "音", 0x2FB4 => "頁", 0x2FB5 => "風", 0x2FB6 => "飛", 0x2FB7 => "食", 0x2FB8 => "首", 0x2FB9 => "香", 0x2FBA => "馬", 0x2FBB => "骨", 0x2FBC => "高", 0x2FBD => "髟", 0x2FBE => "鬥", 0x2FBF => "鬯", 0x2FC0 => "鬲", 0x2FC1 => "鬼", 0x2FC2 => "魚", 0x2FC3 => "鳥", 0x2FC4 => "鹵", 0x2FC5 => "鹿", 0x2FC6 => "麥", 0x2FC7 => "麻", 0x2FC8 => "黃", 0x2FC9 => "黍", 0x2FCA => "黑", 0x2FCB => "黹", 0x2FCC => "黽", 0x2FCD => "鼎", 0x2FCE => "鼓", 0x2FCF => "鼠", 0x2FD0 => "鼻", 0x2FD1 => "齊", 0x2FD2 => "齒", 0x2FD3 => "龍", 0x2FD4 => "龜", 0x2FD5 => "龠", 0x3002 => "\.", 0x3036 => "\x{3012}", 0x3038 => "十", 0x3039 => "卄", 0x303A => "卅", 0x309F => "より", 0x30FF => "コト", 0x3131 => "ᄀ", 0x3132 => "ᄁ", 0x3133 => "ᆪ", 0x3134 => "ᄂ", 0x3135 => "ᆬ", 0x3136 => "ᆭ", 0x3137 => "ᄃ", 0x3138 => "ᄄ", 0x3139 => "ᄅ", 0x313A => "ᆰ", 0x313B => "ᆱ", 0x313C => "ᆲ", 0x313D => "ᆳ", 0x313E => "ᆴ", 0x313F => "ᆵ", 0x3140 => "ᄚ", 0x3141 => "ᄆ", 0x3142 => "ᄇ", 0x3143 => "ᄈ", 0x3144 => "ᄡ", 0x3145 => "ᄉ", 0x3146 => "ᄊ", 0x3147 => "ᄋ", 0x3148 => "ᄌ", 0x3149 => "ᄍ", 0x314A => "ᄎ", 0x314B => "ᄏ", 0x314C => "ᄐ", 0x314D => "ᄑ", 0x314E => "ᄒ", 0x314F => "ᅡ", 0x3150 => "ᅢ", 0x3151 => "ᅣ", 0x3152 => "ᅤ", 0x3153 => "ᅥ", 0x3154 => "ᅦ", 0x3155 => "ᅧ", 0x3156 => "ᅨ", 0x3157 => "ᅩ", 0x3158 => "ᅪ", 0x3159 => "ᅫ", 0x315A => "ᅬ", 0x315B => "ᅭ", 0x315C => "ᅮ", 0x315D => "ᅯ", 0x315E => "ᅰ", 0x315F => "ᅱ", 0x3160 => "ᅲ", 0x3161 => "ᅳ", 0x3162 => "ᅴ", 0x3163 => "ᅵ", 0x3165 => "ᄔ", 0x3166 => "ᄕ", 0x3167 => "ᇇ", 0x3168 => "ᇈ", 0x3169 => "ᇌ", 0x316A => "ᇎ", 0x316B => "ᇓ", 0x316C => "ᇗ", 0x316D => "ᇙ", 0x316E => "ᄜ", 0x316F => "ᇝ", 0x3170 => "ᇟ", 0x3171 => "ᄝ", 0x3172 => "ᄞ", 0x3173 => "ᄠ", 0x3174 => "ᄢ", 0x3175 => "ᄣ", 0x3176 => "ᄧ", 0x3177 => "ᄩ", 0x3178 => "ᄫ", 0x3179 => "ᄬ", 0x317A => "ᄭ", 0x317B => "ᄮ", 0x317C => "ᄯ", 0x317D => "ᄲ", 0x317E => "ᄶ", 0x317F => "ᅀ", 0x3180 => "ᅇ", 0x3181 => "ᅌ", 0x3182 => "ᇱ", 0x3183 => "ᇲ", 0x3184 => "ᅗ", 0x3185 => "ᅘ", 0x3186 => "ᅙ", 0x3187 => "ᆄ", 0x3188 => "ᆅ", 0x3189 => "ᆈ", 0x318A => "ᆑ", 0x318B => "ᆒ", 0x318C => "ᆔ", 0x318D => "ᆞ", 0x318E => "ᆡ", 0x3192 => "一", 0x3193 => "二", 0x3194 => "三", 0x3195 => "四", 0x3196 => "上", 0x3197 => "中", 0x3198 => "下", 0x3199 => "甲", 0x319A => "乙", 0x319B => "丙", 0x319C => "丁", 0x319D => "天", 0x319E => "地", 0x319F => "人", 0x3244 => "問", 0x3245 => "幼", 0x3246 => "文", 0x3247 => "箏", 0x3250 => "pte", 0x3251 => "21", 0x3252 => "22", 0x3253 => "23", 0x3254 => "24", 0x3255 => "25", 0x3256 => "26", 0x3257 => "27", 0x3258 => "28", 0x3259 => "29", 0x325A => "30", 0x325B => "31", 0x325C => "32", 0x325D => "33", 0x325E => "34", 0x325F => "35", 0x3260 => "ᄀ", 0x3261 => "ᄂ", 0x3262 => "ᄃ", 0x3263 => "ᄅ", 0x3264 => "ᄆ", 0x3265 => "ᄇ", 0x3266 => "ᄉ", 0x3267 => "ᄋ", 0x3268 => "ᄌ", 0x3269 => "ᄎ", 0x326A => "ᄏ", 0x326B => "ᄐ", 0x326C => "ᄑ", 0x326D => "ᄒ", 0x326E => "가", 0x326F => "나", 0x3270 => "다", 0x3271 => "라", 0x3272 => "마", 0x3273 => "바", 0x3274 => "사", 0x3275 => "아", 0x3276 => "자", 0x3277 => "차", 0x3278 => "카", 0x3279 => "타", 0x327A => "파", 0x327B => "하", 0x327C => "참고", 0x327D => "주의", 0x327E => "우", 0x3280 => "一", 0x3281 => "二", 0x3282 => "三", 0x3283 => "四", 0x3284 => "五", 0x3285 => "六", 0x3286 => "七", 0x3287 => "八", 0x3288 => "九", 0x3289 => "十", 0x328A => "月", 0x328B => "火", 0x328C => "水", 0x328D => "木", 0x328E => "金", 0x328F => "土", 0x3290 => "日", 0x3291 => "株", 0x3292 => "有", 0x3293 => "社", 0x3294 => "名", 0x3295 => "特", 0x3296 => "財", 0x3297 => "祝", 0x3298 => "労", 0x3299 => "秘", 0x329A => "男", 0x329B => "女", 0x329C => "適", 0x329D => "優", 0x329E => "印", 0x329F => "注", 0x32A0 => "項", 0x32A1 => "休", 0x32A2 => "写", 0x32A3 => "正", 0x32A4 => "上", 0x32A5 => "中", 0x32A6 => "下", 0x32A7 => "左", 0x32A8 => "右", 0x32A9 => "医", 0x32AA => "宗", 0x32AB => "学", 0x32AC => "監", 0x32AD => "企", 0x32AE => "資", 0x32AF => "協", 0x32B0 => "夜", 0x32B1 => "36", 0x32B2 => "37", 0x32B3 => "38", 0x32B4 => "39", 0x32B5 => "40", 0x32B6 => "41", 0x32B7 => "42", 0x32B8 => "43", 0x32B9 => "44", 0x32BA => "45", 0x32BB => "46", 0x32BC => "47", 0x32BD => "48", 0x32BE => "49", 0x32BF => "50", 0x32C0 => "1月", 0x32C1 => "2月", 0x32C2 => "3月", 0x32C3 => "4月", 0x32C4 => "5月", 0x32C5 => "6月", 0x32C6 => "7月", 0x32C7 => "8月", 0x32C8 => "9月", 0x32C9 => "10月", 0x32CA => "11月", 0x32CB => "12月", 0x32CC => "hg", 0x32CD => "erg", 0x32CE => "ev", 0x32CF => "ltd", 0x32D0 => "ア", 0x32D1 => "イ", 0x32D2 => "ウ", 0x32D3 => "エ", 0x32D4 => "オ", 0x32D5 => "カ", 0x32D6 => "キ", 0x32D7 => "ク", 0x32D8 => "ケ", 0x32D9 => "コ", 0x32DA => "サ", 0x32DB => "シ", 0x32DC => "ス", 0x32DD => "セ", 0x32DE => "ソ", 0x32DF => "タ", 0x32E0 => "チ", 0x32E1 => "ツ", 0x32E2 => "テ", 0x32E3 => "ト", 0x32E4 => "ナ", 0x32E5 => "ニ", 0x32E6 => "ヌ", 0x32E7 => "ネ", 0x32E8 => "ノ", 0x32E9 => "ハ", 0x32EA => "ヒ", 0x32EB => "フ", 0x32EC => "ヘ", 0x32ED => "ホ", 0x32EE => "マ", 0x32EF => "ミ", 0x32F0 => "ム", 0x32F1 => "メ", 0x32F2 => "モ", 0x32F3 => "ヤ", 0x32F4 => "ユ", 0x32F5 => "ヨ", 0x32F6 => "ラ", 0x32F7 => "リ", 0x32F8 => "ル", 0x32F9 => "レ", 0x32FA => "ロ", 0x32FB => "ワ", 0x32FC => "ヰ", 0x32FD => "ヱ", 0x32FE => "ヲ", 0x3300 => "アパート", 0x3301 => "アルファ", 0x3302 => "アンペア", 0x3303 => "アール", 0x3304 => "イニング", 0x3305 => "インチ", 0x3306 => "ウォン", 0x3307 => "エスクード", 0x3308 => "エーカー", 0x3309 => "オンス", 0x330A => "オーム", 0x330B => "カイリ", 0x330C => "カラット", 0x330D => "カロリー", 0x330E => "ガロン", 0x330F => "ガンマ", 0x3310 => "ギガ", 0x3311 => "ギニー", 0x3312 => "キュリー", 0x3313 => "ギルダー", 0x3314 => "キロ", 0x3315 => "キログラム", 0x3316 => "キロメートル", 0x3317 => "キロワット", 0x3318 => "グラム", 0x3319 => "グラムトン", 0x331A => "クルゼイロ", 0x331B => "クローネ", 0x331C => "ケース", 0x331D => "コルナ", 0x331E => "コーポ", 0x331F => "サイクル", 0x3320 => "サンチーム", 0x3321 => "シリング", 0x3322 => "センチ", 0x3323 => "セント", 0x3324 => "ダース", 0x3325 => "デシ", 0x3326 => "ドル", 0x3327 => "トン", 0x3328 => "ナノ", 0x3329 => "ノット", 0x332A => "ハイツ", 0x332B => "パーセント", 0x332C => "パーツ", 0x332D => "バーレル", 0x332E => "ピアストル", 0x332F => "ピクル", 0x3330 => "ピコ", 0x3331 => "ビル", 0x3332 => "ファラッド", 0x3333 => "フィート", 0x3334 => "ブッシェル", 0x3335 => "フラン", 0x3336 => "ヘクタール", 0x3337 => "ペソ", 0x3338 => "ペニヒ", 0x3339 => "ヘルツ", 0x333A => "ペンス", 0x333B => "ページ", 0x333C => "ベータ", 0x333D => "ポイント", 0x333E => "ボルト", 0x333F => "ホン", 0x3340 => "ポンド", 0x3341 => "ホール", 0x3342 => "ホーン", 0x3343 => "マイクロ", 0x3344 => "マイル", 0x3345 => "マッハ", 0x3346 => "マルク", 0x3347 => "マンション", 0x3348 => "ミクロン", 0x3349 => "ミリ", 0x334A => "ミリバール", 0x334B => "メガ", 0x334C => "メガトン", 0x334D => "メートル", 0x334E => "ヤード", 0x334F => "ヤール", 0x3350 => "ユアン", 0x3351 => "リットル", 0x3352 => "リラ", 0x3353 => "ルピー", 0x3354 => "ルーブル", 0x3355 => "レム", 0x3356 => "レントゲン", 0x3357 => "ワット", 0x3358 => "0点", 0x3359 => "1点", 0x335A => "2点", 0x335B => "3点", 0x335C => "4点", 0x335D => "5点", 0x335E => "6点", 0x335F => "7点", 0x3360 => "8点", 0x3361 => "9点", 0x3362 => "10点", 0x3363 => "11点", 0x3364 => "12点", 0x3365 => "13点", 0x3366 => "14点", 0x3367 => "15点", 0x3368 => "16点", 0x3369 => "17点", 0x336A => "18点", 0x336B => "19点", 0x336C => "20点", 0x336D => "21点", 0x336E => "22点", 0x336F => "23点", 0x3370 => "24点", 0x3371 => "hpa", 0x3372 => "da", 0x3373 => "au", 0x3374 => "bar", 0x3375 => "ov", 0x3376 => "pc", 0x3377 => "dm", 0x3378 => "dm2", 0x3379 => "dm3", 0x337A => "iu", 0x337B => "平成", 0x337C => "昭和", 0x337D => "大正", 0x337E => "明治", 0x337F => "株式会社", 0x3380 => "pa", 0x3381 => "na", 0x3382 => "μa", 0x3383 => "ma", 0x3384 => "ka", 0x3385 => "kb", 0x3386 => "mb", 0x3387 => "gb", 0x3388 => "cal", 0x3389 => "kcal", 0x338A => "pf", 0x338B => "nf", 0x338C => "μf", 0x338D => "μg", 0x338E => "mg", 0x338F => "kg", 0x3390 => "hz", 0x3391 => "khz", 0x3392 => "mhz", 0x3393 => "ghz", 0x3394 => "thz", 0x3395 => "μl", 0x3396 => "ml", 0x3397 => "dl", 0x3398 => "kl", 0x3399 => "fm", 0x339A => "nm", 0x339B => "μm", 0x339C => "mm", 0x339D => "cm", 0x339E => "km", 0x339F => "mm2", 0x33A0 => "cm2", 0x33A1 => "m2", 0x33A2 => "km2", 0x33A3 => "mm3", 0x33A4 => "cm3", 0x33A5 => "m3", 0x33A6 => "km3", 0x33A7 => "m\x{2215}s", 0x33A8 => "m\x{2215}s2", 0x33A9 => "pa", 0x33AA => "kpa", 0x33AB => "mpa", 0x33AC => "gpa", 0x33AD => "rad", 0x33AE => "rad\x{2215}s", 0x33AF => "rad\x{2215}s2", 0x33B0 => "ps", 0x33B1 => "ns", 0x33B2 => "μs", 0x33B3 => "ms", 0x33B4 => "pv", 0x33B5 => "nv", 0x33B6 => "μv", 0x33B7 => "mv", 0x33B8 => "kv", 0x33B9 => "mv", 0x33BA => "pw", 0x33BB => "nw", 0x33BC => "μw", 0x33BD => "mw", 0x33BE => "kw", 0x33BF => "mw", 0x33C0 => "kω", 0x33C1 => "mω", 0x33C3 => "bq", 0x33C4 => "cc", 0x33C5 => "cd", 0x33C6 => "c\x{2215}kg", 0x33C8 => "db", 0x33C9 => "gy", 0x33CA => "ha", 0x33CB => "hp", 0x33CC => "in", 0x33CD => "kk", 0x33CE => "km", 0x33CF => "kt", 0x33D0 => "lm", 0x33D1 => "ln", 0x33D2 => "log", 0x33D3 => "lx", 0x33D4 => "mb", 0x33D5 => "mil", 0x33D6 => "mol", 0x33D7 => "ph", 0x33D9 => "ppm", 0x33DA => "pr", 0x33DB => "sr", 0x33DC => "sv", 0x33DD => "wb", 0x33DE => "v\x{2215}m", 0x33DF => "a\x{2215}m", 0x33E0 => "1日", 0x33E1 => "2日", 0x33E2 => "3日", 0x33E3 => "4日", 0x33E4 => "5日", 0x33E5 => "6日", 0x33E6 => "7日", 0x33E7 => "8日", 0x33E8 => "9日", 0x33E9 => "10日", 0x33EA => "11日", 0x33EB => "12日", 0x33EC => "13日", 0x33ED => "14日", 0x33EE => "15日", 0x33EF => "16日", 0x33F0 => "17日", 0x33F1 => "18日", 0x33F2 => "19日", 0x33F3 => "20日", 0x33F4 => "21日", 0x33F5 => "22日", 0x33F6 => "23日", 0x33F7 => "24日", 0x33F8 => "25日", 0x33F9 => "26日", 0x33FA => "27日", 0x33FB => "28日", 0x33FC => "29日", 0x33FD => "30日", 0x33FE => "31日", 0x33FF => "gal", 0xA640 => "ꙁ", 0xA642 => "ꙃ", 0xA644 => "ꙅ", 0xA646 => "ꙇ", 0xA648 => "ꙉ", 0xA64A => "ꙋ", 0xA64C => "ꙍ", 0xA64E => "ꙏ", 0xA650 => "ꙑ", 0xA652 => "ꙓ", 0xA654 => "ꙕ", 0xA656 => "ꙗ", 0xA658 => "ꙙ", 0xA65A => "ꙛ", 0xA65C => "ꙝ", 0xA65E => "ꙟ", 0xA660 => "ꙡ", 0xA662 => "ꙣ", 0xA664 => "ꙥ", 0xA666 => "ꙧ", 0xA668 => "ꙩ", 0xA66A => "ꙫ", 0xA66C => "ꙭ", 0xA680 => "ꚁ", 0xA682 => "ꚃ", 0xA684 => "ꚅ", 0xA686 => "ꚇ", 0xA688 => "ꚉ", 0xA68A => "ꚋ", 0xA68C => "ꚍ", 0xA68E => "ꚏ", 0xA690 => "ꚑ", 0xA692 => "ꚓ", 0xA694 => "ꚕ", 0xA696 => "ꚗ", 0xA698 => "ꚙ", 0xA69A => "ꚛ", 0xA69C => "ъ", 0xA69D => "ь", 0xA722 => "ꜣ", 0xA724 => "ꜥ", 0xA726 => "ꜧ", 0xA728 => "ꜩ", 0xA72A => "ꜫ", 0xA72C => "ꜭ", 0xA72E => "ꜯ", 0xA732 => "ꜳ", 0xA734 => "ꜵ", 0xA736 => "ꜷ", 0xA738 => "ꜹ", 0xA73A => "ꜻ", 0xA73C => "ꜽ", 0xA73E => "ꜿ", 0xA740 => "ꝁ", 0xA742 => "ꝃ", 0xA744 => "ꝅ", 0xA746 => "ꝇ", 0xA748 => "ꝉ", 0xA74A => "ꝋ", 0xA74C => "ꝍ", 0xA74E => "ꝏ", 0xA750 => "ꝑ", 0xA752 => "ꝓ", 0xA754 => "ꝕ", 0xA756 => "ꝗ", 0xA758 => "ꝙ", 0xA75A => "ꝛ", 0xA75C => "ꝝ", 0xA75E => "ꝟ", 0xA760 => "ꝡ", 0xA762 => "ꝣ", 0xA764 => "ꝥ", 0xA766 => "ꝧ", 0xA768 => "ꝩ", 0xA76A => "ꝫ", 0xA76C => "ꝭ", 0xA76E => "ꝯ", 0xA770 => "ꝯ", 0xA779 => "ꝺ", 0xA77B => "ꝼ", 0xA77D => "ᵹ", 0xA77E => "ꝿ", 0xA780 => "ꞁ", 0xA782 => "ꞃ", 0xA784 => "ꞅ", 0xA786 => "ꞇ", 0xA78B => "ꞌ", 0xA78D => "ɥ", 0xA790 => "ꞑ", 0xA792 => "ꞓ", 0xA796 => "ꞗ", 0xA798 => "ꞙ", 0xA79A => "ꞛ", 0xA79C => "ꞝ", 0xA79E => "ꞟ", 0xA7A0 => "ꞡ", 0xA7A2 => "ꞣ", 0xA7A4 => "ꞥ", 0xA7A6 => "ꞧ", 0xA7A8 => "ꞩ", 0xA7AA => "ɦ", 0xA7AB => "ɜ", 0xA7AC => "ɡ", 0xA7AD => "ɬ", 0xA7AE => "ɪ", 0xA7B0 => "ʞ", 0xA7B1 => "ʇ", 0xA7B2 => "ʝ", 0xA7B3 => "ꭓ", 0xA7B4 => "ꞵ", 0xA7B6 => "ꞷ", 0xA7F8 => "ħ", 0xA7F9 => "œ", 0xAB5C => "ꜧ", 0xAB5D => "ꬷ", 0xAB5E => "ɫ", 0xAB5F => "ꭒ", 0xAB70 => "Ꭰ", 0xAB71 => "Ꭱ", 0xAB72 => "Ꭲ", 0xAB73 => "Ꭳ", 0xAB74 => "Ꭴ", 0xAB75 => "Ꭵ", 0xAB76 => "Ꭶ", 0xAB77 => "Ꭷ", 0xAB78 => "Ꭸ", 0xAB79 => "Ꭹ", 0xAB7A => "Ꭺ", 0xAB7B => "Ꭻ", 0xAB7C => "Ꭼ", 0xAB7D => "Ꭽ", 0xAB7E => "Ꭾ", 0xAB7F => "Ꭿ", 0xAB80 => "Ꮀ", 0xAB81 => "Ꮁ", 0xAB82 => "Ꮂ", 0xAB83 => "Ꮃ", 0xAB84 => "Ꮄ", 0xAB85 => "Ꮅ", 0xAB86 => "Ꮆ", 0xAB87 => "Ꮇ", 0xAB88 => "Ꮈ", 0xAB89 => "Ꮉ", 0xAB8A => "Ꮊ", 0xAB8B => "Ꮋ", 0xAB8C => "Ꮌ", 0xAB8D => "Ꮍ", 0xAB8E => "Ꮎ", 0xAB8F => "Ꮏ", 0xAB90 => "Ꮐ", 0xAB91 => "Ꮑ", 0xAB92 => "Ꮒ", 0xAB93 => "Ꮓ", 0xAB94 => "Ꮔ", 0xAB95 => "Ꮕ", 0xAB96 => "Ꮖ", 0xAB97 => "Ꮗ", 0xAB98 => "Ꮘ", 0xAB99 => "Ꮙ", 0xAB9A => "Ꮚ", 0xAB9B => "Ꮛ", 0xAB9C => "Ꮜ", 0xAB9D => "Ꮝ", 0xAB9E => "Ꮞ", 0xAB9F => "Ꮟ", 0xABA0 => "Ꮠ", 0xABA1 => "Ꮡ", 0xABA2 => "Ꮢ", 0xABA3 => "Ꮣ", 0xABA4 => "Ꮤ", 0xABA5 => "Ꮥ", 0xABA6 => "Ꮦ", 0xABA7 => "Ꮧ", 0xABA8 => "Ꮨ", 0xABA9 => "Ꮩ", 0xABAA => "Ꮪ", 0xABAB => "Ꮫ", 0xABAC => "Ꮬ", 0xABAD => "Ꮭ", 0xABAE => "Ꮮ", 0xABAF => "Ꮯ", 0xABB0 => "Ꮰ", 0xABB1 => "Ꮱ", 0xABB2 => "Ꮲ", 0xABB3 => "Ꮳ", 0xABB4 => "Ꮴ", 0xABB5 => "Ꮵ", 0xABB6 => "Ꮶ", 0xABB7 => "Ꮷ", 0xABB8 => "Ꮸ", 0xABB9 => "Ꮹ", 0xABBA => "Ꮺ", 0xABBB => "Ꮻ", 0xABBC => "Ꮼ", 0xABBD => "Ꮽ", 0xABBE => "Ꮾ", 0xABBF => "Ꮿ", 0xF900 => "豈", 0xF901 => "更", 0xF902 => "車", 0xF903 => "賈", 0xF904 => "滑", 0xF905 => "串", 0xF906 => "句", 0xF907 => "龜", 0xF908 => "龜", 0xF909 => "契", 0xF90A => "金", 0xF90B => "喇", 0xF90C => "奈", 0xF90D => "懶", 0xF90E => "癩", 0xF90F => "羅", 0xF910 => "蘿", 0xF911 => "螺", 0xF912 => "裸", 0xF913 => "邏", 0xF914 => "樂", 0xF915 => "洛", 0xF916 => "烙", 0xF917 => "珞", 0xF918 => "落", 0xF919 => "酪", 0xF91A => "駱", 0xF91B => "亂", 0xF91C => "卵", 0xF91D => "欄", 0xF91E => "爛", 0xF91F => "蘭", 0xF920 => "鸞", 0xF921 => "嵐", 0xF922 => "濫", 0xF923 => "藍", 0xF924 => "襤", 0xF925 => "拉", 0xF926 => "臘", 0xF927 => "蠟", 0xF928 => "廊", 0xF929 => "朗", 0xF92A => "浪", 0xF92B => "狼", 0xF92C => "郎", 0xF92D => "來", 0xF92E => "冷", 0xF92F => "勞", 0xF930 => "擄", 0xF931 => "櫓", 0xF932 => "爐", 0xF933 => "盧", 0xF934 => "老", 0xF935 => "蘆", 0xF936 => "虜", 0xF937 => "路", 0xF938 => "露", 0xF939 => "魯", 0xF93A => "鷺", 0xF93B => "碌", 0xF93C => "祿", 0xF93D => "綠", 0xF93E => "菉", 0xF93F => "錄", 0xF940 => "鹿", 0xF941 => "論", 0xF942 => "壟", 0xF943 => "弄", 0xF944 => "籠", 0xF945 => "聾", 0xF946 => "牢", 0xF947 => "磊", 0xF948 => "賂", 0xF949 => "雷", 0xF94A => "壘", 0xF94B => "屢", 0xF94C => "樓", 0xF94D => "淚", 0xF94E => "漏", 0xF94F => "累", 0xF950 => "縷", 0xF951 => "陋", 0xF952 => "勒", 0xF953 => "肋", 0xF954 => "凜", 0xF955 => "凌", 0xF956 => "稜", 0xF957 => "綾", 0xF958 => "菱", 0xF959 => "陵", 0xF95A => "讀", 0xF95B => "拏", 0xF95C => "樂", 0xF95D => "諾", 0xF95E => "丹", 0xF95F => "寧", 0xF960 => "怒", 0xF961 => "率", 0xF962 => "異", 0xF963 => "北", 0xF964 => "磻", 0xF965 => "便", 0xF966 => "復", 0xF967 => "不", 0xF968 => "泌", 0xF969 => "數", 0xF96A => "索", 0xF96B => "參", 0xF96C => "塞", 0xF96D => "省", 0xF96E => "葉", 0xF96F => "說", 0xF970 => "殺", 0xF971 => "辰", 0xF972 => "沈", 0xF973 => "拾", 0xF974 => "若", 0xF975 => "掠", 0xF976 => "略", 0xF977 => "亮", 0xF978 => "兩", 0xF979 => "凉", 0xF97A => "梁", 0xF97B => "糧", 0xF97C => "良", 0xF97D => "諒", 0xF97E => "量", 0xF97F => "勵", 0xF980 => "呂", 0xF981 => "女", 0xF982 => "廬", 0xF983 => "旅", 0xF984 => "濾", 0xF985 => "礪", 0xF986 => "閭", 0xF987 => "驪", 0xF988 => "麗", 0xF989 => "黎", 0xF98A => "力", 0xF98B => "曆", 0xF98C => "歷", 0xF98D => "轢", 0xF98E => "年", 0xF98F => "憐", 0xF990 => "戀", 0xF991 => "撚", 0xF992 => "漣", 0xF993 => "煉", 0xF994 => "璉", 0xF995 => "秊", 0xF996 => "練", 0xF997 => "聯", 0xF998 => "輦", 0xF999 => "蓮", 0xF99A => "連", 0xF99B => "鍊", 0xF99C => "列", 0xF99D => "劣", 0xF99E => "咽", 0xF99F => "烈", 0xF9A0 => "裂", 0xF9A1 => "說", 0xF9A2 => "廉", 0xF9A3 => "念", 0xF9A4 => "捻", 0xF9A5 => "殮", 0xF9A6 => "簾", 0xF9A7 => "獵", 0xF9A8 => "令", 0xF9A9 => "囹", 0xF9AA => "寧", 0xF9AB => "嶺", 0xF9AC => "怜", 0xF9AD => "玲", 0xF9AE => "瑩", 0xF9AF => "羚", 0xF9B0 => "聆", 0xF9B1 => "鈴", 0xF9B2 => "零", 0xF9B3 => "靈", 0xF9B4 => "領", 0xF9B5 => "例", 0xF9B6 => "禮", 0xF9B7 => "醴", 0xF9B8 => "隸", 0xF9B9 => "惡", 0xF9BA => "了", 0xF9BB => "僚", 0xF9BC => "寮", 0xF9BD => "尿", 0xF9BE => "料", 0xF9BF => "樂", 0xF9C0 => "燎", 0xF9C1 => "療", 0xF9C2 => "蓼", 0xF9C3 => "遼", 0xF9C4 => "龍", 0xF9C5 => "暈", 0xF9C6 => "阮", 0xF9C7 => "劉", 0xF9C8 => "杻", 0xF9C9 => "柳", 0xF9CA => "流", 0xF9CB => "溜", 0xF9CC => "琉", 0xF9CD => "留", 0xF9CE => "硫", 0xF9CF => "紐", 0xF9D0 => "類", 0xF9D1 => "六", 0xF9D2 => "戮", 0xF9D3 => "陸", 0xF9D4 => "倫", 0xF9D5 => "崙", 0xF9D6 => "淪", 0xF9D7 => "輪", 0xF9D8 => "律", 0xF9D9 => "慄", 0xF9DA => "栗", 0xF9DB => "率", 0xF9DC => "隆", 0xF9DD => "利", 0xF9DE => "吏", 0xF9DF => "履", 0xF9E0 => "易", 0xF9E1 => "李", 0xF9E2 => "梨", 0xF9E3 => "泥", 0xF9E4 => "理", 0xF9E5 => "痢", 0xF9E6 => "罹", 0xF9E7 => "裏", 0xF9E8 => "裡", 0xF9E9 => "里", 0xF9EA => "離", 0xF9EB => "匿", 0xF9EC => "溺", 0xF9ED => "吝", 0xF9EE => "燐", 0xF9EF => "璘", 0xF9F0 => "藺", 0xF9F1 => "隣", 0xF9F2 => "鱗", 0xF9F3 => "麟", 0xF9F4 => "林", 0xF9F5 => "淋", 0xF9F6 => "臨", 0xF9F7 => "立", 0xF9F8 => "笠", 0xF9F9 => "粒", 0xF9FA => "狀", 0xF9FB => "炙", 0xF9FC => "識", 0xF9FD => "什", 0xF9FE => "茶", 0xF9FF => "刺", 0xFA00 => "切", 0xFA01 => "度", 0xFA02 => "拓", 0xFA03 => "糖", 0xFA04 => "宅", 0xFA05 => "洞", 0xFA06 => "暴", 0xFA07 => "輻", 0xFA08 => "行", 0xFA09 => "降", 0xFA0A => "見", 0xFA0B => "廓", 0xFA0C => "兀", 0xFA0D => "嗀", 0xFA10 => "塚", 0xFA12 => "晴", 0xFA15 => "凞", 0xFA16 => "猪", 0xFA17 => "益", 0xFA18 => "礼", 0xFA19 => "神", 0xFA1A => "祥", 0xFA1B => "福", 0xFA1C => "靖", 0xFA1D => "精", 0xFA1E => "羽", 0xFA20 => "蘒", 0xFA22 => "諸", 0xFA25 => "逸", 0xFA26 => "都", 0xFA2A => "飯", 0xFA2B => "飼", 0xFA2C => "館", 0xFA2D => "鶴", 0xFA2E => "郞", 0xFA2F => "隷", 0xFA30 => "侮", 0xFA31 => "僧", 0xFA32 => "免", 0xFA33 => "勉", 0xFA34 => "勤", 0xFA35 => "卑", 0xFA36 => "喝", 0xFA37 => "嘆", 0xFA38 => "器", 0xFA39 => "塀", 0xFA3A => "墨", 0xFA3B => "層", 0xFA3C => "屮", 0xFA3D => "悔", 0xFA3E => "慨", 0xFA3F => "憎", 0xFA40 => "懲", 0xFA41 => "敏", 0xFA42 => "既", 0xFA43 => "暑", 0xFA44 => "梅", 0xFA45 => "海", 0xFA46 => "渚", 0xFA47 => "漢", 0xFA48 => "煮", 0xFA49 => "爫", 0xFA4A => "琢", 0xFA4B => "碑", 0xFA4C => "社", 0xFA4D => "祉", 0xFA4E => "祈", 0xFA4F => "祐", 0xFA50 => "祖", 0xFA51 => "祝", 0xFA52 => "禍", 0xFA53 => "禎", 0xFA54 => "穀", 0xFA55 => "突", 0xFA56 => "節", 0xFA57 => "練", 0xFA58 => "縉", 0xFA59 => "繁", 0xFA5A => "署", 0xFA5B => "者", 0xFA5C => "臭", 0xFA5D => "艹", 0xFA5E => "艹", 0xFA5F => "著", 0xFA60 => "褐", 0xFA61 => "視", 0xFA62 => "謁", 0xFA63 => "謹", 0xFA64 => "賓", 0xFA65 => "贈", 0xFA66 => "辶", 0xFA67 => "逸", 0xFA68 => "難", 0xFA69 => "響", 0xFA6A => "頻", 0xFA6B => "恵", 0xFA6C => "𤋮", 0xFA6D => "舘", 0xFA70 => "並", 0xFA71 => "况", 0xFA72 => "全", 0xFA73 => "侀", 0xFA74 => "充", 0xFA75 => "冀", 0xFA76 => "勇", 0xFA77 => "勺", 0xFA78 => "喝", 0xFA79 => "啕", 0xFA7A => "喙", 0xFA7B => "嗢", 0xFA7C => "塚", 0xFA7D => "墳", 0xFA7E => "奄", 0xFA7F => "奔", 0xFA80 => "婢", 0xFA81 => "嬨", 0xFA82 => "廒", 0xFA83 => "廙", 0xFA84 => "彩", 0xFA85 => "徭", 0xFA86 => "惘", 0xFA87 => "慎", 0xFA88 => "愈", 0xFA89 => "憎", 0xFA8A => "慠", 0xFA8B => "懲", 0xFA8C => "戴", 0xFA8D => "揄", 0xFA8E => "搜", 0xFA8F => "摒", 0xFA90 => "敖", 0xFA91 => "晴", 0xFA92 => "朗", 0xFA93 => "望", 0xFA94 => "杖", 0xFA95 => "歹", 0xFA96 => "殺", 0xFA97 => "流", 0xFA98 => "滛", 0xFA99 => "滋", 0xFA9A => "漢", 0xFA9B => "瀞", 0xFA9C => "煮", 0xFA9D => "瞧", 0xFA9E => "爵", 0xFA9F => "犯", 0xFAA0 => "猪", 0xFAA1 => "瑱", 0xFAA2 => "甆", 0xFAA3 => "画", 0xFAA4 => "瘝", 0xFAA5 => "瘟", 0xFAA6 => "益", 0xFAA7 => "盛", 0xFAA8 => "直", 0xFAA9 => "睊", 0xFAAA => "着", 0xFAAB => "磌", 0xFAAC => "窱", 0xFAAD => "節", 0xFAAE => "类", 0xFAAF => "絛", 0xFAB0 => "練", 0xFAB1 => "缾", 0xFAB2 => "者", 0xFAB3 => "荒", 0xFAB4 => "華", 0xFAB5 => "蝹", 0xFAB6 => "襁", 0xFAB7 => "覆", 0xFAB8 => "視", 0xFAB9 => "調", 0xFABA => "諸", 0xFABB => "請", 0xFABC => "謁", 0xFABD => "諾", 0xFABE => "諭", 0xFABF => "謹", 0xFAC0 => "變", 0xFAC1 => "贈", 0xFAC2 => "輸", 0xFAC3 => "遲", 0xFAC4 => "醙", 0xFAC5 => "鉶", 0xFAC6 => "陼", 0xFAC7 => "難", 0xFAC8 => "靖", 0xFAC9 => "韛", 0xFACA => "響", 0xFACB => "頋", 0xFACC => "頻", 0xFACD => "鬒", 0xFACE => "龜", 0xFACF => "𢡊", 0xFAD0 => "𢡄", 0xFAD1 => "𣏕", 0xFAD2 => "㮝", 0xFAD3 => "䀘", 0xFAD4 => "䀹", 0xFAD5 => "𥉉", 0xFAD6 => "𥳐", 0xFAD7 => "𧻓", 0xFAD8 => "齃", 0xFAD9 => "龎", 0xFB00 => "ff", 0xFB01 => "fi", 0xFB02 => "fl", 0xFB03 => "ffi", 0xFB04 => "ffl", 0xFB05 => "st", 0xFB06 => "st", 0xFB13 => "մն", 0xFB14 => "մե", 0xFB15 => "մի", 0xFB16 => "վն", 0xFB17 => "մխ", 0xFB1D => "יִ", 0xFB1F => "ײַ", 0xFB20 => "ע", 0xFB21 => "א", 0xFB22 => "ד", 0xFB23 => "ה", 0xFB24 => "כ", 0xFB25 => "ל", 0xFB26 => "ם", 0xFB27 => "ר", 0xFB28 => "ת", 0xFB2A => "שׁ", 0xFB2B => "שׂ", 0xFB2C => "שּׁ", 0xFB2D => "שּׂ", 0xFB2E => "אַ", 0xFB2F => "אָ", 0xFB30 => "אּ", 0xFB31 => "בּ", 0xFB32 => "גּ", 0xFB33 => "דּ", 0xFB34 => "הּ", 0xFB35 => "וּ", 0xFB36 => "זּ", 0xFB38 => "טּ", 0xFB39 => "יּ", 0xFB3A => "ךּ", 0xFB3B => "כּ", 0xFB3C => "לּ", 0xFB3E => "מּ", 0xFB40 => "נּ", 0xFB41 => "סּ", 0xFB43 => "ףּ", 0xFB44 => "פּ", 0xFB46 => "צּ", 0xFB47 => "קּ", 0xFB48 => "רּ", 0xFB49 => "שּ", 0xFB4A => "תּ", 0xFB4B => "וֹ", 0xFB4C => "בֿ", 0xFB4D => "כֿ", 0xFB4E => "פֿ", 0xFB4F => "אל", 0xFB50 => "ٱ", 0xFB51 => "ٱ", 0xFB52 => "ٻ", 0xFB53 => "ٻ", 0xFB54 => "ٻ", 0xFB55 => "ٻ", 0xFB56 => "پ", 0xFB57 => "پ", 0xFB58 => "پ", 0xFB59 => "پ", 0xFB5A => "ڀ", 0xFB5B => "ڀ", 0xFB5C => "ڀ", 0xFB5D => "ڀ", 0xFB5E => "ٺ", 0xFB5F => "ٺ", 0xFB60 => "ٺ", 0xFB61 => "ٺ", 0xFB62 => "ٿ", 0xFB63 => "ٿ", 0xFB64 => "ٿ", 0xFB65 => "ٿ", 0xFB66 => "ٹ", 0xFB67 => "ٹ", 0xFB68 => "ٹ", 0xFB69 => "ٹ", 0xFB6A => "ڤ", 0xFB6B => "ڤ", 0xFB6C => "ڤ", 0xFB6D => "ڤ", 0xFB6E => "ڦ", 0xFB6F => "ڦ", 0xFB70 => "ڦ", 0xFB71 => "ڦ", 0xFB72 => "ڄ", 0xFB73 => "ڄ", 0xFB74 => "ڄ", 0xFB75 => "ڄ", 0xFB76 => "ڃ", 0xFB77 => "ڃ", 0xFB78 => "ڃ", 0xFB79 => "ڃ", 0xFB7A => "چ", 0xFB7B => "چ", 0xFB7C => "چ", 0xFB7D => "چ", 0xFB7E => "ڇ", 0xFB7F => "ڇ", 0xFB80 => "ڇ", 0xFB81 => "ڇ", 0xFB82 => "ڍ", 0xFB83 => "ڍ", 0xFB84 => "ڌ", 0xFB85 => "ڌ", 0xFB86 => "ڎ", 0xFB87 => "ڎ", 0xFB88 => "ڈ", 0xFB89 => "ڈ", 0xFB8A => "ژ", 0xFB8B => "ژ", 0xFB8C => "ڑ", 0xFB8D => "ڑ", 0xFB8E => "ک", 0xFB8F => "ک", 0xFB90 => "ک", 0xFB91 => "ک", 0xFB92 => "گ", 0xFB93 => "گ", 0xFB94 => "گ", 0xFB95 => "گ", 0xFB96 => "ڳ", 0xFB97 => "ڳ", 0xFB98 => "ڳ", 0xFB99 => "ڳ", 0xFB9A => "ڱ", 0xFB9B => "ڱ", 0xFB9C => "ڱ", 0xFB9D => "ڱ", 0xFB9E => "ں", 0xFB9F => "ں", 0xFBA0 => "ڻ", 0xFBA1 => "ڻ", 0xFBA2 => "ڻ", 0xFBA3 => "ڻ", 0xFBA4 => "ۀ", 0xFBA5 => "ۀ", 0xFBA6 => "ہ", 0xFBA7 => "ہ", 0xFBA8 => "ہ", 0xFBA9 => "ہ", 0xFBAA => "ھ", 0xFBAB => "ھ", 0xFBAC => "ھ", 0xFBAD => "ھ", 0xFBAE => "ے", 0xFBAF => "ے", 0xFBB0 => "ۓ", 0xFBB1 => "ۓ", 0xFBD3 => "ڭ", 0xFBD4 => "ڭ", 0xFBD5 => "ڭ", 0xFBD6 => "ڭ", 0xFBD7 => "ۇ", 0xFBD8 => "ۇ", 0xFBD9 => "ۆ", 0xFBDA => "ۆ", 0xFBDB => "ۈ", 0xFBDC => "ۈ", 0xFBDD => "ۇٴ", 0xFBDE => "ۋ", 0xFBDF => "ۋ", 0xFBE0 => "ۅ", 0xFBE1 => "ۅ", 0xFBE2 => "ۉ", 0xFBE3 => "ۉ", 0xFBE4 => "ې", 0xFBE5 => "ې", 0xFBE6 => "ې", 0xFBE7 => "ې", 0xFBE8 => "ى", 0xFBE9 => "ى", 0xFBEA => "ئا", 0xFBEB => "ئا", 0xFBEC => "ئە", 0xFBED => "ئە", 0xFBEE => "ئو", 0xFBEF => "ئو", 0xFBF0 => "ئۇ", 0xFBF1 => "ئۇ", 0xFBF2 => "ئۆ", 0xFBF3 => "ئۆ", 0xFBF4 => "ئۈ", 0xFBF5 => "ئۈ", 0xFBF6 => "ئې", 0xFBF7 => "ئې", 0xFBF8 => "ئې", 0xFBF9 => "ئى", 0xFBFA => "ئى", 0xFBFB => "ئى", 0xFBFC => "ی", 0xFBFD => "ی", 0xFBFE => "ی", 0xFBFF => "ی", 0xFC00 => "ئج", 0xFC01 => "ئح", 0xFC02 => "ئم", 0xFC03 => "ئى", 0xFC04 => "ئي", 0xFC05 => "بج", 0xFC06 => "بح", 0xFC07 => "بخ", 0xFC08 => "بم", 0xFC09 => "بى", 0xFC0A => "بي", 0xFC0B => "تج", 0xFC0C => "تح", 0xFC0D => "تخ", 0xFC0E => "تم", 0xFC0F => "تى", 0xFC10 => "تي", 0xFC11 => "ثج", 0xFC12 => "ثم", 0xFC13 => "ثى", 0xFC14 => "ثي", 0xFC15 => "جح", 0xFC16 => "جم", 0xFC17 => "حج", 0xFC18 => "حم", 0xFC19 => "خج", 0xFC1A => "خح", 0xFC1B => "خم", 0xFC1C => "سج", 0xFC1D => "سح", 0xFC1E => "سخ", 0xFC1F => "سم", 0xFC20 => "صح", 0xFC21 => "صم", 0xFC22 => "ضج", 0xFC23 => "ضح", 0xFC24 => "ضخ", 0xFC25 => "ضم", 0xFC26 => "طح", 0xFC27 => "طم", 0xFC28 => "ظم", 0xFC29 => "عج", 0xFC2A => "عم", 0xFC2B => "غج", 0xFC2C => "غم", 0xFC2D => "فج", 0xFC2E => "فح", 0xFC2F => "فخ", 0xFC30 => "فم", 0xFC31 => "فى", 0xFC32 => "في", 0xFC33 => "قح", 0xFC34 => "قم", 0xFC35 => "قى", 0xFC36 => "قي", 0xFC37 => "كا", 0xFC38 => "كج", 0xFC39 => "كح", 0xFC3A => "كخ", 0xFC3B => "كل", 0xFC3C => "كم", 0xFC3D => "كى", 0xFC3E => "كي", 0xFC3F => "لج", 0xFC40 => "لح", 0xFC41 => "لخ", 0xFC42 => "لم", 0xFC43 => "لى", 0xFC44 => "لي", 0xFC45 => "مج", 0xFC46 => "مح", 0xFC47 => "مخ", 0xFC48 => "مم", 0xFC49 => "مى", 0xFC4A => "مي", 0xFC4B => "نج", 0xFC4C => "نح", 0xFC4D => "نخ", 0xFC4E => "نم", 0xFC4F => "نى", 0xFC50 => "ني", 0xFC51 => "هج", 0xFC52 => "هم", 0xFC53 => "هى", 0xFC54 => "هي", 0xFC55 => "يج", 0xFC56 => "يح", 0xFC57 => "يخ", 0xFC58 => "يم", 0xFC59 => "يى", 0xFC5A => "يي", 0xFC5B => "ذٰ", 0xFC5C => "رٰ", 0xFC5D => "ىٰ", 0xFC64 => "ئر", 0xFC65 => "ئز", 0xFC66 => "ئم", 0xFC67 => "ئن", 0xFC68 => "ئى", 0xFC69 => "ئي", 0xFC6A => "بر", 0xFC6B => "بز", 0xFC6C => "بم", 0xFC6D => "بن", 0xFC6E => "بى", 0xFC6F => "بي", 0xFC70 => "تر", 0xFC71 => "تز", 0xFC72 => "تم", 0xFC73 => "تن", 0xFC74 => "تى", 0xFC75 => "تي", 0xFC76 => "ثر", 0xFC77 => "ثز", 0xFC78 => "ثم", 0xFC79 => "ثن", 0xFC7A => "ثى", 0xFC7B => "ثي", 0xFC7C => "فى", 0xFC7D => "في", 0xFC7E => "قى", 0xFC7F => "قي", 0xFC80 => "كا", 0xFC81 => "كل", 0xFC82 => "كم", 0xFC83 => "كى", 0xFC84 => "كي", 0xFC85 => "لم", 0xFC86 => "لى", 0xFC87 => "لي", 0xFC88 => "ما", 0xFC89 => "مم", 0xFC8A => "نر", 0xFC8B => "نز", 0xFC8C => "نم", 0xFC8D => "نن", 0xFC8E => "نى", 0xFC8F => "ني", 0xFC90 => "ىٰ", 0xFC91 => "ير", 0xFC92 => "يز", 0xFC93 => "يم", 0xFC94 => "ين", 0xFC95 => "يى", 0xFC96 => "يي", 0xFC97 => "ئج", 0xFC98 => "ئح", 0xFC99 => "ئخ", 0xFC9A => "ئم", 0xFC9B => "ئه", 0xFC9C => "بج", 0xFC9D => "بح", 0xFC9E => "بخ", 0xFC9F => "بم", 0xFCA0 => "به", 0xFCA1 => "تج", 0xFCA2 => "تح", 0xFCA3 => "تخ", 0xFCA4 => "تم", 0xFCA5 => "ته", 0xFCA6 => "ثم", 0xFCA7 => "جح", 0xFCA8 => "جم", 0xFCA9 => "حج", 0xFCAA => "حم", 0xFCAB => "خج", 0xFCAC => "خم", 0xFCAD => "سج", 0xFCAE => "سح", 0xFCAF => "سخ", 0xFCB0 => "سم", 0xFCB1 => "صح", 0xFCB2 => "صخ", 0xFCB3 => "صم", 0xFCB4 => "ضج", 0xFCB5 => "ضح", 0xFCB6 => "ضخ", 0xFCB7 => "ضم", 0xFCB8 => "طح", 0xFCB9 => "ظم", 0xFCBA => "عج", 0xFCBB => "عم", 0xFCBC => "غج", 0xFCBD => "غم", 0xFCBE => "فج", 0xFCBF => "فح", 0xFCC0 => "فخ", 0xFCC1 => "فم", 0xFCC2 => "قح", 0xFCC3 => "قم", 0xFCC4 => "كج", 0xFCC5 => "كح", 0xFCC6 => "كخ", 0xFCC7 => "كل", 0xFCC8 => "كم", 0xFCC9 => "لج", 0xFCCA => "لح", 0xFCCB => "لخ", 0xFCCC => "لم", 0xFCCD => "له", 0xFCCE => "مج", 0xFCCF => "مح", 0xFCD0 => "مخ", 0xFCD1 => "مم", 0xFCD2 => "نج", 0xFCD3 => "نح", 0xFCD4 => "نخ", 0xFCD5 => "نم", 0xFCD6 => "نه", 0xFCD7 => "هج", 0xFCD8 => "هم", 0xFCD9 => "هٰ", 0xFCDA => "يج", 0xFCDB => "يح", 0xFCDC => "يخ", 0xFCDD => "يم", 0xFCDE => "يه", 0xFCDF => "ئم", 0xFCE0 => "ئه", 0xFCE1 => "بم", 0xFCE2 => "به", 0xFCE3 => "تم", 0xFCE4 => "ته", 0xFCE5 => "ثم", 0xFCE6 => "ثه", 0xFCE7 => "سم", 0xFCE8 => "سه", 0xFCE9 => "شم", 0xFCEA => "شه", 0xFCEB => "كل", 0xFCEC => "كم", 0xFCED => "لم", 0xFCEE => "نم", 0xFCEF => "نه", 0xFCF0 => "يم", 0xFCF1 => "يه", 0xFCF2 => "ـَّ", 0xFCF3 => "ـُّ", 0xFCF4 => "ـِّ", 0xFCF5 => "طى", 0xFCF6 => "طي", 0xFCF7 => "عى", 0xFCF8 => "عي", 0xFCF9 => "غى", 0xFCFA => "غي", 0xFCFB => "سى", 0xFCFC => "سي", 0xFCFD => "شى", 0xFCFE => "شي", 0xFCFF => "حى", 0xFD00 => "حي", 0xFD01 => "جى", 0xFD02 => "جي", 0xFD03 => "خى", 0xFD04 => "خي", 0xFD05 => "صى", 0xFD06 => "صي", 0xFD07 => "ضى", 0xFD08 => "ضي", 0xFD09 => "شج", 0xFD0A => "شح", 0xFD0B => "شخ", 0xFD0C => "شم", 0xFD0D => "شر", 0xFD0E => "سر", 0xFD0F => "صر", 0xFD10 => "ضر", 0xFD11 => "طى", 0xFD12 => "طي", 0xFD13 => "عى", 0xFD14 => "عي", 0xFD15 => "غى", 0xFD16 => "غي", 0xFD17 => "سى", 0xFD18 => "سي", 0xFD19 => "شى", 0xFD1A => "شي", 0xFD1B => "حى", 0xFD1C => "حي", 0xFD1D => "جى", 0xFD1E => "جي", 0xFD1F => "خى", 0xFD20 => "خي", 0xFD21 => "صى", 0xFD22 => "صي", 0xFD23 => "ضى", 0xFD24 => "ضي", 0xFD25 => "شج", 0xFD26 => "شح", 0xFD27 => "شخ", 0xFD28 => "شم", 0xFD29 => "شر", 0xFD2A => "سر", 0xFD2B => "صر", 0xFD2C => "ضر", 0xFD2D => "شج", 0xFD2E => "شح", 0xFD2F => "شخ", 0xFD30 => "شم", 0xFD31 => "سه", 0xFD32 => "شه", 0xFD33 => "طم", 0xFD34 => "سج", 0xFD35 => "سح", 0xFD36 => "سخ", 0xFD37 => "شج", 0xFD38 => "شح", 0xFD39 => "شخ", 0xFD3A => "طم", 0xFD3B => "ظم", 0xFD3C => "اً", 0xFD3D => "اً", 0xFD50 => "تجم", 0xFD51 => "تحج", 0xFD52 => "تحج", 0xFD53 => "تحم", 0xFD54 => "تخم", 0xFD55 => "تمج", 0xFD56 => "تمح", 0xFD57 => "تمخ", 0xFD58 => "جمح", 0xFD59 => "جمح", 0xFD5A => "حمي", 0xFD5B => "حمى", 0xFD5C => "سحج", 0xFD5D => "سجح", 0xFD5E => "سجى", 0xFD5F => "سمح", 0xFD60 => "سمح", 0xFD61 => "سمج", 0xFD62 => "سمم", 0xFD63 => "سمم", 0xFD64 => "صحح", 0xFD65 => "صحح", 0xFD66 => "صمم", 0xFD67 => "شحم", 0xFD68 => "شحم", 0xFD69 => "شجي", 0xFD6A => "شمخ", 0xFD6B => "شمخ", 0xFD6C => "شمم", 0xFD6D => "شمم", 0xFD6E => "ضحى", 0xFD6F => "ضخم", 0xFD70 => "ضخم", 0xFD71 => "طمح", 0xFD72 => "طمح", 0xFD73 => "طمم", 0xFD74 => "طمي", 0xFD75 => "عجم", 0xFD76 => "عمم", 0xFD77 => "عمم", 0xFD78 => "عمى", 0xFD79 => "غمم", 0xFD7A => "غمي", 0xFD7B => "غمى", 0xFD7C => "فخم", 0xFD7D => "فخم", 0xFD7E => "قمح", 0xFD7F => "قمم", 0xFD80 => "لحم", 0xFD81 => "لحي", 0xFD82 => "لحى", 0xFD83 => "لجج", 0xFD84 => "لجج", 0xFD85 => "لخم", 0xFD86 => "لخم", 0xFD87 => "لمح", 0xFD88 => "لمح", 0xFD89 => "محج", 0xFD8A => "محم", 0xFD8B => "محي", 0xFD8C => "مجح", 0xFD8D => "مجم", 0xFD8E => "مخج", 0xFD8F => "مخم", 0xFD92 => "مجخ", 0xFD93 => "همج", 0xFD94 => "همم", 0xFD95 => "نحم", 0xFD96 => "نحى", 0xFD97 => "نجم", 0xFD98 => "نجم", 0xFD99 => "نجى", 0xFD9A => "نمي", 0xFD9B => "نمى", 0xFD9C => "يمم", 0xFD9D => "يمم", 0xFD9E => "بخي", 0xFD9F => "تجي", 0xFDA0 => "تجى", 0xFDA1 => "تخي", 0xFDA2 => "تخى", 0xFDA3 => "تمي", 0xFDA4 => "تمى", 0xFDA5 => "جمي", 0xFDA6 => "جحى", 0xFDA7 => "جمى", 0xFDA8 => "سخى", 0xFDA9 => "صحي", 0xFDAA => "شحي", 0xFDAB => "ضحي", 0xFDAC => "لجي", 0xFDAD => "لمي", 0xFDAE => "يحي", 0xFDAF => "يجي", 0xFDB0 => "يمي", 0xFDB1 => "ممي", 0xFDB2 => "قمي", 0xFDB3 => "نحي", 0xFDB4 => "قمح", 0xFDB5 => "لحم", 0xFDB6 => "عمي", 0xFDB7 => "كمي", 0xFDB8 => "نجح", 0xFDB9 => "مخي", 0xFDBA => "لجم", 0xFDBB => "كمم", 0xFDBC => "لجم", 0xFDBD => "نجح", 0xFDBE => "جحي", 0xFDBF => "حجي", 0xFDC0 => "مجي", 0xFDC1 => "فمي", 0xFDC2 => "بحي", 0xFDC3 => "كمم", 0xFDC4 => "عجم", 0xFDC5 => "صمم", 0xFDC6 => "سخي", 0xFDC7 => "نجي", 0xFDF0 => "صلے", 0xFDF1 => "قلے", 0xFDF2 => "الله", 0xFDF3 => "اكبر", 0xFDF4 => "محمد", 0xFDF5 => "صلعم", 0xFDF6 => "رسول", 0xFDF7 => "عليه", 0xFDF8 => "وسلم", 0xFDF9 => "صلى", 0xFDFC => "ریال", 0xFE11 => "\x{3001}", 0xFE17 => "\x{3016}", 0xFE18 => "\x{3017}", 0xFE31 => "\x{2014}", 0xFE32 => "\x{2013}", 0xFE39 => "\x{3014}", 0xFE3A => "\x{3015}", 0xFE3B => "\x{3010}", 0xFE3C => "\x{3011}", 0xFE3D => "\x{300A}", 0xFE3E => "\x{300B}", 0xFE3F => "\x{3008}", 0xFE40 => "\x{3009}", 0xFE41 => "\x{300C}", 0xFE42 => "\x{300D}", 0xFE43 => "\x{300E}", 0xFE44 => "\x{300F}", 0xFE51 => "\x{3001}", 0xFE58 => "\x{2014}", 0xFE5D => "\x{3014}", 0xFE5E => "\x{3015}", 0xFE63 => "\-", 0xFE71 => "ـً", 0xFE77 => "ـَ", 0xFE79 => "ـُ", 0xFE7B => "ـِ", 0xFE7D => "ـّ", 0xFE7F => "ـْ", 0xFE80 => "ء", 0xFE81 => "آ", 0xFE82 => "آ", 0xFE83 => "أ", 0xFE84 => "أ", 0xFE85 => "ؤ", 0xFE86 => "ؤ", 0xFE87 => "إ", 0xFE88 => "إ", 0xFE89 => "ئ", 0xFE8A => "ئ", 0xFE8B => "ئ", 0xFE8C => "ئ", 0xFE8D => "ا", 0xFE8E => "ا", 0xFE8F => "ب", 0xFE90 => "ب", 0xFE91 => "ب", 0xFE92 => "ب", 0xFE93 => "ة", 0xFE94 => "ة", 0xFE95 => "ت", 0xFE96 => "ت", 0xFE97 => "ت", 0xFE98 => "ت", 0xFE99 => "ث", 0xFE9A => "ث", 0xFE9B => "ث", 0xFE9C => "ث", 0xFE9D => "ج", 0xFE9E => "ج", 0xFE9F => "ج", 0xFEA0 => "ج", 0xFEA1 => "ح", 0xFEA2 => "ح", 0xFEA3 => "ح", 0xFEA4 => "ح", 0xFEA5 => "خ", 0xFEA6 => "خ", 0xFEA7 => "خ", 0xFEA8 => "خ", 0xFEA9 => "د", 0xFEAA => "د", 0xFEAB => "ذ", 0xFEAC => "ذ", 0xFEAD => "ر", 0xFEAE => "ر", 0xFEAF => "ز", 0xFEB0 => "ز", 0xFEB1 => "س", 0xFEB2 => "س", 0xFEB3 => "س", 0xFEB4 => "س", 0xFEB5 => "ش", 0xFEB6 => "ش", 0xFEB7 => "ش", 0xFEB8 => "ش", 0xFEB9 => "ص", 0xFEBA => "ص", 0xFEBB => "ص", 0xFEBC => "ص", 0xFEBD => "ض", 0xFEBE => "ض", 0xFEBF => "ض", 0xFEC0 => "ض", 0xFEC1 => "ط", 0xFEC2 => "ط", 0xFEC3 => "ط", 0xFEC4 => "ط", 0xFEC5 => "ظ", 0xFEC6 => "ظ", 0xFEC7 => "ظ", 0xFEC8 => "ظ", 0xFEC9 => "ع", 0xFECA => "ع", 0xFECB => "ع", 0xFECC => "ع", 0xFECD => "غ", 0xFECE => "غ", 0xFECF => "غ", 0xFED0 => "غ", 0xFED1 => "ف", 0xFED2 => "ف", 0xFED3 => "ف", 0xFED4 => "ف", 0xFED5 => "ق", 0xFED6 => "ق", 0xFED7 => "ق", 0xFED8 => "ق", 0xFED9 => "ك", 0xFEDA => "ك", 0xFEDB => "ك", 0xFEDC => "ك", 0xFEDD => "ل", 0xFEDE => "ل", 0xFEDF => "ل", 0xFEE0 => "ل", 0xFEE1 => "م", 0xFEE2 => "م", 0xFEE3 => "م", 0xFEE4 => "م", 0xFEE5 => "ن", 0xFEE6 => "ن", 0xFEE7 => "ن", 0xFEE8 => "ن", 0xFEE9 => "ه", 0xFEEA => "ه", 0xFEEB => "ه", 0xFEEC => "ه", 0xFEED => "و", 0xFEEE => "و", 0xFEEF => "ى", 0xFEF0 => "ى", 0xFEF1 => "ي", 0xFEF2 => "ي", 0xFEF3 => "ي", 0xFEF4 => "ي", 0xFEF5 => "لآ", 0xFEF6 => "لآ", 0xFEF7 => "لأ", 0xFEF8 => "لأ", 0xFEF9 => "لإ", 0xFEFA => "لإ", 0xFEFB => "لا", 0xFEFC => "لا", 0xFF0D => "\-", 0xFF0E => "\.", 0xFF10 => "0", 0xFF11 => "1", 0xFF12 => "2", 0xFF13 => "3", 0xFF14 => "4", 0xFF15 => "5", 0xFF16 => "6", 0xFF17 => "7", 0xFF18 => "8", 0xFF19 => "9", 0xFF21 => "a", 0xFF22 => "b", 0xFF23 => "c", 0xFF24 => "d", 0xFF25 => "e", 0xFF26 => "f", 0xFF27 => "g", 0xFF28 => "h", 0xFF29 => "i", 0xFF2A => "j", 0xFF2B => "k", 0xFF2C => "l", 0xFF2D => "m", 0xFF2E => "n", 0xFF2F => "o", 0xFF30 => "p", 0xFF31 => "q", 0xFF32 => "r", 0xFF33 => "s", 0xFF34 => "t", 0xFF35 => "u", 0xFF36 => "v", 0xFF37 => "w", 0xFF38 => "x", 0xFF39 => "y", 0xFF3A => "z", 0xFF41 => "a", 0xFF42 => "b", 0xFF43 => "c", 0xFF44 => "d", 0xFF45 => "e", 0xFF46 => "f", 0xFF47 => "g", 0xFF48 => "h", 0xFF49 => "i", 0xFF4A => "j", 0xFF4B => "k", 0xFF4C => "l", 0xFF4D => "m", 0xFF4E => "n", 0xFF4F => "o", 0xFF50 => "p", 0xFF51 => "q", 0xFF52 => "r", 0xFF53 => "s", 0xFF54 => "t", 0xFF55 => "u", 0xFF56 => "v", 0xFF57 => "w", 0xFF58 => "x", 0xFF59 => "y", 0xFF5A => "z", 0xFF5F => "\x{2985}", 0xFF60 => "\x{2986}", 0xFF61 => "\.", 0xFF62 => "\x{300C}", 0xFF63 => "\x{300D}", 0xFF64 => "\x{3001}", 0xFF65 => "\x{30FB}", 0xFF66 => "ヲ", 0xFF67 => "ァ", 0xFF68 => "ィ", 0xFF69 => "ゥ", 0xFF6A => "ェ", 0xFF6B => "ォ", 0xFF6C => "ャ", 0xFF6D => "ュ", 0xFF6E => "ョ", 0xFF6F => "ッ", 0xFF70 => "ー", 0xFF71 => "ア", 0xFF72 => "イ", 0xFF73 => "ウ", 0xFF74 => "エ", 0xFF75 => "オ", 0xFF76 => "カ", 0xFF77 => "キ", 0xFF78 => "ク", 0xFF79 => "ケ", 0xFF7A => "コ", 0xFF7B => "サ", 0xFF7C => "シ", 0xFF7D => "ス", 0xFF7E => "セ", 0xFF7F => "ソ", 0xFF80 => "タ", 0xFF81 => "チ", 0xFF82 => "ツ", 0xFF83 => "テ", 0xFF84 => "ト", 0xFF85 => "ナ", 0xFF86 => "ニ", 0xFF87 => "ヌ", 0xFF88 => "ネ", 0xFF89 => "ノ", 0xFF8A => "ハ", 0xFF8B => "ヒ", 0xFF8C => "フ", 0xFF8D => "ヘ", 0xFF8E => "ホ", 0xFF8F => "マ", 0xFF90 => "ミ", 0xFF91 => "ム", 0xFF92 => "メ", 0xFF93 => "モ", 0xFF94 => "ヤ", 0xFF95 => "ユ", 0xFF96 => "ヨ", 0xFF97 => "ラ", 0xFF98 => "リ", 0xFF99 => "ル", 0xFF9A => "レ", 0xFF9B => "ロ", 0xFF9C => "ワ", 0xFF9D => "ン", 0xFF9E => "\x{3099}", 0xFF9F => "\x{309A}", 0xFFA1 => "ᄀ", 0xFFA2 => "ᄁ", 0xFFA3 => "ᆪ", 0xFFA4 => "ᄂ", 0xFFA5 => "ᆬ", 0xFFA6 => "ᆭ", 0xFFA7 => "ᄃ", 0xFFA8 => "ᄄ", 0xFFA9 => "ᄅ", 0xFFAA => "ᆰ", 0xFFAB => "ᆱ", 0xFFAC => "ᆲ", 0xFFAD => "ᆳ", 0xFFAE => "ᆴ", 0xFFAF => "ᆵ", 0xFFB0 => "ᄚ", 0xFFB1 => "ᄆ", 0xFFB2 => "ᄇ", 0xFFB3 => "ᄈ", 0xFFB4 => "ᄡ", 0xFFB5 => "ᄉ", 0xFFB6 => "ᄊ", 0xFFB7 => "ᄋ", 0xFFB8 => "ᄌ", 0xFFB9 => "ᄍ", 0xFFBA => "ᄎ", 0xFFBB => "ᄏ", 0xFFBC => "ᄐ", 0xFFBD => "ᄑ", 0xFFBE => "ᄒ", 0xFFC2 => "ᅡ", 0xFFC3 => "ᅢ", 0xFFC4 => "ᅣ", 0xFFC5 => "ᅤ", 0xFFC6 => "ᅥ", 0xFFC7 => "ᅦ", 0xFFCA => "ᅧ", 0xFFCB => "ᅨ", 0xFFCC => "ᅩ", 0xFFCD => "ᅪ", 0xFFCE => "ᅫ", 0xFFCF => "ᅬ", 0xFFD2 => "ᅭ", 0xFFD3 => "ᅮ", 0xFFD4 => "ᅯ", 0xFFD5 => "ᅰ", 0xFFD6 => "ᅱ", 0xFFD7 => "ᅲ", 0xFFDA => "ᅳ", 0xFFDB => "ᅴ", 0xFFDC => "ᅵ", 0xFFE0 => "\x{00A2}", 0xFFE1 => "\x{00A3}", 0xFFE2 => "\x{00AC}", 0xFFE4 => "\x{00A6}", 0xFFE5 => "\x{00A5}", 0xFFE6 => "\x{20A9}", 0xFFE8 => "\x{2502}", 0xFFE9 => "\x{2190}", 0xFFEA => "\x{2191}", 0xFFEB => "\x{2192}", 0xFFEC => "\x{2193}", 0xFFED => "\x{25A0}", 0xFFEE => "\x{25CB}", 0x10400 => "𐐨", 0x10401 => "𐐩", 0x10402 => "𐐪", 0x10403 => "𐐫", 0x10404 => "𐐬", 0x10405 => "𐐭", 0x10406 => "𐐮", 0x10407 => "𐐯", 0x10408 => "𐐰", 0x10409 => "𐐱", 0x1040A => "𐐲", 0x1040B => "𐐳", 0x1040C => "𐐴", 0x1040D => "𐐵", 0x1040E => "𐐶", 0x1040F => "𐐷", 0x10410 => "𐐸", 0x10411 => "𐐹", 0x10412 => "𐐺", 0x10413 => "𐐻", 0x10414 => "𐐼", 0x10415 => "𐐽", 0x10416 => "𐐾", 0x10417 => "𐐿", 0x10418 => "𐑀", 0x10419 => "𐑁", 0x1041A => "𐑂", 0x1041B => "𐑃", 0x1041C => "𐑄", 0x1041D => "𐑅", 0x1041E => "𐑆", 0x1041F => "𐑇", 0x10420 => "𐑈", 0x10421 => "𐑉", 0x10422 => "𐑊", 0x10423 => "𐑋", 0x10424 => "𐑌", 0x10425 => "𐑍", 0x10426 => "𐑎", 0x10427 => "𐑏", 0x104B0 => "𐓘", 0x104B1 => "𐓙", 0x104B2 => "𐓚", 0x104B3 => "𐓛", 0x104B4 => "𐓜", 0x104B5 => "𐓝", 0x104B6 => "𐓞", 0x104B7 => "𐓟", 0x104B8 => "𐓠", 0x104B9 => "𐓡", 0x104BA => "𐓢", 0x104BB => "𐓣", 0x104BC => "𐓤", 0x104BD => "𐓥", 0x104BE => "𐓦", 0x104BF => "𐓧", 0x104C0 => "𐓨", 0x104C1 => "𐓩", 0x104C2 => "𐓪", 0x104C3 => "𐓫", 0x104C4 => "𐓬", 0x104C5 => "𐓭", 0x104C6 => "𐓮", 0x104C7 => "𐓯", 0x104C8 => "𐓰", 0x104C9 => "𐓱", 0x104CA => "𐓲", 0x104CB => "𐓳", 0x104CC => "𐓴", 0x104CD => "𐓵", 0x104CE => "𐓶", 0x104CF => "𐓷", 0x104D0 => "𐓸", 0x104D1 => "𐓹", 0x104D2 => "𐓺", 0x104D3 => "𐓻", 0x10C80 => "𐳀", 0x10C81 => "𐳁", 0x10C82 => "𐳂", 0x10C83 => "𐳃", 0x10C84 => "𐳄", 0x10C85 => "𐳅", 0x10C86 => "𐳆", 0x10C87 => "𐳇", 0x10C88 => "𐳈", 0x10C89 => "𐳉", 0x10C8A => "𐳊", 0x10C8B => "𐳋", 0x10C8C => "𐳌", 0x10C8D => "𐳍", 0x10C8E => "𐳎", 0x10C8F => "𐳏", 0x10C90 => "𐳐", 0x10C91 => "𐳑", 0x10C92 => "𐳒", 0x10C93 => "𐳓", 0x10C94 => "𐳔", 0x10C95 => "𐳕", 0x10C96 => "𐳖", 0x10C97 => "𐳗", 0x10C98 => "𐳘", 0x10C99 => "𐳙", 0x10C9A => "𐳚", 0x10C9B => "𐳛", 0x10C9C => "𐳜", 0x10C9D => "𐳝", 0x10C9E => "𐳞", 0x10C9F => "𐳟", 0x10CA0 => "𐳠", 0x10CA1 => "𐳡", 0x10CA2 => "𐳢", 0x10CA3 => "𐳣", 0x10CA4 => "𐳤", 0x10CA5 => "𐳥", 0x10CA6 => "𐳦", 0x10CA7 => "𐳧", 0x10CA8 => "𐳨", 0x10CA9 => "𐳩", 0x10CAA => "𐳪", 0x10CAB => "𐳫", 0x10CAC => "𐳬", 0x10CAD => "𐳭", 0x10CAE => "𐳮", 0x10CAF => "𐳯", 0x10CB0 => "𐳰", 0x10CB1 => "𐳱", 0x10CB2 => "𐳲", 0x118A0 => "𑣀", 0x118A1 => "𑣁", 0x118A2 => "𑣂", 0x118A3 => "𑣃", 0x118A4 => "𑣄", 0x118A5 => "𑣅", 0x118A6 => "𑣆", 0x118A7 => "𑣇", 0x118A8 => "𑣈", 0x118A9 => "𑣉", 0x118AA => "𑣊", 0x118AB => "𑣋", 0x118AC => "𑣌", 0x118AD => "𑣍", 0x118AE => "𑣎", 0x118AF => "𑣏", 0x118B0 => "𑣐", 0x118B1 => "𑣑", 0x118B2 => "𑣒", 0x118B3 => "𑣓", 0x118B4 => "𑣔", 0x118B5 => "𑣕", 0x118B6 => "𑣖", 0x118B7 => "𑣗", 0x118B8 => "𑣘", 0x118B9 => "𑣙", 0x118BA => "𑣚", 0x118BB => "𑣛", 0x118BC => "𑣜", 0x118BD => "𑣝", 0x118BE => "𑣞", 0x118BF => "𑣟", 0x1D15E => "\x{1D157}\x{1D165}", 0x1D15F => "\x{1D158}\x{1D165}", 0x1D160 => "\x{1D158}\x{1D165}\x{1D16E}", 0x1D161 => "\x{1D158}\x{1D165}\x{1D16F}", 0x1D162 => "\x{1D158}\x{1D165}\x{1D170}", 0x1D163 => "\x{1D158}\x{1D165}\x{1D171}", 0x1D164 => "\x{1D158}\x{1D165}\x{1D172}", 0x1D1BB => "\x{1D1B9}\x{1D165}", 0x1D1BC => "\x{1D1BA}\x{1D165}", 0x1D1BD => "\x{1D1B9}\x{1D165}\x{1D16E}", 0x1D1BE => "\x{1D1BA}\x{1D165}\x{1D16E}", 0x1D1BF => "\x{1D1B9}\x{1D165}\x{1D16F}", 0x1D1C0 => "\x{1D1BA}\x{1D165}\x{1D16F}", 0x1D400 => "a", 0x1D401 => "b", 0x1D402 => "c", 0x1D403 => "d", 0x1D404 => "e", 0x1D405 => "f", 0x1D406 => "g", 0x1D407 => "h", 0x1D408 => "i", 0x1D409 => "j", 0x1D40A => "k", 0x1D40B => "l", 0x1D40C => "m", 0x1D40D => "n", 0x1D40E => "o", 0x1D40F => "p", 0x1D410 => "q", 0x1D411 => "r", 0x1D412 => "s", 0x1D413 => "t", 0x1D414 => "u", 0x1D415 => "v", 0x1D416 => "w", 0x1D417 => "x", 0x1D418 => "y", 0x1D419 => "z", 0x1D41A => "a", 0x1D41B => "b", 0x1D41C => "c", 0x1D41D => "d", 0x1D41E => "e", 0x1D41F => "f", 0x1D420 => "g", 0x1D421 => "h", 0x1D422 => "i", 0x1D423 => "j", 0x1D424 => "k", 0x1D425 => "l", 0x1D426 => "m", 0x1D427 => "n", 0x1D428 => "o", 0x1D429 => "p", 0x1D42A => "q", 0x1D42B => "r", 0x1D42C => "s", 0x1D42D => "t", 0x1D42E => "u", 0x1D42F => "v", 0x1D430 => "w", 0x1D431 => "x", 0x1D432 => "y", 0x1D433 => "z", 0x1D434 => "a", 0x1D435 => "b", 0x1D436 => "c", 0x1D437 => "d", 0x1D438 => "e", 0x1D439 => "f", 0x1D43A => "g", 0x1D43B => "h", 0x1D43C => "i", 0x1D43D => "j", 0x1D43E => "k", 0x1D43F => "l", 0x1D440 => "m", 0x1D441 => "n", 0x1D442 => "o", 0x1D443 => "p", 0x1D444 => "q", 0x1D445 => "r", 0x1D446 => "s", 0x1D447 => "t", 0x1D448 => "u", 0x1D449 => "v", 0x1D44A => "w", 0x1D44B => "x", 0x1D44C => "y", 0x1D44D => "z", 0x1D44E => "a", 0x1D44F => "b", 0x1D450 => "c", 0x1D451 => "d", 0x1D452 => "e", 0x1D453 => "f", 0x1D454 => "g", 0x1D456 => "i", 0x1D457 => "j", 0x1D458 => "k", 0x1D459 => "l", 0x1D45A => "m", 0x1D45B => "n", 0x1D45C => "o", 0x1D45D => "p", 0x1D45E => "q", 0x1D45F => "r", 0x1D460 => "s", 0x1D461 => "t", 0x1D462 => "u", 0x1D463 => "v", 0x1D464 => "w", 0x1D465 => "x", 0x1D466 => "y", 0x1D467 => "z", 0x1D468 => "a", 0x1D469 => "b", 0x1D46A => "c", 0x1D46B => "d", 0x1D46C => "e", 0x1D46D => "f", 0x1D46E => "g", 0x1D46F => "h", 0x1D470 => "i", 0x1D471 => "j", 0x1D472 => "k", 0x1D473 => "l", 0x1D474 => "m", 0x1D475 => "n", 0x1D476 => "o", 0x1D477 => "p", 0x1D478 => "q", 0x1D479 => "r", 0x1D47A => "s", 0x1D47B => "t", 0x1D47C => "u", 0x1D47D => "v", 0x1D47E => "w", 0x1D47F => "x", 0x1D480 => "y", 0x1D481 => "z", 0x1D482 => "a", 0x1D483 => "b", 0x1D484 => "c", 0x1D485 => "d", 0x1D486 => "e", 0x1D487 => "f", 0x1D488 => "g", 0x1D489 => "h", 0x1D48A => "i", 0x1D48B => "j", 0x1D48C => "k", 0x1D48D => "l", 0x1D48E => "m", 0x1D48F => "n", 0x1D490 => "o", 0x1D491 => "p", 0x1D492 => "q", 0x1D493 => "r", 0x1D494 => "s", 0x1D495 => "t", 0x1D496 => "u", 0x1D497 => "v", 0x1D498 => "w", 0x1D499 => "x", 0x1D49A => "y", 0x1D49B => "z", 0x1D49C => "a", 0x1D49E => "c", 0x1D49F => "d", 0x1D4A2 => "g", 0x1D4A5 => "j", 0x1D4A6 => "k", 0x1D4A9 => "n", 0x1D4AA => "o", 0x1D4AB => "p", 0x1D4AC => "q", 0x1D4AE => "s", 0x1D4AF => "t", 0x1D4B0 => "u", 0x1D4B1 => "v", 0x1D4B2 => "w", 0x1D4B3 => "x", 0x1D4B4 => "y", 0x1D4B5 => "z", 0x1D4B6 => "a", 0x1D4B7 => "b", 0x1D4B8 => "c", 0x1D4B9 => "d", 0x1D4BB => "f", 0x1D4BD => "h", 0x1D4BE => "i", 0x1D4BF => "j", 0x1D4C0 => "k", 0x1D4C1 => "l", 0x1D4C2 => "m", 0x1D4C3 => "n", 0x1D4C5 => "p", 0x1D4C6 => "q", 0x1D4C7 => "r", 0x1D4C8 => "s", 0x1D4C9 => "t", 0x1D4CA => "u", 0x1D4CB => "v", 0x1D4CC => "w", 0x1D4CD => "x", 0x1D4CE => "y", 0x1D4CF => "z", 0x1D4D0 => "a", 0x1D4D1 => "b", 0x1D4D2 => "c", 0x1D4D3 => "d", 0x1D4D4 => "e", 0x1D4D5 => "f", 0x1D4D6 => "g", 0x1D4D7 => "h", 0x1D4D8 => "i", 0x1D4D9 => "j", 0x1D4DA => "k", 0x1D4DB => "l", 0x1D4DC => "m", 0x1D4DD => "n", 0x1D4DE => "o", 0x1D4DF => "p", 0x1D4E0 => "q", 0x1D4E1 => "r", 0x1D4E2 => "s", 0x1D4E3 => "t", 0x1D4E4 => "u", 0x1D4E5 => "v", 0x1D4E6 => "w", 0x1D4E7 => "x", 0x1D4E8 => "y", 0x1D4E9 => "z", 0x1D4EA => "a", 0x1D4EB => "b", 0x1D4EC => "c", 0x1D4ED => "d", 0x1D4EE => "e", 0x1D4EF => "f", 0x1D4F0 => "g", 0x1D4F1 => "h", 0x1D4F2 => "i", 0x1D4F3 => "j", 0x1D4F4 => "k", 0x1D4F5 => "l", 0x1D4F6 => "m", 0x1D4F7 => "n", 0x1D4F8 => "o", 0x1D4F9 => "p", 0x1D4FA => "q", 0x1D4FB => "r", 0x1D4FC => "s", 0x1D4FD => "t", 0x1D4FE => "u", 0x1D4FF => "v", 0x1D500 => "w", 0x1D501 => "x", 0x1D502 => "y", 0x1D503 => "z", 0x1D504 => "a", 0x1D505 => "b", 0x1D507 => "d", 0x1D508 => "e", 0x1D509 => "f", 0x1D50A => "g", 0x1D50D => "j", 0x1D50E => "k", 0x1D50F => "l", 0x1D510 => "m", 0x1D511 => "n", 0x1D512 => "o", 0x1D513 => "p", 0x1D514 => "q", 0x1D516 => "s", 0x1D517 => "t", 0x1D518 => "u", 0x1D519 => "v", 0x1D51A => "w", 0x1D51B => "x", 0x1D51C => "y", 0x1D51E => "a", 0x1D51F => "b", 0x1D520 => "c", 0x1D521 => "d", 0x1D522 => "e", 0x1D523 => "f", 0x1D524 => "g", 0x1D525 => "h", 0x1D526 => "i", 0x1D527 => "j", 0x1D528 => "k", 0x1D529 => "l", 0x1D52A => "m", 0x1D52B => "n", 0x1D52C => "o", 0x1D52D => "p", 0x1D52E => "q", 0x1D52F => "r", 0x1D530 => "s", 0x1D531 => "t", 0x1D532 => "u", 0x1D533 => "v", 0x1D534 => "w", 0x1D535 => "x", 0x1D536 => "y", 0x1D537 => "z", 0x1D538 => "a", 0x1D539 => "b", 0x1D53B => "d", 0x1D53C => "e", 0x1D53D => "f", 0x1D53E => "g", 0x1D540 => "i", 0x1D541 => "j", 0x1D542 => "k", 0x1D543 => "l", 0x1D544 => "m", 0x1D546 => "o", 0x1D54A => "s", 0x1D54B => "t", 0x1D54C => "u", 0x1D54D => "v", 0x1D54E => "w", 0x1D54F => "x", 0x1D550 => "y", 0x1D552 => "a", 0x1D553 => "b", 0x1D554 => "c", 0x1D555 => "d", 0x1D556 => "e", 0x1D557 => "f", 0x1D558 => "g", 0x1D559 => "h", 0x1D55A => "i", 0x1D55B => "j", 0x1D55C => "k", 0x1D55D => "l", 0x1D55E => "m", 0x1D55F => "n", 0x1D560 => "o", 0x1D561 => "p", 0x1D562 => "q", 0x1D563 => "r", 0x1D564 => "s", 0x1D565 => "t", 0x1D566 => "u", 0x1D567 => "v", 0x1D568 => "w", 0x1D569 => "x", 0x1D56A => "y", 0x1D56B => "z", 0x1D56C => "a", 0x1D56D => "b", 0x1D56E => "c", 0x1D56F => "d", 0x1D570 => "e", 0x1D571 => "f", 0x1D572 => "g", 0x1D573 => "h", 0x1D574 => "i", 0x1D575 => "j", 0x1D576 => "k", 0x1D577 => "l", 0x1D578 => "m", 0x1D579 => "n", 0x1D57A => "o", 0x1D57B => "p", 0x1D57C => "q", 0x1D57D => "r", 0x1D57E => "s", 0x1D57F => "t", 0x1D580 => "u", 0x1D581 => "v", 0x1D582 => "w", 0x1D583 => "x", 0x1D584 => "y", 0x1D585 => "z", 0x1D586 => "a", 0x1D587 => "b", 0x1D588 => "c", 0x1D589 => "d", 0x1D58A => "e", 0x1D58B => "f", 0x1D58C => "g", 0x1D58D => "h", 0x1D58E => "i", 0x1D58F => "j", 0x1D590 => "k", 0x1D591 => "l", 0x1D592 => "m", 0x1D593 => "n", 0x1D594 => "o", 0x1D595 => "p", 0x1D596 => "q", 0x1D597 => "r", 0x1D598 => "s", 0x1D599 => "t", 0x1D59A => "u", 0x1D59B => "v", 0x1D59C => "w", 0x1D59D => "x", 0x1D59E => "y", 0x1D59F => "z", 0x1D5A0 => "a", 0x1D5A1 => "b", 0x1D5A2 => "c", 0x1D5A3 => "d", 0x1D5A4 => "e", 0x1D5A5 => "f", 0x1D5A6 => "g", 0x1D5A7 => "h", 0x1D5A8 => "i", 0x1D5A9 => "j", 0x1D5AA => "k", 0x1D5AB => "l", 0x1D5AC => "m", 0x1D5AD => "n", 0x1D5AE => "o", 0x1D5AF => "p", 0x1D5B0 => "q", 0x1D5B1 => "r", 0x1D5B2 => "s", 0x1D5B3 => "t", 0x1D5B4 => "u", 0x1D5B5 => "v", 0x1D5B6 => "w", 0x1D5B7 => "x", 0x1D5B8 => "y", 0x1D5B9 => "z", 0x1D5BA => "a", 0x1D5BB => "b", 0x1D5BC => "c", 0x1D5BD => "d", 0x1D5BE => "e", 0x1D5BF => "f", 0x1D5C0 => "g", 0x1D5C1 => "h", 0x1D5C2 => "i", 0x1D5C3 => "j", 0x1D5C4 => "k", 0x1D5C5 => "l", 0x1D5C6 => "m", 0x1D5C7 => "n", 0x1D5C8 => "o", 0x1D5C9 => "p", 0x1D5CA => "q", 0x1D5CB => "r", 0x1D5CC => "s", 0x1D5CD => "t", 0x1D5CE => "u", 0x1D5CF => "v", 0x1D5D0 => "w", 0x1D5D1 => "x", 0x1D5D2 => "y", 0x1D5D3 => "z", 0x1D5D4 => "a", 0x1D5D5 => "b", 0x1D5D6 => "c", 0x1D5D7 => "d", 0x1D5D8 => "e", 0x1D5D9 => "f", 0x1D5DA => "g", 0x1D5DB => "h", 0x1D5DC => "i", 0x1D5DD => "j", 0x1D5DE => "k", 0x1D5DF => "l", 0x1D5E0 => "m", 0x1D5E1 => "n", 0x1D5E2 => "o", 0x1D5E3 => "p", 0x1D5E4 => "q", 0x1D5E5 => "r", 0x1D5E6 => "s", 0x1D5E7 => "t", 0x1D5E8 => "u", 0x1D5E9 => "v", 0x1D5EA => "w", 0x1D5EB => "x", 0x1D5EC => "y", 0x1D5ED => "z", 0x1D5EE => "a", 0x1D5EF => "b", 0x1D5F0 => "c", 0x1D5F1 => "d", 0x1D5F2 => "e", 0x1D5F3 => "f", 0x1D5F4 => "g", 0x1D5F5 => "h", 0x1D5F6 => "i", 0x1D5F7 => "j", 0x1D5F8 => "k", 0x1D5F9 => "l", 0x1D5FA => "m", 0x1D5FB => "n", 0x1D5FC => "o", 0x1D5FD => "p", 0x1D5FE => "q", 0x1D5FF => "r", 0x1D600 => "s", 0x1D601 => "t", 0x1D602 => "u", 0x1D603 => "v", 0x1D604 => "w", 0x1D605 => "x", 0x1D606 => "y", 0x1D607 => "z", 0x1D608 => "a", 0x1D609 => "b", 0x1D60A => "c", 0x1D60B => "d", 0x1D60C => "e", 0x1D60D => "f", 0x1D60E => "g", 0x1D60F => "h", 0x1D610 => "i", 0x1D611 => "j", 0x1D612 => "k", 0x1D613 => "l", 0x1D614 => "m", 0x1D615 => "n", 0x1D616 => "o", 0x1D617 => "p", 0x1D618 => "q", 0x1D619 => "r", 0x1D61A => "s", 0x1D61B => "t", 0x1D61C => "u", 0x1D61D => "v", 0x1D61E => "w", 0x1D61F => "x", 0x1D620 => "y", 0x1D621 => "z", 0x1D622 => "a", 0x1D623 => "b", 0x1D624 => "c", 0x1D625 => "d", 0x1D626 => "e", 0x1D627 => "f", 0x1D628 => "g", 0x1D629 => "h", 0x1D62A => "i", 0x1D62B => "j", 0x1D62C => "k", 0x1D62D => "l", 0x1D62E => "m", 0x1D62F => "n", 0x1D630 => "o", 0x1D631 => "p", 0x1D632 => "q", 0x1D633 => "r", 0x1D634 => "s", 0x1D635 => "t", 0x1D636 => "u", 0x1D637 => "v", 0x1D638 => "w", 0x1D639 => "x", 0x1D63A => "y", 0x1D63B => "z", 0x1D63C => "a", 0x1D63D => "b", 0x1D63E => "c", 0x1D63F => "d", 0x1D640 => "e", 0x1D641 => "f", 0x1D642 => "g", 0x1D643 => "h", 0x1D644 => "i", 0x1D645 => "j", 0x1D646 => "k", 0x1D647 => "l", 0x1D648 => "m", 0x1D649 => "n", 0x1D64A => "o", 0x1D64B => "p", 0x1D64C => "q", 0x1D64D => "r", 0x1D64E => "s", 0x1D64F => "t", 0x1D650 => "u", 0x1D651 => "v", 0x1D652 => "w", 0x1D653 => "x", 0x1D654 => "y", 0x1D655 => "z", 0x1D656 => "a", 0x1D657 => "b", 0x1D658 => "c", 0x1D659 => "d", 0x1D65A => "e", 0x1D65B => "f", 0x1D65C => "g", 0x1D65D => "h", 0x1D65E => "i", 0x1D65F => "j", 0x1D660 => "k", 0x1D661 => "l", 0x1D662 => "m", 0x1D663 => "n", 0x1D664 => "o", 0x1D665 => "p", 0x1D666 => "q", 0x1D667 => "r", 0x1D668 => "s", 0x1D669 => "t", 0x1D66A => "u", 0x1D66B => "v", 0x1D66C => "w", 0x1D66D => "x", 0x1D66E => "y", 0x1D66F => "z", 0x1D670 => "a", 0x1D671 => "b", 0x1D672 => "c", 0x1D673 => "d", 0x1D674 => "e", 0x1D675 => "f", 0x1D676 => "g", 0x1D677 => "h", 0x1D678 => "i", 0x1D679 => "j", 0x1D67A => "k", 0x1D67B => "l", 0x1D67C => "m", 0x1D67D => "n", 0x1D67E => "o", 0x1D67F => "p", 0x1D680 => "q", 0x1D681 => "r", 0x1D682 => "s", 0x1D683 => "t", 0x1D684 => "u", 0x1D685 => "v", 0x1D686 => "w", 0x1D687 => "x", 0x1D688 => "y", 0x1D689 => "z", 0x1D68A => "a", 0x1D68B => "b", 0x1D68C => "c", 0x1D68D => "d", 0x1D68E => "e", 0x1D68F => "f", 0x1D690 => "g", 0x1D691 => "h", 0x1D692 => "i", 0x1D693 => "j", 0x1D694 => "k", 0x1D695 => "l", 0x1D696 => "m", 0x1D697 => "n", 0x1D698 => "o", 0x1D699 => "p", 0x1D69A => "q", 0x1D69B => "r", 0x1D69C => "s", 0x1D69D => "t", 0x1D69E => "u", 0x1D69F => "v", 0x1D6A0 => "w", 0x1D6A1 => "x", 0x1D6A2 => "y", 0x1D6A3 => "z", 0x1D6A4 => "ı", 0x1D6A5 => "ȷ", 0x1D6A8 => "α", 0x1D6A9 => "β", 0x1D6AA => "γ", 0x1D6AB => "δ", 0x1D6AC => "ε", 0x1D6AD => "ζ", 0x1D6AE => "η", 0x1D6AF => "θ", 0x1D6B0 => "ι", 0x1D6B1 => "κ", 0x1D6B2 => "λ", 0x1D6B3 => "μ", 0x1D6B4 => "ν", 0x1D6B5 => "ξ", 0x1D6B6 => "ο", 0x1D6B7 => "π", 0x1D6B8 => "ρ", 0x1D6B9 => "θ", 0x1D6BA => "σ", 0x1D6BB => "τ", 0x1D6BC => "υ", 0x1D6BD => "φ", 0x1D6BE => "χ", 0x1D6BF => "ψ", 0x1D6C0 => "ω", 0x1D6C1 => "\x{2207}", 0x1D6C2 => "α", 0x1D6C3 => "β", 0x1D6C4 => "γ", 0x1D6C5 => "δ", 0x1D6C6 => "ε", 0x1D6C7 => "ζ", 0x1D6C8 => "η", 0x1D6C9 => "θ", 0x1D6CA => "ι", 0x1D6CB => "κ", 0x1D6CC => "λ", 0x1D6CD => "μ", 0x1D6CE => "ν", 0x1D6CF => "ξ", 0x1D6D0 => "ο", 0x1D6D1 => "π", 0x1D6D2 => "ρ", 0x1D6D3 => "σ", 0x1D6D4 => "σ", 0x1D6D5 => "τ", 0x1D6D6 => "υ", 0x1D6D7 => "φ", 0x1D6D8 => "χ", 0x1D6D9 => "ψ", 0x1D6DA => "ω", 0x1D6DB => "\x{2202}", 0x1D6DC => "ε", 0x1D6DD => "θ", 0x1D6DE => "κ", 0x1D6DF => "φ", 0x1D6E0 => "ρ", 0x1D6E1 => "π", 0x1D6E2 => "α", 0x1D6E3 => "β", 0x1D6E4 => "γ", 0x1D6E5 => "δ", 0x1D6E6 => "ε", 0x1D6E7 => "ζ", 0x1D6E8 => "η", 0x1D6E9 => "θ", 0x1D6EA => "ι", 0x1D6EB => "κ", 0x1D6EC => "λ", 0x1D6ED => "μ", 0x1D6EE => "ν", 0x1D6EF => "ξ", 0x1D6F0 => "ο", 0x1D6F1 => "π", 0x1D6F2 => "ρ", 0x1D6F3 => "θ", 0x1D6F4 => "σ", 0x1D6F5 => "τ", 0x1D6F6 => "υ", 0x1D6F7 => "φ", 0x1D6F8 => "χ", 0x1D6F9 => "ψ", 0x1D6FA => "ω", 0x1D6FB => "\x{2207}", 0x1D6FC => "α", 0x1D6FD => "β", 0x1D6FE => "γ", 0x1D6FF => "δ", 0x1D700 => "ε", 0x1D701 => "ζ", 0x1D702 => "η", 0x1D703 => "θ", 0x1D704 => "ι", 0x1D705 => "κ", 0x1D706 => "λ", 0x1D707 => "μ", 0x1D708 => "ν", 0x1D709 => "ξ", 0x1D70A => "ο", 0x1D70B => "π", 0x1D70C => "ρ", 0x1D70D => "σ", 0x1D70E => "σ", 0x1D70F => "τ", 0x1D710 => "υ", 0x1D711 => "φ", 0x1D712 => "χ", 0x1D713 => "ψ", 0x1D714 => "ω", 0x1D715 => "\x{2202}", 0x1D716 => "ε", 0x1D717 => "θ", 0x1D718 => "κ", 0x1D719 => "φ", 0x1D71A => "ρ", 0x1D71B => "π", 0x1D71C => "α", 0x1D71D => "β", 0x1D71E => "γ", 0x1D71F => "δ", 0x1D720 => "ε", 0x1D721 => "ζ", 0x1D722 => "η", 0x1D723 => "θ", 0x1D724 => "ι", 0x1D725 => "κ", 0x1D726 => "λ", 0x1D727 => "μ", 0x1D728 => "ν", 0x1D729 => "ξ", 0x1D72A => "ο", 0x1D72B => "π", 0x1D72C => "ρ", 0x1D72D => "θ", 0x1D72E => "σ", 0x1D72F => "τ", 0x1D730 => "υ", 0x1D731 => "φ", 0x1D732 => "χ", 0x1D733 => "ψ", 0x1D734 => "ω", 0x1D735 => "\x{2207}", 0x1D736 => "α", 0x1D737 => "β", 0x1D738 => "γ", 0x1D739 => "δ", 0x1D73A => "ε", 0x1D73B => "ζ", 0x1D73C => "η", 0x1D73D => "θ", 0x1D73E => "ι", 0x1D73F => "κ", 0x1D740 => "λ", 0x1D741 => "μ", 0x1D742 => "ν", 0x1D743 => "ξ", 0x1D744 => "ο", 0x1D745 => "π", 0x1D746 => "ρ", 0x1D747 => "σ", 0x1D748 => "σ", 0x1D749 => "τ", 0x1D74A => "υ", 0x1D74B => "φ", 0x1D74C => "χ", 0x1D74D => "ψ", 0x1D74E => "ω", 0x1D74F => "\x{2202}", 0x1D750 => "ε", 0x1D751 => "θ", 0x1D752 => "κ", 0x1D753 => "φ", 0x1D754 => "ρ", 0x1D755 => "π", 0x1D756 => "α", 0x1D757 => "β", 0x1D758 => "γ", 0x1D759 => "δ", 0x1D75A => "ε", 0x1D75B => "ζ", 0x1D75C => "η", 0x1D75D => "θ", 0x1D75E => "ι", 0x1D75F => "κ", 0x1D760 => "λ", 0x1D761 => "μ", 0x1D762 => "ν", 0x1D763 => "ξ", 0x1D764 => "ο", 0x1D765 => "π", 0x1D766 => "ρ", 0x1D767 => "θ", 0x1D768 => "σ", 0x1D769 => "τ", 0x1D76A => "υ", 0x1D76B => "φ", 0x1D76C => "χ", 0x1D76D => "ψ", 0x1D76E => "ω", 0x1D76F => "\x{2207}", 0x1D770 => "α", 0x1D771 => "β", 0x1D772 => "γ", 0x1D773 => "δ", 0x1D774 => "ε", 0x1D775 => "ζ", 0x1D776 => "η", 0x1D777 => "θ", 0x1D778 => "ι", 0x1D779 => "κ", 0x1D77A => "λ", 0x1D77B => "μ", 0x1D77C => "ν", 0x1D77D => "ξ", 0x1D77E => "ο", 0x1D77F => "π", 0x1D780 => "ρ", 0x1D781 => "σ", 0x1D782 => "σ", 0x1D783 => "τ", 0x1D784 => "υ", 0x1D785 => "φ", 0x1D786 => "χ", 0x1D787 => "ψ", 0x1D788 => "ω", 0x1D789 => "\x{2202}", 0x1D78A => "ε", 0x1D78B => "θ", 0x1D78C => "κ", 0x1D78D => "φ", 0x1D78E => "ρ", 0x1D78F => "π", 0x1D790 => "α", 0x1D791 => "β", 0x1D792 => "γ", 0x1D793 => "δ", 0x1D794 => "ε", 0x1D795 => "ζ", 0x1D796 => "η", 0x1D797 => "θ", 0x1D798 => "ι", 0x1D799 => "κ", 0x1D79A => "λ", 0x1D79B => "μ", 0x1D79C => "ν", 0x1D79D => "ξ", 0x1D79E => "ο", 0x1D79F => "π", 0x1D7A0 => "ρ", 0x1D7A1 => "θ", 0x1D7A2 => "σ", 0x1D7A3 => "τ", 0x1D7A4 => "υ", 0x1D7A5 => "φ", 0x1D7A6 => "χ", 0x1D7A7 => "ψ", 0x1D7A8 => "ω", 0x1D7A9 => "\x{2207}", 0x1D7AA => "α", 0x1D7AB => "β", 0x1D7AC => "γ", 0x1D7AD => "δ", 0x1D7AE => "ε", 0x1D7AF => "ζ", 0x1D7B0 => "η", 0x1D7B1 => "θ", 0x1D7B2 => "ι", 0x1D7B3 => "κ", 0x1D7B4 => "λ", 0x1D7B5 => "μ", 0x1D7B6 => "ν", 0x1D7B7 => "ξ", 0x1D7B8 => "ο", 0x1D7B9 => "π", 0x1D7BA => "ρ", 0x1D7BB => "σ", 0x1D7BC => "σ", 0x1D7BD => "τ", 0x1D7BE => "υ", 0x1D7BF => "φ", 0x1D7C0 => "χ", 0x1D7C1 => "ψ", 0x1D7C2 => "ω", 0x1D7C3 => "\x{2202}", 0x1D7C4 => "ε", 0x1D7C5 => "θ", 0x1D7C6 => "κ", 0x1D7C7 => "φ", 0x1D7C8 => "ρ", 0x1D7C9 => "π", 0x1D7CA => "ϝ", 0x1D7CB => "ϝ", 0x1D7CE => "0", 0x1D7CF => "1", 0x1D7D0 => "2", 0x1D7D1 => "3", 0x1D7D2 => "4", 0x1D7D3 => "5", 0x1D7D4 => "6", 0x1D7D5 => "7", 0x1D7D6 => "8", 0x1D7D7 => "9", 0x1D7D8 => "0", 0x1D7D9 => "1", 0x1D7DA => "2", 0x1D7DB => "3", 0x1D7DC => "4", 0x1D7DD => "5", 0x1D7DE => "6", 0x1D7DF => "7", 0x1D7E0 => "8", 0x1D7E1 => "9", 0x1D7E2 => "0", 0x1D7E3 => "1", 0x1D7E4 => "2", 0x1D7E5 => "3", 0x1D7E6 => "4", 0x1D7E7 => "5", 0x1D7E8 => "6", 0x1D7E9 => "7", 0x1D7EA => "8", 0x1D7EB => "9", 0x1D7EC => "0", 0x1D7ED => "1", 0x1D7EE => "2", 0x1D7EF => "3", 0x1D7F0 => "4", 0x1D7F1 => "5", 0x1D7F2 => "6", 0x1D7F3 => "7", 0x1D7F4 => "8", 0x1D7F5 => "9", 0x1D7F6 => "0", 0x1D7F7 => "1", 0x1D7F8 => "2", 0x1D7F9 => "3", 0x1D7FA => "4", 0x1D7FB => "5", 0x1D7FC => "6", 0x1D7FD => "7", 0x1D7FE => "8", 0x1D7FF => "9", 0x1E900 => "𞤢", 0x1E901 => "𞤣", 0x1E902 => "𞤤", 0x1E903 => "𞤥", 0x1E904 => "𞤦", 0x1E905 => "𞤧", 0x1E906 => "𞤨", 0x1E907 => "𞤩", 0x1E908 => "𞤪", 0x1E909 => "𞤫", 0x1E90A => "𞤬", 0x1E90B => "𞤭", 0x1E90C => "𞤮", 0x1E90D => "𞤯", 0x1E90E => "𞤰", 0x1E90F => "𞤱", 0x1E910 => "𞤲", 0x1E911 => "𞤳", 0x1E912 => "𞤴", 0x1E913 => "𞤵", 0x1E914 => "𞤶", 0x1E915 => "𞤷", 0x1E916 => "𞤸", 0x1E917 => "𞤹", 0x1E918 => "𞤺", 0x1E919 => "𞤻", 0x1E91A => "𞤼", 0x1E91B => "𞤽", 0x1E91C => "𞤾", 0x1E91D => "𞤿", 0x1E91E => "𞥀", 0x1E91F => "𞥁", 0x1E920 => "𞥂", 0x1E921 => "𞥃", 0x1EE00 => "ا", 0x1EE01 => "ب", 0x1EE02 => "ج", 0x1EE03 => "د", 0x1EE05 => "و", 0x1EE06 => "ز", 0x1EE07 => "ح", 0x1EE08 => "ط", 0x1EE09 => "ي", 0x1EE0A => "ك", 0x1EE0B => "ل", 0x1EE0C => "م", 0x1EE0D => "ن", 0x1EE0E => "س", 0x1EE0F => "ع", 0x1EE10 => "ف", 0x1EE11 => "ص", 0x1EE12 => "ق", 0x1EE13 => "ر", 0x1EE14 => "ش", 0x1EE15 => "ت", 0x1EE16 => "ث", 0x1EE17 => "خ", 0x1EE18 => "ذ", 0x1EE19 => "ض", 0x1EE1A => "ظ", 0x1EE1B => "غ", 0x1EE1C => "ٮ", 0x1EE1D => "ں", 0x1EE1E => "ڡ", 0x1EE1F => "ٯ", 0x1EE21 => "ب", 0x1EE22 => "ج", 0x1EE24 => "ه", 0x1EE27 => "ح", 0x1EE29 => "ي", 0x1EE2A => "ك", 0x1EE2B => "ل", 0x1EE2C => "م", 0x1EE2D => "ن", 0x1EE2E => "س", 0x1EE2F => "ع", 0x1EE30 => "ف", 0x1EE31 => "ص", 0x1EE32 => "ق", 0x1EE34 => "ش", 0x1EE35 => "ت", 0x1EE36 => "ث", 0x1EE37 => "خ", 0x1EE39 => "ض", 0x1EE3B => "غ", 0x1EE42 => "ج", 0x1EE47 => "ح", 0x1EE49 => "ي", 0x1EE4B => "ل", 0x1EE4D => "ن", 0x1EE4E => "س", 0x1EE4F => "ع", 0x1EE51 => "ص", 0x1EE52 => "ق", 0x1EE54 => "ش", 0x1EE57 => "خ", 0x1EE59 => "ض", 0x1EE5B => "غ", 0x1EE5D => "ں", 0x1EE5F => "ٯ", 0x1EE61 => "ب", 0x1EE62 => "ج", 0x1EE64 => "ه", 0x1EE67 => "ح", 0x1EE68 => "ط", 0x1EE69 => "ي", 0x1EE6A => "ك", 0x1EE6C => "م", 0x1EE6D => "ن", 0x1EE6E => "س", 0x1EE6F => "ع", 0x1EE70 => "ف", 0x1EE71 => "ص", 0x1EE72 => "ق", 0x1EE74 => "ش", 0x1EE75 => "ت", 0x1EE76 => "ث", 0x1EE77 => "خ", 0x1EE79 => "ض", 0x1EE7A => "ظ", 0x1EE7B => "غ", 0x1EE7C => "ٮ", 0x1EE7E => "ڡ", 0x1EE80 => "ا", 0x1EE81 => "ب", 0x1EE82 => "ج", 0x1EE83 => "د", 0x1EE84 => "ه", 0x1EE85 => "و", 0x1EE86 => "ز", 0x1EE87 => "ح", 0x1EE88 => "ط", 0x1EE89 => "ي", 0x1EE8B => "ل", 0x1EE8C => "م", 0x1EE8D => "ن", 0x1EE8E => "س", 0x1EE8F => "ع", 0x1EE90 => "ف", 0x1EE91 => "ص", 0x1EE92 => "ق", 0x1EE93 => "ر", 0x1EE94 => "ش", 0x1EE95 => "ت", 0x1EE96 => "ث", 0x1EE97 => "خ", 0x1EE98 => "ذ", 0x1EE99 => "ض", 0x1EE9A => "ظ", 0x1EE9B => "غ", 0x1EEA1 => "ب", 0x1EEA2 => "ج", 0x1EEA3 => "د", 0x1EEA5 => "و", 0x1EEA6 => "ز", 0x1EEA7 => "ح", 0x1EEA8 => "ط", 0x1EEA9 => "ي", 0x1EEAB => "ل", 0x1EEAC => "م", 0x1EEAD => "ن", 0x1EEAE => "س", 0x1EEAF => "ع", 0x1EEB0 => "ف", 0x1EEB1 => "ص", 0x1EEB2 => "ق", 0x1EEB3 => "ر", 0x1EEB4 => "ش", 0x1EEB5 => "ت", 0x1EEB6 => "ث", 0x1EEB7 => "خ", 0x1EEB8 => "ذ", 0x1EEB9 => "ض", 0x1EEBA => "ظ", 0x1EEBB => "غ", 0x1F12A => "\x{3014}s\x{3015}", 0x1F12B => "c", 0x1F12C => "r", 0x1F12D => "cd", 0x1F12E => "wz", 0x1F130 => "a", 0x1F131 => "b", 0x1F132 => "c", 0x1F133 => "d", 0x1F134 => "e", 0x1F135 => "f", 0x1F136 => "g", 0x1F137 => "h", 0x1F138 => "i", 0x1F139 => "j", 0x1F13A => "k", 0x1F13B => "l", 0x1F13C => "m", 0x1F13D => "n", 0x1F13E => "o", 0x1F13F => "p", 0x1F140 => "q", 0x1F141 => "r", 0x1F142 => "s", 0x1F143 => "t", 0x1F144 => "u", 0x1F145 => "v", 0x1F146 => "w", 0x1F147 => "x", 0x1F148 => "y", 0x1F149 => "z", 0x1F14A => "hv", 0x1F14B => "mv", 0x1F14C => "sd", 0x1F14D => "ss", 0x1F14E => "ppv", 0x1F14F => "wc", 0x1F16A => "mc", 0x1F16B => "md", 0x1F190 => "dj", 0x1F200 => "ほか", 0x1F201 => "ココ", 0x1F202 => "サ", 0x1F210 => "手", 0x1F211 => "字", 0x1F212 => "双", 0x1F213 => "デ", 0x1F214 => "二", 0x1F215 => "多", 0x1F216 => "解", 0x1F217 => "天", 0x1F218 => "交", 0x1F219 => "映", 0x1F21A => "無", 0x1F21B => "料", 0x1F21C => "前", 0x1F21D => "後", 0x1F21E => "再", 0x1F21F => "新", 0x1F220 => "初", 0x1F221 => "終", 0x1F222 => "生", 0x1F223 => "販", 0x1F224 => "声", 0x1F225 => "吹", 0x1F226 => "演", 0x1F227 => "投", 0x1F228 => "捕", 0x1F229 => "一", 0x1F22A => "三", 0x1F22B => "遊", 0x1F22C => "左", 0x1F22D => "中", 0x1F22E => "右", 0x1F22F => "指", 0x1F230 => "走", 0x1F231 => "打", 0x1F232 => "禁", 0x1F233 => "空", 0x1F234 => "合", 0x1F235 => "満", 0x1F236 => "有", 0x1F237 => "月", 0x1F238 => "申", 0x1F239 => "割", 0x1F23A => "営", 0x1F23B => "配", 0x1F240 => "\x{3014}本\x{3015}", 0x1F241 => "\x{3014}三\x{3015}", 0x1F242 => "\x{3014}二\x{3015}", 0x1F243 => "\x{3014}安\x{3015}", 0x1F244 => "\x{3014}点\x{3015}", 0x1F245 => "\x{3014}打\x{3015}", 0x1F246 => "\x{3014}盗\x{3015}", 0x1F247 => "\x{3014}勝\x{3015}", 0x1F248 => "\x{3014}敗\x{3015}", 0x1F250 => "得", 0x1F251 => "可", 0x2F800 => "丽", 0x2F801 => "丸", 0x2F802 => "乁", 0x2F803 => "𠄢", 0x2F804 => "你", 0x2F805 => "侮", 0x2F806 => "侻", 0x2F807 => "倂", 0x2F808 => "偺", 0x2F809 => "備", 0x2F80A => "僧", 0x2F80B => "像", 0x2F80C => "㒞", 0x2F80D => "𠘺", 0x2F80E => "免", 0x2F80F => "兔", 0x2F810 => "兤", 0x2F811 => "具", 0x2F812 => "𠔜", 0x2F813 => "㒹", 0x2F814 => "內", 0x2F815 => "再", 0x2F816 => "𠕋", 0x2F817 => "冗", 0x2F818 => "冤", 0x2F819 => "仌", 0x2F81A => "冬", 0x2F81B => "况", 0x2F81C => "𩇟", 0x2F81D => "凵", 0x2F81E => "刃", 0x2F81F => "㓟", 0x2F820 => "刻", 0x2F821 => "剆", 0x2F822 => "割", 0x2F823 => "剷", 0x2F824 => "㔕", 0x2F825 => "勇", 0x2F826 => "勉", 0x2F827 => "勤", 0x2F828 => "勺", 0x2F829 => "包", 0x2F82A => "匆", 0x2F82B => "北", 0x2F82C => "卉", 0x2F82D => "卑", 0x2F82E => "博", 0x2F82F => "即", 0x2F830 => "卽", 0x2F831 => "卿", 0x2F832 => "卿", 0x2F833 => "卿", 0x2F834 => "𠨬", 0x2F835 => "灰", 0x2F836 => "及", 0x2F837 => "叟", 0x2F838 => "𠭣", 0x2F839 => "叫", 0x2F83A => "叱", 0x2F83B => "吆", 0x2F83C => "咞", 0x2F83D => "吸", 0x2F83E => "呈", 0x2F83F => "周", 0x2F840 => "咢", 0x2F841 => "哶", 0x2F842 => "唐", 0x2F843 => "啓", 0x2F844 => "啣", 0x2F845 => "善", 0x2F846 => "善", 0x2F847 => "喙", 0x2F848 => "喫", 0x2F849 => "喳", 0x2F84A => "嗂", 0x2F84B => "圖", 0x2F84C => "嘆", 0x2F84D => "圗", 0x2F84E => "噑", 0x2F84F => "噴", 0x2F850 => "切", 0x2F851 => "壮", 0x2F852 => "城", 0x2F853 => "埴", 0x2F854 => "堍", 0x2F855 => "型", 0x2F856 => "堲", 0x2F857 => "報", 0x2F858 => "墬", 0x2F859 => "𡓤", 0x2F85A => "売", 0x2F85B => "壷", 0x2F85C => "夆", 0x2F85D => "多", 0x2F85E => "夢", 0x2F85F => "奢", 0x2F860 => "𡚨", 0x2F861 => "𡛪", 0x2F862 => "姬", 0x2F863 => "娛", 0x2F864 => "娧", 0x2F865 => "姘", 0x2F866 => "婦", 0x2F867 => "㛮", 0x2F869 => "嬈", 0x2F86A => "嬾", 0x2F86B => "嬾", 0x2F86C => "𡧈", 0x2F86D => "寃", 0x2F86E => "寘", 0x2F86F => "寧", 0x2F870 => "寳", 0x2F871 => "𡬘", 0x2F872 => "寿", 0x2F873 => "将", 0x2F875 => "尢", 0x2F876 => "㞁", 0x2F877 => "屠", 0x2F878 => "屮", 0x2F879 => "峀", 0x2F87A => "岍", 0x2F87B => "𡷤", 0x2F87C => "嵃", 0x2F87D => "𡷦", 0x2F87E => "嵮", 0x2F87F => "嵫", 0x2F880 => "嵼", 0x2F881 => "巡", 0x2F882 => "巢", 0x2F883 => "㠯", 0x2F884 => "巽", 0x2F885 => "帨", 0x2F886 => "帽", 0x2F887 => "幩", 0x2F888 => "㡢", 0x2F889 => "𢆃", 0x2F88A => "㡼", 0x2F88B => "庰", 0x2F88C => "庳", 0x2F88D => "庶", 0x2F88E => "廊", 0x2F88F => "𪎒", 0x2F890 => "廾", 0x2F891 => "𢌱", 0x2F892 => "𢌱", 0x2F893 => "舁", 0x2F894 => "弢", 0x2F895 => "弢", 0x2F896 => "㣇", 0x2F897 => "𣊸", 0x2F898 => "𦇚", 0x2F899 => "形", 0x2F89A => "彫", 0x2F89B => "㣣", 0x2F89C => "徚", 0x2F89D => "忍", 0x2F89E => "志", 0x2F89F => "忹", 0x2F8A0 => "悁", 0x2F8A1 => "㤺", 0x2F8A2 => "㤜", 0x2F8A3 => "悔", 0x2F8A4 => "𢛔", 0x2F8A5 => "惇", 0x2F8A6 => "慈", 0x2F8A7 => "慌", 0x2F8A8 => "慎", 0x2F8A9 => "慌", 0x2F8AA => "慺", 0x2F8AB => "憎", 0x2F8AC => "憲", 0x2F8AD => "憤", 0x2F8AE => "憯", 0x2F8AF => "懞", 0x2F8B0 => "懲", 0x2F8B1 => "懶", 0x2F8B2 => "成", 0x2F8B3 => "戛", 0x2F8B4 => "扝", 0x2F8B5 => "抱", 0x2F8B6 => "拔", 0x2F8B7 => "捐", 0x2F8B8 => "𢬌", 0x2F8B9 => "挽", 0x2F8BA => "拼", 0x2F8BB => "捨", 0x2F8BC => "掃", 0x2F8BD => "揤", 0x2F8BE => "𢯱", 0x2F8BF => "搢", 0x2F8C0 => "揅", 0x2F8C1 => "掩", 0x2F8C2 => "㨮", 0x2F8C3 => "摩", 0x2F8C4 => "摾", 0x2F8C5 => "撝", 0x2F8C6 => "摷", 0x2F8C7 => "㩬", 0x2F8C8 => "敏", 0x2F8C9 => "敬", 0x2F8CA => "𣀊", 0x2F8CB => "旣", 0x2F8CC => "書", 0x2F8CD => "晉", 0x2F8CE => "㬙", 0x2F8CF => "暑", 0x2F8D0 => "㬈", 0x2F8D1 => "㫤", 0x2F8D2 => "冒", 0x2F8D3 => "冕", 0x2F8D4 => "最", 0x2F8D5 => "暜", 0x2F8D6 => "肭", 0x2F8D7 => "䏙", 0x2F8D8 => "朗", 0x2F8D9 => "望", 0x2F8DA => "朡", 0x2F8DB => "杞", 0x2F8DC => "杓", 0x2F8DD => "𣏃", 0x2F8DE => "㭉", 0x2F8DF => "柺", 0x2F8E0 => "枅", 0x2F8E1 => "桒", 0x2F8E2 => "梅", 0x2F8E3 => "𣑭", 0x2F8E4 => "梎", 0x2F8E5 => "栟", 0x2F8E6 => "椔", 0x2F8E7 => "㮝", 0x2F8E8 => "楂", 0x2F8E9 => "榣", 0x2F8EA => "槪", 0x2F8EB => "檨", 0x2F8EC => "𣚣", 0x2F8ED => "櫛", 0x2F8EE => "㰘", 0x2F8EF => "次", 0x2F8F0 => "𣢧", 0x2F8F1 => "歔", 0x2F8F2 => "㱎", 0x2F8F3 => "歲", 0x2F8F4 => "殟", 0x2F8F5 => "殺", 0x2F8F6 => "殻", 0x2F8F7 => "𣪍", 0x2F8F8 => "𡴋", 0x2F8F9 => "𣫺", 0x2F8FA => "汎", 0x2F8FB => "𣲼", 0x2F8FC => "沿", 0x2F8FD => "泍", 0x2F8FE => "汧", 0x2F8FF => "洖", 0x2F900 => "派", 0x2F901 => "海", 0x2F902 => "流", 0x2F903 => "浩", 0x2F904 => "浸", 0x2F905 => "涅", 0x2F906 => "𣴞", 0x2F907 => "洴", 0x2F908 => "港", 0x2F909 => "湮", 0x2F90A => "㴳", 0x2F90B => "滋", 0x2F90C => "滇", 0x2F90D => "𣻑", 0x2F90E => "淹", 0x2F90F => "潮", 0x2F910 => "𣽞", 0x2F911 => "𣾎", 0x2F912 => "濆", 0x2F913 => "瀹", 0x2F914 => "瀞", 0x2F915 => "瀛", 0x2F916 => "㶖", 0x2F917 => "灊", 0x2F918 => "災", 0x2F919 => "灷", 0x2F91A => "炭", 0x2F91B => "𠔥", 0x2F91C => "煅", 0x2F91D => "𤉣", 0x2F91E => "熜", 0x2F920 => "爨", 0x2F921 => "爵", 0x2F922 => "牐", 0x2F923 => "𤘈", 0x2F924 => "犀", 0x2F925 => "犕", 0x2F926 => "𤜵", 0x2F927 => "𤠔", 0x2F928 => "獺", 0x2F929 => "王", 0x2F92A => "㺬", 0x2F92B => "玥", 0x2F92C => "㺸", 0x2F92D => "㺸", 0x2F92E => "瑇", 0x2F92F => "瑜", 0x2F930 => "瑱", 0x2F931 => "璅", 0x2F932 => "瓊", 0x2F933 => "㼛", 0x2F934 => "甤", 0x2F935 => "𤰶", 0x2F936 => "甾", 0x2F937 => "𤲒", 0x2F938 => "異", 0x2F939 => "𢆟", 0x2F93A => "瘐", 0x2F93B => "𤾡", 0x2F93C => "𤾸", 0x2F93D => "𥁄", 0x2F93E => "㿼", 0x2F93F => "䀈", 0x2F940 => "直", 0x2F941 => "𥃳", 0x2F942 => "𥃲", 0x2F943 => "𥄙", 0x2F944 => "𥄳", 0x2F945 => "眞", 0x2F946 => "真", 0x2F947 => "真", 0x2F948 => "睊", 0x2F949 => "䀹", 0x2F94A => "瞋", 0x2F94B => "䁆", 0x2F94C => "䂖", 0x2F94D => "𥐝", 0x2F94E => "硎", 0x2F94F => "碌", 0x2F950 => "磌", 0x2F951 => "䃣", 0x2F952 => "𥘦", 0x2F953 => "祖", 0x2F954 => "𥚚", 0x2F955 => "𥛅", 0x2F956 => "福", 0x2F957 => "秫", 0x2F958 => "䄯", 0x2F959 => "穀", 0x2F95A => "穊", 0x2F95B => "穏", 0x2F95C => "𥥼", 0x2F95D => "𥪧", 0x2F95E => "𥪧", 0x2F960 => "䈂", 0x2F961 => "𥮫", 0x2F962 => "篆", 0x2F963 => "築", 0x2F964 => "䈧", 0x2F965 => "𥲀", 0x2F966 => "糒", 0x2F967 => "䊠", 0x2F968 => "糨", 0x2F969 => "糣", 0x2F96A => "紀", 0x2F96B => "𥾆", 0x2F96C => "絣", 0x2F96D => "䌁", 0x2F96E => "緇", 0x2F96F => "縂", 0x2F970 => "繅", 0x2F971 => "䌴", 0x2F972 => "𦈨", 0x2F973 => "𦉇", 0x2F974 => "䍙", 0x2F975 => "𦋙", 0x2F976 => "罺", 0x2F977 => "𦌾", 0x2F978 => "羕", 0x2F979 => "翺", 0x2F97A => "者", 0x2F97B => "𦓚", 0x2F97C => "𦔣", 0x2F97D => "聠", 0x2F97E => "𦖨", 0x2F97F => "聰", 0x2F980 => "𣍟", 0x2F981 => "䏕", 0x2F982 => "育", 0x2F983 => "脃", 0x2F984 => "䐋", 0x2F985 => "脾", 0x2F986 => "媵", 0x2F987 => "𦞧", 0x2F988 => "𦞵", 0x2F989 => "𣎓", 0x2F98A => "𣎜", 0x2F98B => "舁", 0x2F98C => "舄", 0x2F98D => "辞", 0x2F98E => "䑫", 0x2F98F => "芑", 0x2F990 => "芋", 0x2F991 => "芝", 0x2F992 => "劳", 0x2F993 => "花", 0x2F994 => "芳", 0x2F995 => "芽", 0x2F996 => "苦", 0x2F997 => "𦬼", 0x2F998 => "若", 0x2F999 => "茝", 0x2F99A => "荣", 0x2F99B => "莭", 0x2F99C => "茣", 0x2F99D => "莽", 0x2F99E => "菧", 0x2F99F => "著", 0x2F9A0 => "荓", 0x2F9A1 => "菊", 0x2F9A2 => "菌", 0x2F9A3 => "菜", 0x2F9A4 => "𦰶", 0x2F9A5 => "𦵫", 0x2F9A6 => "𦳕", 0x2F9A7 => "䔫", 0x2F9A8 => "蓱", 0x2F9A9 => "蓳", 0x2F9AA => "蔖", 0x2F9AB => "𧏊", 0x2F9AC => "蕤", 0x2F9AD => "𦼬", 0x2F9AE => "䕝", 0x2F9AF => "䕡", 0x2F9B0 => "𦾱", 0x2F9B1 => "𧃒", 0x2F9B2 => "䕫", 0x2F9B3 => "虐", 0x2F9B4 => "虜", 0x2F9B5 => "虧", 0x2F9B6 => "虩", 0x2F9B7 => "蚩", 0x2F9B8 => "蚈", 0x2F9B9 => "蜎", 0x2F9BA => "蛢", 0x2F9BB => "蝹", 0x2F9BC => "蜨", 0x2F9BD => "蝫", 0x2F9BE => "螆", 0x2F9C0 => "蟡", 0x2F9C1 => "蠁", 0x2F9C2 => "䗹", 0x2F9C3 => "衠", 0x2F9C4 => "衣", 0x2F9C5 => "𧙧", 0x2F9C6 => "裗", 0x2F9C7 => "裞", 0x2F9C8 => "䘵", 0x2F9C9 => "裺", 0x2F9CA => "㒻", 0x2F9CB => "𧢮", 0x2F9CC => "𧥦", 0x2F9CD => "䚾", 0x2F9CE => "䛇", 0x2F9CF => "誠", 0x2F9D0 => "諭", 0x2F9D1 => "變", 0x2F9D2 => "豕", 0x2F9D3 => "𧲨", 0x2F9D4 => "貫", 0x2F9D5 => "賁", 0x2F9D6 => "贛", 0x2F9D7 => "起", 0x2F9D8 => "𧼯", 0x2F9D9 => "𠠄", 0x2F9DA => "跋", 0x2F9DB => "趼", 0x2F9DC => "跰", 0x2F9DD => "𠣞", 0x2F9DE => "軔", 0x2F9DF => "輸", 0x2F9E0 => "𨗒", 0x2F9E1 => "𨗭", 0x2F9E2 => "邔", 0x2F9E3 => "郱", 0x2F9E4 => "鄑", 0x2F9E5 => "𨜮", 0x2F9E6 => "鄛", 0x2F9E7 => "鈸", 0x2F9E8 => "鋗", 0x2F9E9 => "鋘", 0x2F9EA => "鉼", 0x2F9EB => "鏹", 0x2F9EC => "鐕", 0x2F9ED => "𨯺", 0x2F9EE => "開", 0x2F9EF => "䦕", 0x2F9F0 => "閷", 0x2F9F1 => "𨵷", 0x2F9F2 => "䧦", 0x2F9F3 => "雃", 0x2F9F4 => "嶲", 0x2F9F5 => "霣", 0x2F9F6 => "𩅅", 0x2F9F7 => "𩈚", 0x2F9F8 => "䩮", 0x2F9F9 => "䩶", 0x2F9FA => "韠", 0x2F9FB => "𩐊", 0x2F9FC => "䪲", 0x2F9FD => "𩒖", 0x2F9FE => "頋", 0x2F9FF => "頋", 0x2FA00 => "頩", 0x2FA01 => "𩖶", 0x2FA02 => "飢", 0x2FA03 => "䬳", 0x2FA04 => "餩", 0x2FA05 => "馧", 0x2FA06 => "駂", 0x2FA07 => "駾", 0x2FA08 => "䯎", 0x2FA09 => "𩬰", 0x2FA0A => "鬒", 0x2FA0B => "鱀", 0x2FA0C => "鳽", 0x2FA0D => "䳎", 0x2FA0E => "䳭", 0x2FA0F => "鵧", 0x2FA10 => "𪃎", 0x2FA11 => "䳸", 0x2FA12 => "𪄅", 0x2FA13 => "𪈎", 0x2FA14 => "𪊑", 0x2FA15 => "麻", 0x2FA16 => "䵖", 0x2FA17 => "黹", 0x2FA18 => "黾", 0x2FA19 => "鼅", 0x2FA1A => "鼏", 0x2FA1B => "鼖", 0x2FA1C => "鼻", 0x2FA1D => "𪘀",); our @MAPPED = ( 0x0041, 0x005A, 0x00AA, undef, 0x00B2, 0x00B3, 0x00B5, undef, 0x00B9, 0x00BA, 0x00BC, 0x00BE, 0x00C0, 0x00D6, 0x00D8, 0x00DE, 0x0100, undef, 0x0102, undef, 0x0104, undef, 0x0106, undef, 0x0108, undef, 0x010A, undef, 0x010C, undef, 0x010E, undef, 0x0110, undef, 0x0112, undef, 0x0114, undef, 0x0116, undef, 0x0118, undef, 0x011A, undef, 0x011C, undef, 0x011E, undef, 0x0120, undef, 0x0122, undef, 0x0124, undef, 0x0126, undef, 0x0128, undef, 0x012A, undef, 0x012C, undef, 0x012E, undef, 0x0130, undef, 0x0132, 0x0134, 0x0136, undef, 0x0139, undef, 0x013B, undef, 0x013D, undef, 0x013F, 0x0141, 0x0143, undef, 0x0145, undef, 0x0147, undef, 0x0149, 0x014A, 0x014C, undef, 0x014E, undef, 0x0150, undef, 0x0152, undef, 0x0154, undef, 0x0156, undef, 0x0158, undef, 0x015A, undef, 0x015C, undef, 0x015E, undef, 0x0160, undef, 0x0162, undef, 0x0164, undef, 0x0166, undef, 0x0168, undef, 0x016A, undef, 0x016C, undef, 0x016E, undef, 0x0170, undef, 0x0172, undef, 0x0174, undef, 0x0176, undef, 0x0178, 0x0179, 0x017B, undef, 0x017D, undef, 0x017F, undef, 0x0181, 0x0182, 0x0184, undef, 0x0186, 0x0187, 0x0189, 0x018B, 0x018E, 0x0191, 0x0193, 0x0194, 0x0196, 0x0198, 0x019C, 0x019D, 0x019F, 0x01A0, 0x01A2, undef, 0x01A4, undef, 0x01A6, 0x01A7, 0x01A9, undef, 0x01AC, undef, 0x01AE, 0x01AF, 0x01B1, 0x01B3, 0x01B5, undef, 0x01B7, 0x01B8, 0x01BC, undef, 0x01C4, 0x01CD, 0x01CF, undef, 0x01D1, undef, 0x01D3, undef, 0x01D5, undef, 0x01D7, undef, 0x01D9, undef, 0x01DB, undef, 0x01DE, undef, 0x01E0, undef, 0x01E2, undef, 0x01E4, undef, 0x01E6, undef, 0x01E8, undef, 0x01EA, undef, 0x01EC, undef, 0x01EE, undef, 0x01F1, 0x01F4, 0x01F6, 0x01F8, 0x01FA, undef, 0x01FC, undef, 0x01FE, undef, 0x0200, undef, 0x0202, undef, 0x0204, undef, 0x0206, undef, 0x0208, undef, 0x020A, undef, 0x020C, undef, 0x020E, undef, 0x0210, undef, 0x0212, undef, 0x0214, undef, 0x0216, undef, 0x0218, undef, 0x021A, undef, 0x021C, undef, 0x021E, undef, 0x0220, undef, 0x0222, undef, 0x0224, undef, 0x0226, undef, 0x0228, undef, 0x022A, undef, 0x022C, undef, 0x022E, undef, 0x0230, undef, 0x0232, undef, 0x023A, 0x023B, 0x023D, 0x023E, 0x0241, undef, 0x0243, 0x0246, 0x0248, undef, 0x024A, undef, 0x024C, undef, 0x024E, undef, 0x02B0, 0x02B8, 0x02E0, 0x02E4, 0x0340, 0x0341, 0x0343, 0x0345, 0x0370, undef, 0x0372, undef, 0x0374, undef, 0x0376, undef, 0x037F, undef, 0x0386, 0x038A, 0x038C, undef, 0x038E, 0x038F, 0x0391, 0x03A1, 0x03A3, 0x03AB, 0x03CF, 0x03D6, 0x03D8, undef, 0x03DA, undef, 0x03DC, undef, 0x03DE, undef, 0x03E0, undef, 0x03E2, undef, 0x03E4, undef, 0x03E6, undef, 0x03E8, undef, 0x03EA, undef, 0x03EC, undef, 0x03EE, undef, 0x03F0, 0x03F2, 0x03F4, 0x03F5, 0x03F7, undef, 0x03F9, 0x03FA, 0x03FD, 0x042F, 0x0460, undef, 0x0462, undef, 0x0464, undef, 0x0466, undef, 0x0468, undef, 0x046A, undef, 0x046C, undef, 0x046E, undef, 0x0470, undef, 0x0472, undef, 0x0474, undef, 0x0476, undef, 0x0478, undef, 0x047A, undef, 0x047C, undef, 0x047E, undef, 0x0480, undef, 0x048A, undef, 0x048C, undef, 0x048E, undef, 0x0490, undef, 0x0492, undef, 0x0494, undef, 0x0496, undef, 0x0498, undef, 0x049A, undef, 0x049C, undef, 0x049E, undef, 0x04A0, undef, 0x04A2, undef, 0x04A4, undef, 0x04A6, undef, 0x04A8, undef, 0x04AA, undef, 0x04AC, undef, 0x04AE, undef, 0x04B0, undef, 0x04B2, undef, 0x04B4, undef, 0x04B6, undef, 0x04B8, undef, 0x04BA, undef, 0x04BC, undef, 0x04BE, undef, 0x04C1, undef, 0x04C3, undef, 0x04C5, undef, 0x04C7, undef, 0x04C9, undef, 0x04CB, undef, 0x04CD, undef, 0x04D0, undef, 0x04D2, undef, 0x04D4, undef, 0x04D6, undef, 0x04D8, undef, 0x04DA, undef, 0x04DC, undef, 0x04DE, undef, 0x04E0, undef, 0x04E2, undef, 0x04E4, undef, 0x04E6, undef, 0x04E8, undef, 0x04EA, undef, 0x04EC, undef, 0x04EE, undef, 0x04F0, undef, 0x04F2, undef, 0x04F4, undef, 0x04F6, undef, 0x04F8, undef, 0x04FA, undef, 0x04FC, undef, 0x04FE, undef, 0x0500, undef, 0x0502, undef, 0x0504, undef, 0x0506, undef, 0x0508, undef, 0x050A, undef, 0x050C, undef, 0x050E, undef, 0x0510, undef, 0x0512, undef, 0x0514, undef, 0x0516, undef, 0x0518, undef, 0x051A, undef, 0x051C, undef, 0x051E, undef, 0x0520, undef, 0x0522, undef, 0x0524, undef, 0x0526, undef, 0x0528, undef, 0x052A, undef, 0x052C, undef, 0x052E, undef, 0x0531, 0x0556, 0x0587, undef, 0x0675, 0x0678, 0x0958, 0x095F, 0x09DC, 0x09DD, 0x09DF, undef, 0x0A33, undef, 0x0A36, undef, 0x0A59, 0x0A5B, 0x0A5E, undef, 0x0B5C, 0x0B5D, 0x0E33, undef, 0x0EB3, undef, 0x0EDC, 0x0EDD, 0x0F0C, undef, 0x0F43, undef, 0x0F4D, undef, 0x0F52, undef, 0x0F57, undef, 0x0F5C, undef, 0x0F69, undef, 0x0F73, undef, 0x0F75, 0x0F79, 0x0F81, undef, 0x0F93, undef, 0x0F9D, undef, 0x0FA2, undef, 0x0FA7, undef, 0x0FAC, undef, 0x0FB9, undef, 0x10C7, undef, 0x10CD, undef, 0x10FC, undef, 0x13F8, 0x13FD, 0x1C80, 0x1C88, 0x1D2C, 0x1D2E, 0x1D30, 0x1D3A, 0x1D3C, 0x1D4D, 0x1D4F, 0x1D6A, 0x1D78, undef, 0x1D9B, 0x1DBF, 0x1E00, undef, 0x1E02, undef, 0x1E04, undef, 0x1E06, undef, 0x1E08, undef, 0x1E0A, undef, 0x1E0C, undef, 0x1E0E, undef, 0x1E10, undef, 0x1E12, undef, 0x1E14, undef, 0x1E16, undef, 0x1E18, undef, 0x1E1A, undef, 0x1E1C, undef, 0x1E1E, undef, 0x1E20, undef, 0x1E22, undef, 0x1E24, undef, 0x1E26, undef, 0x1E28, undef, 0x1E2A, undef, 0x1E2C, undef, 0x1E2E, undef, 0x1E30, undef, 0x1E32, undef, 0x1E34, undef, 0x1E36, undef, 0x1E38, undef, 0x1E3A, undef, 0x1E3C, undef, 0x1E3E, undef, 0x1E40, undef, 0x1E42, undef, 0x1E44, undef, 0x1E46, undef, 0x1E48, undef, 0x1E4A, undef, 0x1E4C, undef, 0x1E4E, undef, 0x1E50, undef, 0x1E52, undef, 0x1E54, undef, 0x1E56, undef, 0x1E58, undef, 0x1E5A, undef, 0x1E5C, undef, 0x1E5E, undef, 0x1E60, undef, 0x1E62, undef, 0x1E64, undef, 0x1E66, undef, 0x1E68, undef, 0x1E6A, undef, 0x1E6C, undef, 0x1E6E, undef, 0x1E70, undef, 0x1E72, undef, 0x1E74, undef, 0x1E76, undef, 0x1E78, undef, 0x1E7A, undef, 0x1E7C, undef, 0x1E7E, undef, 0x1E80, undef, 0x1E82, undef, 0x1E84, undef, 0x1E86, undef, 0x1E88, undef, 0x1E8A, undef, 0x1E8C, undef, 0x1E8E, undef, 0x1E90, undef, 0x1E92, undef, 0x1E94, undef, 0x1E9A, 0x1E9B, 0x1E9E, undef, 0x1EA0, undef, 0x1EA2, undef, 0x1EA4, undef, 0x1EA6, undef, 0x1EA8, undef, 0x1EAA, undef, 0x1EAC, undef, 0x1EAE, undef, 0x1EB0, undef, 0x1EB2, undef, 0x1EB4, undef, 0x1EB6, undef, 0x1EB8, undef, 0x1EBA, undef, 0x1EBC, undef, 0x1EBE, undef, 0x1EC0, undef, 0x1EC2, undef, 0x1EC4, undef, 0x1EC6, undef, 0x1EC8, undef, 0x1ECA, undef, 0x1ECC, undef, 0x1ECE, undef, 0x1ED0, undef, 0x1ED2, undef, 0x1ED4, undef, 0x1ED6, undef, 0x1ED8, undef, 0x1EDA, undef, 0x1EDC, undef, 0x1EDE, undef, 0x1EE0, undef, 0x1EE2, undef, 0x1EE4, undef, 0x1EE6, undef, 0x1EE8, undef, 0x1EEA, undef, 0x1EEC, undef, 0x1EEE, undef, 0x1EF0, undef, 0x1EF2, undef, 0x1EF4, undef, 0x1EF6, undef, 0x1EF8, undef, 0x1EFA, undef, 0x1EFC, undef, 0x1EFE, undef, 0x1F08, 0x1F0F, 0x1F18, 0x1F1D, 0x1F28, 0x1F2F, 0x1F38, 0x1F3F, 0x1F48, 0x1F4D, 0x1F59, undef, 0x1F5B, undef, 0x1F5D, undef, 0x1F5F, undef, 0x1F68, 0x1F6F, 0x1F71, undef, 0x1F73, undef, 0x1F75, undef, 0x1F77, undef, 0x1F79, undef, 0x1F7B, undef, 0x1F7D, undef, 0x1F80, 0x1FAF, 0x1FB2, 0x1FB4, 0x1FB7, 0x1FBC, 0x1FBE, undef, 0x1FC2, 0x1FC4, 0x1FC7, 0x1FCC, 0x1FD3, undef, 0x1FD8, 0x1FDB, 0x1FE3, undef, 0x1FE8, 0x1FEC, 0x1FF2, 0x1FF4, 0x1FF7, 0x1FFC, 0x2011, undef, 0x2033, 0x2034, 0x2036, 0x2037, 0x2057, undef, 0x2070, 0x2071, 0x2074, 0x2079, 0x207B, undef, 0x207F, 0x2089, 0x208B, undef, 0x2090, 0x209C, 0x20A8, undef, 0x2102, 0x2103, 0x2107, undef, 0x2109, 0x2113, 0x2115, 0x2116, 0x2119, 0x211D, 0x2120, 0x2122, 0x2124, undef, 0x2126, undef, 0x2128, undef, 0x212A, 0x212D, 0x212F, 0x2131, 0x2133, 0x2139, 0x213B, 0x2140, 0x2145, 0x2149, 0x2150, 0x217F, 0x2189, undef, 0x222C, 0x222D, 0x222F, 0x2230, 0x2329, 0x232A, 0x2460, 0x2473, 0x24B6, 0x24EA, 0x2A0C, undef, 0x2ADC, undef, 0x2C00, 0x2C2E, 0x2C60, undef, 0x2C62, 0x2C64, 0x2C67, undef, 0x2C69, undef, 0x2C6B, undef, 0x2C6D, 0x2C70, 0x2C72, undef, 0x2C75, undef, 0x2C7C, 0x2C80, 0x2C82, undef, 0x2C84, undef, 0x2C86, undef, 0x2C88, undef, 0x2C8A, undef, 0x2C8C, undef, 0x2C8E, undef, 0x2C90, undef, 0x2C92, undef, 0x2C94, undef, 0x2C96, undef, 0x2C98, undef, 0x2C9A, undef, 0x2C9C, undef, 0x2C9E, undef, 0x2CA0, undef, 0x2CA2, undef, 0x2CA4, undef, 0x2CA6, undef, 0x2CA8, undef, 0x2CAA, undef, 0x2CAC, undef, 0x2CAE, undef, 0x2CB0, undef, 0x2CB2, undef, 0x2CB4, undef, 0x2CB6, undef, 0x2CB8, undef, 0x2CBA, undef, 0x2CBC, undef, 0x2CBE, undef, 0x2CC0, undef, 0x2CC2, undef, 0x2CC4, undef, 0x2CC6, undef, 0x2CC8, undef, 0x2CCA, undef, 0x2CCC, undef, 0x2CCE, undef, 0x2CD0, undef, 0x2CD2, undef, 0x2CD4, undef, 0x2CD6, undef, 0x2CD8, undef, 0x2CDA, undef, 0x2CDC, undef, 0x2CDE, undef, 0x2CE0, undef, 0x2CE2, undef, 0x2CEB, undef, 0x2CED, undef, 0x2CF2, undef, 0x2D6F, undef, 0x2E9F, undef, 0x2EF3, undef, 0x2F00, 0x2FD5, 0x3002, undef, 0x3036, undef, 0x3038, 0x303A, 0x309F, undef, 0x30FF, undef, 0x3131, 0x3163, 0x3165, 0x318E, 0x3192, 0x319F, 0x3244, 0x3247, 0x3250, 0x327E, 0x3280, 0x32FE, 0x3300, 0x33C1, 0x33C3, 0x33C6, 0x33C8, 0x33D7, 0x33D9, 0x33FF, 0xA640, undef, 0xA642, undef, 0xA644, undef, 0xA646, undef, 0xA648, undef, 0xA64A, undef, 0xA64C, undef, 0xA64E, undef, 0xA650, undef, 0xA652, undef, 0xA654, undef, 0xA656, undef, 0xA658, undef, 0xA65A, undef, 0xA65C, undef, 0xA65E, undef, 0xA660, undef, 0xA662, undef, 0xA664, undef, 0xA666, undef, 0xA668, undef, 0xA66A, undef, 0xA66C, undef, 0xA680, undef, 0xA682, undef, 0xA684, undef, 0xA686, undef, 0xA688, undef, 0xA68A, undef, 0xA68C, undef, 0xA68E, undef, 0xA690, undef, 0xA692, undef, 0xA694, undef, 0xA696, undef, 0xA698, undef, 0xA69A, undef, 0xA69C, 0xA69D, 0xA722, undef, 0xA724, undef, 0xA726, undef, 0xA728, undef, 0xA72A, undef, 0xA72C, undef, 0xA72E, undef, 0xA732, undef, 0xA734, undef, 0xA736, undef, 0xA738, undef, 0xA73A, undef, 0xA73C, undef, 0xA73E, undef, 0xA740, undef, 0xA742, undef, 0xA744, undef, 0xA746, undef, 0xA748, undef, 0xA74A, undef, 0xA74C, undef, 0xA74E, undef, 0xA750, undef, 0xA752, undef, 0xA754, undef, 0xA756, undef, 0xA758, undef, 0xA75A, undef, 0xA75C, undef, 0xA75E, undef, 0xA760, undef, 0xA762, undef, 0xA764, undef, 0xA766, undef, 0xA768, undef, 0xA76A, undef, 0xA76C, undef, 0xA76E, undef, 0xA770, undef, 0xA779, undef, 0xA77B, undef, 0xA77D, 0xA77E, 0xA780, undef, 0xA782, undef, 0xA784, undef, 0xA786, undef, 0xA78B, undef, 0xA78D, undef, 0xA790, undef, 0xA792, undef, 0xA796, undef, 0xA798, undef, 0xA79A, undef, 0xA79C, undef, 0xA79E, undef, 0xA7A0, undef, 0xA7A2, undef, 0xA7A4, undef, 0xA7A6, undef, 0xA7A8, undef, 0xA7AA, 0xA7AE, 0xA7B0, 0xA7B4, 0xA7B6, undef, 0xA7F8, 0xA7F9, 0xAB5C, 0xAB5F, 0xAB70, 0xABBF, 0xF900, 0xFA0D, 0xFA10, undef, 0xFA12, undef, 0xFA15, 0xFA1E, 0xFA20, undef, 0xFA22, undef, 0xFA25, 0xFA26, 0xFA2A, 0xFA6D, 0xFA70, 0xFAD9, 0xFB00, 0xFB06, 0xFB13, 0xFB17, 0xFB1D, undef, 0xFB1F, 0xFB28, 0xFB2A, 0xFB36, 0xFB38, 0xFB3C, 0xFB3E, undef, 0xFB40, 0xFB41, 0xFB43, 0xFB44, 0xFB46, 0xFBB1, 0xFBD3, 0xFC5D, 0xFC64, 0xFD3D, 0xFD50, 0xFD8F, 0xFD92, 0xFDC7, 0xFDF0, 0xFDF9, 0xFDFC, undef, 0xFE11, undef, 0xFE17, 0xFE18, 0xFE31, 0xFE32, 0xFE39, 0xFE44, 0xFE51, undef, 0xFE58, undef, 0xFE5D, 0xFE5E, 0xFE63, undef, 0xFE71, undef, 0xFE77, undef, 0xFE79, undef, 0xFE7B, undef, 0xFE7D, undef, 0xFE7F, 0xFEFC, 0xFF0D, 0xFF0E, 0xFF10, 0xFF19, 0xFF21, 0xFF3A, 0xFF41, 0xFF5A, 0xFF5F, 0xFF9F, 0xFFA1, 0xFFBE, 0xFFC2, 0xFFC7, 0xFFCA, 0xFFCF, 0xFFD2, 0xFFD7, 0xFFDA, 0xFFDC, 0xFFE0, 0xFFE2, 0xFFE4, 0xFFE6, 0xFFE8, 0xFFEE, 0x10400, 0x10427, 0x104B0, 0x104D3, 0x10C80, 0x10CB2, 0x118A0, 0x118BF, 0x1D15E, 0x1D164, 0x1D1BB, 0x1D1C0, 0x1D400, 0x1D454, 0x1D456, 0x1D49C, 0x1D49E, 0x1D49F, 0x1D4A2, undef, 0x1D4A5, 0x1D4A6, 0x1D4A9, 0x1D4AC, 0x1D4AE, 0x1D4B9, 0x1D4BB, undef, 0x1D4BD, 0x1D4C3, 0x1D4C5, 0x1D505, 0x1D507, 0x1D50A, 0x1D50D, 0x1D514, 0x1D516, 0x1D51C, 0x1D51E, 0x1D539, 0x1D53B, 0x1D53E, 0x1D540, 0x1D544, 0x1D546, undef, 0x1D54A, 0x1D550, 0x1D552, 0x1D6A5, 0x1D6A8, 0x1D7CB, 0x1D7CE, 0x1D7FF, 0x1E900, 0x1E921, 0x1EE00, 0x1EE03, 0x1EE05, 0x1EE1F, 0x1EE21, 0x1EE22, 0x1EE24, undef, 0x1EE27, undef, 0x1EE29, 0x1EE32, 0x1EE34, 0x1EE37, 0x1EE39, undef, 0x1EE3B, undef, 0x1EE42, undef, 0x1EE47, undef, 0x1EE49, undef, 0x1EE4B, undef, 0x1EE4D, 0x1EE4F, 0x1EE51, 0x1EE52, 0x1EE54, undef, 0x1EE57, undef, 0x1EE59, undef, 0x1EE5B, undef, 0x1EE5D, undef, 0x1EE5F, undef, 0x1EE61, 0x1EE62, 0x1EE64, undef, 0x1EE67, 0x1EE6A, 0x1EE6C, 0x1EE72, 0x1EE74, 0x1EE77, 0x1EE79, 0x1EE7C, 0x1EE7E, undef, 0x1EE80, 0x1EE89, 0x1EE8B, 0x1EE9B, 0x1EEA1, 0x1EEA3, 0x1EEA5, 0x1EEA9, 0x1EEAB, 0x1EEBB, 0x1F12A, 0x1F12E, 0x1F130, 0x1F14F, 0x1F16A, 0x1F16B, 0x1F190, undef, 0x1F200, 0x1F202, 0x1F210, 0x1F23B, 0x1F240, 0x1F248, 0x1F250, 0x1F251, 0x2F800, 0x2F867, 0x2F869, 0x2F873, 0x2F875, 0x2F91E, 0x2F920, 0x2F95E, 0x2F960, 0x2F9BE, 0x2F9C0, 0x2FA1D, ); sub IsMapped { return _mk_prop(@MAPPED); }; sub MapMapped { my $l = shift; $l =~ tr/ABCDEFGHIJKLMNOPQRSTUVWXYZª\x{00B2}\x{00B3}µ\x{00B9}ºÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞĀĂĄĆĈĊČĎĐĒĔĖĘĚĜĞĠĢĤĦĨĪĬĮĴĶĹĻĽŁŃŅŇŊŌŎŐŒŔŖŘŚŜŞŠŢŤŦŨŪŬŮŰŲŴŶŸŹŻŽſƁƂƄƆƇƉƊƋƎƏƐƑƓƔƖƗƘƜƝƟƠƢƤƦƧƩƬƮƯƱƲƳƵƷƸƼǍǏǑǓǕǗǙǛǞǠǢǤǦǨǪǬǮǴǶǷǸǺǼǾȀȂȄȆȈȊȌȎȐȒȔȖȘȚȜȞȠȢȤȦȨȪȬȮȰȲȺȻȽȾɁɃɄɅɆɈɊɌɎʰʱʲʳʴʵʶʷʸˠˡˢˣˤ\x{0340}\x{0341}\x{0343}ͅͰͲʹͶͿΆ\x{0387}ΈΉΊΌΎΏΑΒΓΔΕΖΗΘΙΚΛΜΝΞΟΠΡΣΤΥΦΧΨΩΪΫϏϐϑϒϓϔϕϖϘϚϜϞϠϢϤϦϨϪϬϮϰϱϲϴϵϷϹϺϽϾϿЀЁЂЃЄЅІЇЈЉЊЋЌЍЎЏАБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯѠѢѤѦѨѪѬѮѰѲѴѶѸѺѼѾҀҊҌҎҐҒҔҖҘҚҜҞҠҢҤҦҨҪҬҮҰҲҴҶҸҺҼҾӁӃӅӇӉӋӍӐӒӔӖӘӚӜӞӠӢӤӦӨӪӬӮӰӲӴӶӸӺӼӾԀԂԄԆԈԊԌԎԐԒԔԖԘԚԜԞԠԢԤԦԨԪԬԮԱԲԳԴԵԶԷԸԹԺԻԼԽԾԿՀՁՂՃՄՅՆՇՈՉՊՋՌՍՎՏՐՑՒՓՔՕՖ\x{0F0C}ჇჍჼᏸᏹᏺᏻᏼᏽᲀᲁᲂᲃᲄᲅᲆᲇᲈᴬᴭᴮᴰᴱᴲᴳᴴᴵᴶᴷᴸᴹᴺᴼᴽᴾᴿᵀᵁᵂᵃᵄᵅᵆᵇᵈᵉᵊᵋᵌᵍᵏᵐᵑᵒᵓᵔᵕᵖᵗᵘᵙᵚᵛᵜᵝᵞᵟᵠᵡᵢᵣᵤᵥᵦᵧᵨᵩᵪᵸᶛᶜᶝᶞᶟᶠᶡᶢᶣᶤᶥᶦᶧᶨᶩᶪᶫᶬᶭᶮᶯᶰᶱᶲᶳᶴᶵᶶᶷᶸᶹᶺᶻᶼᶽᶾᶿḀḂḄḆḈḊḌḎḐḒḔḖḘḚḜḞḠḢḤḦḨḪḬḮḰḲḴḶḸḺḼḾṀṂṄṆṈṊṌṎṐṒṔṖṘṚṜṞṠṢṤṦṨṪṬṮṰṲṴṶṸṺṼṾẀẂẄẆẈẊẌẎẐẒẔẛẠẢẤẦẨẪẬẮẰẲẴẶẸẺẼẾỀỂỄỆỈỊỌỎỐỒỔỖỘỚỜỞỠỢỤỦỨỪỬỮỰỲỴỶỸỺỼỾἈἉἊἋἌἍἎἏἘἙἚἛἜἝἨἩἪἫἬἭἮἯἸἹἺἻἼἽἾἿὈὉὊὋὌὍὙὛὝὟὨὩὪὫὬὭὮὯάέήίόύώᾸᾹᾺΆιῈΈῊΉΐῘῙῚΊΰῨῩῪΎῬῸΌῺΏ\x{2011}\x{2070}ⁱ\x{2074}\x{2075}\x{2076}\x{2077}\x{2078}\x{2079}\x{207B}ⁿ\x{2080}\x{2081}\x{2082}\x{2083}\x{2084}\x{2085}\x{2086}\x{2087}\x{2088}\x{2089}\x{208B}ₐₑₒₓₔₕₖₗₘₙₚₛₜℂℇℊℋℌℍℎℏℐℑℒℓℕℙℚℛℜℝℤΩℨKÅℬℭℯℰℱℳℴℵℶℷℸℹℼℽℾℿ\x{2140}ⅅⅆⅇⅈⅉⅠⅤⅩⅬⅭⅮⅯⅰⅴⅹⅼⅽⅾⅿ\x{2329}\x{232A}\x{2460}\x{2461}\x{2462}\x{2463}\x{2464}\x{2465}\x{2466}\x{2467}\x{2468}ⒶⒷⒸⒹⒺⒻⒼⒽⒾⒿⓀⓁⓂⓃⓄⓅⓆⓇⓈⓉⓊⓋⓌⓍⓎⓏⓐⓑⓒⓓⓔⓕⓖⓗⓘⓙⓚⓛⓜⓝⓞⓟⓠⓡⓢⓣⓤⓥⓦⓧⓨⓩ\x{24EA}ⰀⰁⰂⰃⰄⰅⰆⰇⰈⰉⰊⰋⰌⰍⰎⰏⰐⰑⰒⰓⰔⰕⰖⰗⰘⰙⰚⰛⰜⰝⰞⰟⰠⰡⰢⰣⰤⰥⰦⰧⰨⰩⰪⰫⰬⰭⰮⱠⱢⱣⱤⱧⱩⱫⱭⱮⱯⱰⱲⱵⱼⱽⱾⱿⲀⲂⲄⲆⲈⲊⲌⲎⲐⲒⲔⲖⲘⲚⲜⲞⲠⲢⲤⲦⲨⲪⲬⲮⲰⲲⲴⲶⲸⲺⲼⲾⳀⳂⳄⳆⳈⳊⳌⳎⳐⳒⳔⳖⳘⳚⳜⳞⳠⳢⳫⳭⳲⵯ\x{2E9F}\x{2EF3}\x{2F00}\x{2F01}\x{2F02}\x{2F03}\x{2F04}\x{2F05}\x{2F06}\x{2F07}\x{2F08}\x{2F09}\x{2F0A}\x{2F0B}\x{2F0C}\x{2F0D}\x{2F0E}\x{2F0F}\x{2F10}\x{2F11}\x{2F12}\x{2F13}\x{2F14}\x{2F15}\x{2F16}\x{2F17}\x{2F18}\x{2F19}\x{2F1A}\x{2F1B}\x{2F1C}\x{2F1D}\x{2F1E}\x{2F1F}\x{2F20}\x{2F21}\x{2F22}\x{2F23}\x{2F24}\x{2F25}\x{2F26}\x{2F27}\x{2F28}\x{2F29}\x{2F2A}\x{2F2B}\x{2F2C}\x{2F2D}\x{2F2E}\x{2F2F}\x{2F30}\x{2F31}\x{2F32}\x{2F33}\x{2F34}\x{2F35}\x{2F36}\x{2F37}\x{2F38}\x{2F39}\x{2F3A}\x{2F3B}\x{2F3C}\x{2F3D}\x{2F3E}\x{2F3F}\x{2F40}\x{2F41}\x{2F42}\x{2F43}\x{2F44}\x{2F45}\x{2F46}\x{2F47}\x{2F48}\x{2F49}\x{2F4A}\x{2F4B}\x{2F4C}\x{2F4D}\x{2F4E}\x{2F4F}\x{2F50}\x{2F51}\x{2F52}\x{2F53}\x{2F54}\x{2F55}\x{2F56}\x{2F57}\x{2F58}\x{2F59}\x{2F5A}\x{2F5B}\x{2F5C}\x{2F5D}\x{2F5E}\x{2F5F}\x{2F60}\x{2F61}\x{2F62}\x{2F63}\x{2F64}\x{2F65}\x{2F66}\x{2F67}\x{2F68}\x{2F69}\x{2F6A}\x{2F6B}\x{2F6C}\x{2F6D}\x{2F6E}\x{2F6F}\x{2F70}\x{2F71}\x{2F72}\x{2F73}\x{2F74}\x{2F75}\x{2F76}\x{2F77}\x{2F78}\x{2F79}\x{2F7A}\x{2F7B}\x{2F7C}\x{2F7D}\x{2F7E}\x{2F7F}\x{2F80}\x{2F81}\x{2F82}\x{2F83}\x{2F84}\x{2F85}\x{2F86}\x{2F87}\x{2F88}\x{2F89}\x{2F8A}\x{2F8B}\x{2F8C}\x{2F8D}\x{2F8E}\x{2F8F}\x{2F90}\x{2F91}\x{2F92}\x{2F93}\x{2F94}\x{2F95}\x{2F96}\x{2F97}\x{2F98}\x{2F99}\x{2F9A}\x{2F9B}\x{2F9C}\x{2F9D}\x{2F9E}\x{2F9F}\x{2FA0}\x{2FA1}\x{2FA2}\x{2FA3}\x{2FA4}\x{2FA5}\x{2FA6}\x{2FA7}\x{2FA8}\x{2FA9}\x{2FAA}\x{2FAB}\x{2FAC}\x{2FAD}\x{2FAE}\x{2FAF}\x{2FB0}\x{2FB1}\x{2FB2}\x{2FB3}\x{2FB4}\x{2FB5}\x{2FB6}\x{2FB7}\x{2FB8}\x{2FB9}\x{2FBA}\x{2FBB}\x{2FBC}\x{2FBD}\x{2FBE}\x{2FBF}\x{2FC0}\x{2FC1}\x{2FC2}\x{2FC3}\x{2FC4}\x{2FC5}\x{2FC6}\x{2FC7}\x{2FC8}\x{2FC9}\x{2FCA}\x{2FCB}\x{2FCC}\x{2FCD}\x{2FCE}\x{2FCF}\x{2FD0}\x{2FD1}\x{2FD2}\x{2FD3}\x{2FD4}\x{2FD5}\x{3002}\x{3036}〸〹〺ㄱㄲㄳㄴㄵㄶㄷㄸㄹㄺㄻㄼㄽㄾㄿㅀㅁㅂㅃㅄㅅㅆㅇㅈㅉㅊㅋㅌㅍㅎㅏㅐㅑㅒㅓㅔㅕㅖㅗㅘㅙㅚㅛㅜㅝㅞㅟㅠㅡㅢㅣㅥㅦㅧㅨㅩㅪㅫㅬㅭㅮㅯㅰㅱㅲㅳㅴㅵㅶㅷㅸㅹㅺㅻㅼㅽㅾㅿㆀㆁㆂㆃㆄㆅㆆㆇㆈㆉㆊㆋㆌㆍㆎ\x{3192}\x{3193}\x{3194}\x{3195}\x{3196}\x{3197}\x{3198}\x{3199}\x{319A}\x{319B}\x{319C}\x{319D}\x{319E}\x{319F}\x{3244}\x{3245}\x{3246}\x{3247}\x{3260}\x{3261}\x{3262}\x{3263}\x{3264}\x{3265}\x{3266}\x{3267}\x{3268}\x{3269}\x{326A}\x{326B}\x{326C}\x{326D}\x{326E}\x{326F}\x{3270}\x{3271}\x{3272}\x{3273}\x{3274}\x{3275}\x{3276}\x{3277}\x{3278}\x{3279}\x{327A}\x{327B}\x{327E}\x{3280}\x{3281}\x{3282}\x{3283}\x{3284}\x{3285}\x{3286}\x{3287}\x{3288}\x{3289}\x{328A}\x{328B}\x{328C}\x{328D}\x{328E}\x{328F}\x{3290}\x{3291}\x{3292}\x{3293}\x{3294}\x{3295}\x{3296}\x{3297}\x{3298}\x{3299}\x{329A}\x{329B}\x{329C}\x{329D}\x{329E}\x{329F}\x{32A0}\x{32A1}\x{32A2}\x{32A3}\x{32A4}\x{32A5}\x{32A6}\x{32A7}\x{32A8}\x{32A9}\x{32AA}\x{32AB}\x{32AC}\x{32AD}\x{32AE}\x{32AF}\x{32B0}\x{32D0}\x{32D1}\x{32D2}\x{32D3}\x{32D4}\x{32D5}\x{32D6}\x{32D7}\x{32D8}\x{32D9}\x{32DA}\x{32DB}\x{32DC}\x{32DD}\x{32DE}\x{32DF}\x{32E0}\x{32E1}\x{32E2}\x{32E3}\x{32E4}\x{32E5}\x{32E6}\x{32E7}\x{32E8}\x{32E9}\x{32EA}\x{32EB}\x{32EC}\x{32ED}\x{32EE}\x{32EF}\x{32F0}\x{32F1}\x{32F2}\x{32F3}\x{32F4}\x{32F5}\x{32F6}\x{32F7}\x{32F8}\x{32F9}\x{32FA}\x{32FB}\x{32FC}\x{32FD}\x{32FE}ꙀꙂꙄꙆꙈꙊꙌꙎꙐꙒꙔꙖꙘꙚꙜꙞꙠꙢꙤꙦꙨꙪꙬꚀꚂꚄꚆꚈꚊꚌꚎꚐꚒꚔꚖꚘꚚꚜꚝꜢꜤꜦꜨꜪꜬꜮꜲꜴꜶꜸꜺꜼꜾꝀꝂꝄꝆꝈꝊꝌꝎꝐꝒꝔꝖꝘꝚꝜꝞꝠꝢꝤꝦꝨꝪꝬꝮꝰꝹꝻꝽꝾꞀꞂꞄꞆꞋꞍꞐꞒꞖꞘꞚꞜꞞꞠꞢꞤꞦꞨꞪꞫꞬꞭꞮꞰꞱꞲꞳꞴꞶꟸꟹꭜꭝꭞꭟꭰꭱꭲꭳꭴꭵꭶꭷꭸꭹꭺꭻꭼꭽꭾꭿꮀꮁꮂꮃꮄꮅꮆꮇꮈꮉꮊꮋꮌꮍꮎꮏꮐꮑꮒꮓꮔꮕꮖꮗꮘꮙꮚꮛꮜꮝꮞꮟꮠꮡꮢꮣꮤꮥꮦꮧꮨꮩꮪꮫꮬꮭꮮꮯꮰꮱꮲꮳꮴꮵꮶꮷꮸꮹꮺꮻꮼꮽꮾꮿ豈更車賈滑串句龜龜契金喇奈懶癩羅蘿螺裸邏樂洛烙珞落酪駱亂卵欄爛蘭鸞嵐濫藍襤拉臘蠟廊朗浪狼郎來冷勞擄櫓爐盧老蘆虜路露魯鷺碌祿綠菉錄鹿論壟弄籠聾牢磊賂雷壘屢樓淚漏累縷陋勒肋凜凌稜綾菱陵讀拏樂諾丹寧怒率異北磻便復不泌數索參塞省葉說殺辰沈拾若掠略亮兩凉梁糧良諒量勵呂女廬旅濾礪閭驪麗黎力曆歷轢年憐戀撚漣煉璉秊練聯輦蓮連鍊列劣咽烈裂說廉念捻殮簾獵令囹寧嶺怜玲瑩羚聆鈴零靈領例禮醴隸惡了僚寮尿料樂燎療蓼遼龍暈阮劉杻柳流溜琉留硫紐類六戮陸倫崙淪輪律慄栗率隆利吏履易李梨泥理痢罹裏裡里離匿溺吝燐璘藺隣鱗麟林淋臨立笠粒狀炙識什茶刺切度拓糖宅洞暴輻行降見廓兀嗀塚晴凞猪益礼神祥福靖精羽蘒諸逸都飯飼館鶴郞隷侮僧免勉勤卑喝嘆器塀墨層屮悔慨憎懲敏既暑梅海渚漢煮爫琢碑社祉祈祐祖祝禍禎穀突節練縉繁署者臭艹艹著褐視謁謹賓贈辶逸難響頻恵𤋮舘並况全侀充冀勇勺喝啕喙嗢塚墳奄奔婢嬨廒廙彩徭惘慎愈憎慠懲戴揄搜摒敖晴朗望杖歹殺流滛滋漢瀞煮瞧爵犯猪瑱甆画瘝瘟益盛直睊着磌窱節类絛練缾者荒華蝹襁覆視調諸請謁諾諭謹變贈輸遲醙鉶陼難靖韛響頋頻鬒龜𢡊𢡄𣏕㮝䀘䀹𥉉𥳐𧻓齃龎ﬠﬡﬢﬣﬤﬥﬦﬧﬨﭐﭑﭒﭓﭔﭕﭖﭗﭘﭙﭚﭛﭜﭝﭞﭟﭠﭡﭢﭣﭤﭥﭦﭧﭨﭩﭪﭫﭬﭭﭮﭯﭰﭱﭲﭳﭴﭵﭶﭷﭸﭹﭺﭻﭼﭽﭾﭿﮀﮁﮂﮃﮄﮅﮆﮇﮈﮉﮊﮋﮌﮍﮎﮏﮐﮑﮒﮓﮔﮕﮖﮗﮘﮙﮚﮛﮜﮝﮞﮟﮠﮡﮢﮣﮤﮥﮦﮧﮨﮩﮪﮫﮬﮭﮮﮯﮰﮱﯓﯔﯕﯖﯗﯘﯙﯚﯛﯜﯞﯟﯠﯡﯢﯣﯤﯥﯦﯧﯨﯩﯼﯽﯾﯿ\x{FE11}\x{FE17}\x{FE18}\x{FE31}\x{FE32}\x{FE39}\x{FE3A}\x{FE3B}\x{FE3C}\x{FE3D}\x{FE3E}\x{FE3F}\x{FE40}\x{FE41}\x{FE42}\x{FE43}\x{FE44}\x{FE51}\x{FE58}\x{FE5D}\x{FE5E}\x{FE63}ﺀﺁﺂﺃﺄﺅﺆﺇﺈﺉﺊﺋﺌﺍﺎﺏﺐﺑﺒﺓﺔﺕﺖﺗﺘﺙﺚﺛﺜﺝﺞﺟﺠﺡﺢﺣﺤﺥﺦﺧﺨﺩﺪﺫﺬﺭﺮﺯﺰﺱﺲﺳﺴﺵﺶﺷﺸﺹﺺﺻﺼﺽﺾﺿﻀﻁﻂﻃﻄﻅﻆﻇﻈﻉﻊﻋﻌﻍﻎﻏﻐﻑﻒﻓﻔﻕﻖﻗﻘﻙﻚﻛﻜﻝﻞﻟﻠﻡﻢﻣﻤﻥﻦﻧﻨﻩﻪﻫﻬﻭﻮﻯﻰﻱﻲﻳﻴ\x{FF0D}\x{FF0E}０１２３４５６７８９ＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚ\x{FF5F}\x{FF60}\x{FF61}\x{FF62}\x{FF63}\x{FF64}\x{FF65}ｦｧｨｩｪｫｬｭｮｯｰｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜﾝﾞﾟﾡﾢﾣﾤﾥﾦﾧﾨﾩﾪﾫﾬﾭﾮﾯﾰﾱﾲﾳﾴﾵﾶﾷﾸﾹﾺﾻﾼﾽﾾￂￃￄￅￆￇￊￋￌￍￎￏￒￓￔￕￖￗￚￛￜ\x{FFE0}\x{FFE1}\x{FFE2}\x{FFE4}\x{FFE5}\x{FFE6}\x{FFE8}\x{FFE9}\x{FFEA}\x{FFEB}\x{FFEC}\x{FFED}\x{FFEE}𐐀𐐁𐐂𐐃𐐄𐐅𐐆𐐇𐐈𐐉𐐊𐐋𐐌𐐍𐐎𐐏𐐐𐐑𐐒𐐓𐐔𐐕𐐖𐐗𐐘𐐙𐐚𐐛𐐜𐐝𐐞𐐟𐐠𐐡𐐢𐐣𐐤𐐥𐐦𐐧𐒰𐒱𐒲𐒳𐒴𐒵𐒶𐒷𐒸𐒹𐒺𐒻𐒼𐒽𐒾𐒿𐓀𐓁𐓂𐓃𐓄𐓅𐓆𐓇𐓈𐓉𐓊𐓋𐓌𐓍𐓎𐓏𐓐𐓑𐓒𐓓𐲀𐲁𐲂𐲃𐲄𐲅𐲆𐲇𐲈𐲉𐲊𐲋𐲌𐲍𐲎𐲏𐲐𐲑𐲒𐲓𐲔𐲕𐲖𐲗𐲘𐲙𐲚𐲛𐲜𐲝𐲞𐲟𐲠𐲡𐲢𐲣𐲤𐲥𐲦𐲧𐲨𐲩𐲪𐲫𐲬𐲭𐲮𐲯𐲰𐲱𐲲𑢠𑢡𑢢𑢣𑢤𑢥𑢦𑢧𑢨𑢩𑢪𑢫𑢬𑢭𑢮𑢯𑢰𑢱𑢲𑢳𑢴𑢵𑢶𑢷𑢸𑢹𑢺𑢻𑢼𑢽𑢾𑢿𝐀𝐁𝐂𝐃𝐄𝐅𝐆𝐇𝐈𝐉𝐊𝐋𝐌𝐍𝐎𝐏𝐐𝐑𝐒𝐓𝐔𝐕𝐖𝐗𝐘𝐙𝐚𝐛𝐜𝐝𝐞𝐟𝐠𝐡𝐢𝐣𝐤𝐥𝐦𝐧𝐨𝐩𝐪𝐫𝐬𝐭𝐮𝐯𝐰𝐱𝐲𝐳𝐴𝐵𝐶𝐷𝐸𝐹𝐺𝐻𝐼𝐽𝐾𝐿𝑀𝑁𝑂𝑃𝑄𝑅𝑆𝑇𝑈𝑉𝑊𝑋𝑌𝑍𝑎𝑏𝑐𝑑𝑒𝑓𝑔𝑖𝑗𝑘𝑙𝑚𝑛𝑜𝑝𝑞𝑟𝑠𝑡𝑢𝑣𝑤𝑥𝑦𝑧𝑨𝑩𝑪𝑫𝑬𝑭𝑮𝑯𝑰𝑱𝑲𝑳𝑴𝑵𝑶𝑷𝑸𝑹𝑺𝑻𝑼𝑽𝑾𝑿𝒀𝒁𝒂𝒃𝒄𝒅𝒆𝒇𝒈𝒉𝒊𝒋𝒌𝒍𝒎𝒏𝒐𝒑𝒒𝒓𝒔𝒕𝒖𝒗𝒘𝒙𝒚𝒛𝒜𝒞𝒟𝒢𝒥𝒦𝒩𝒪𝒫𝒬𝒮𝒯𝒰𝒱𝒲𝒳𝒴𝒵𝒶𝒷𝒸𝒹𝒻𝒽𝒾𝒿𝓀𝓁𝓂𝓃𝓅𝓆𝓇𝓈𝓉𝓊𝓋𝓌𝓍𝓎𝓏𝓐𝓑𝓒𝓓𝓔𝓕𝓖𝓗𝓘𝓙𝓚𝓛𝓜𝓝𝓞𝓟𝓠𝓡𝓢𝓣𝓤𝓥𝓦𝓧𝓨𝓩𝓪𝓫𝓬𝓭𝓮𝓯𝓰𝓱𝓲𝓳𝓴𝓵𝓶𝓷𝓸𝓹𝓺𝓻𝓼𝓽𝓾𝓿𝔀𝔁𝔂𝔃𝔄𝔅𝔇𝔈𝔉𝔊𝔍𝔎𝔏𝔐𝔑𝔒𝔓𝔔𝔖𝔗𝔘𝔙𝔚𝔛𝔜𝔞𝔟𝔠𝔡𝔢𝔣𝔤𝔥𝔦𝔧𝔨𝔩𝔪𝔫𝔬𝔭𝔮𝔯𝔰𝔱𝔲𝔳𝔴𝔵𝔶𝔷𝔸𝔹𝔻𝔼𝔽𝔾𝕀𝕁𝕂𝕃𝕄𝕆𝕊𝕋𝕌𝕍𝕎𝕏𝕐𝕒𝕓𝕔𝕕𝕖𝕗𝕘𝕙𝕚𝕛𝕜𝕝𝕞𝕟𝕠𝕡𝕢𝕣𝕤𝕥𝕦𝕧𝕨𝕩𝕪𝕫𝕬𝕭𝕮𝕯𝕰𝕱𝕲𝕳𝕴𝕵𝕶𝕷𝕸𝕹𝕺𝕻𝕼𝕽𝕾𝕿𝖀𝖁𝖂𝖃𝖄𝖅𝖆𝖇𝖈𝖉𝖊𝖋𝖌𝖍𝖎𝖏𝖐𝖑𝖒𝖓𝖔𝖕𝖖𝖗𝖘𝖙𝖚𝖛𝖜𝖝𝖞𝖟𝖠𝖡𝖢𝖣𝖤𝖥𝖦𝖧𝖨𝖩𝖪𝖫𝖬𝖭𝖮𝖯𝖰𝖱𝖲𝖳𝖴𝖵𝖶𝖷𝖸𝖹𝖺𝖻𝖼𝖽𝖾𝖿𝗀𝗁𝗂𝗃𝗄𝗅𝗆𝗇𝗈𝗉𝗊𝗋𝗌𝗍𝗎𝗏𝗐𝗑𝗒𝗓𝗔𝗕𝗖𝗗𝗘𝗙𝗚𝗛𝗜𝗝𝗞𝗟𝗠𝗡𝗢𝗣𝗤𝗥𝗦𝗧𝗨𝗩𝗪𝗫𝗬𝗭𝗮𝗯𝗰𝗱𝗲𝗳𝗴𝗵𝗶𝗷𝗸𝗹𝗺𝗻𝗼𝗽𝗾𝗿𝘀𝘁𝘂𝘃𝘄𝘅𝘆𝘇𝘈𝘉𝘊𝘋𝘌𝘍𝘎𝘏𝘐𝘑𝘒𝘓𝘔𝘕𝘖𝘗𝘘𝘙𝘚𝘛𝘜𝘝𝘞𝘟𝘠𝘡𝘢𝘣𝘤𝘥𝘦𝘧𝘨𝘩𝘪𝘫𝘬𝘭𝘮𝘯𝘰𝘱𝘲𝘳𝘴𝘵𝘶𝘷𝘸𝘹𝘺𝘻𝘼𝘽𝘾𝘿𝙀𝙁𝙂𝙃𝙄𝙅𝙆𝙇𝙈𝙉𝙊𝙋𝙌𝙍𝙎𝙏𝙐𝙑𝙒𝙓𝙔𝙕𝙖𝙗𝙘𝙙𝙚𝙛𝙜𝙝𝙞𝙟𝙠𝙡𝙢𝙣𝙤𝙥𝙦𝙧𝙨𝙩𝙪𝙫𝙬𝙭𝙮𝙯𝙰𝙱𝙲𝙳𝙴𝙵𝙶𝙷𝙸𝙹𝙺𝙻𝙼𝙽𝙾𝙿𝚀𝚁𝚂𝚃𝚄𝚅𝚆𝚇𝚈𝚉𝚊𝚋𝚌𝚍𝚎𝚏𝚐𝚑𝚒𝚓𝚔𝚕𝚖𝚗𝚘𝚙𝚚𝚛𝚜𝚝𝚞𝚟𝚠𝚡𝚢𝚣𝚤𝚥𝚨𝚩𝚪𝚫𝚬𝚭𝚮𝚯𝚰𝚱𝚲𝚳𝚴𝚵𝚶𝚷𝚸𝚹𝚺𝚻𝚼𝚽𝚾𝚿𝛀\x{1D6C1}𝛂𝛃𝛄𝛅𝛆𝛇𝛈𝛉𝛊𝛋𝛌𝛍𝛎𝛏𝛐𝛑𝛒𝛓𝛔𝛕𝛖𝛗𝛘𝛙𝛚\x{1D6DB}𝛜𝛝𝛞𝛟𝛠𝛡𝛢𝛣𝛤𝛥𝛦𝛧𝛨𝛩𝛪𝛫𝛬𝛭𝛮𝛯𝛰𝛱𝛲𝛳𝛴𝛵𝛶𝛷𝛸𝛹𝛺\x{1D6FB}𝛼𝛽𝛾𝛿𝜀𝜁𝜂𝜃𝜄𝜅𝜆𝜇𝜈𝜉𝜊𝜋𝜌𝜍𝜎𝜏𝜐𝜑𝜒𝜓𝜔\x{1D715}𝜖𝜗𝜘𝜙𝜚𝜛𝜜𝜝𝜞𝜟𝜠𝜡𝜢𝜣𝜤𝜥𝜦𝜧𝜨𝜩𝜪𝜫𝜬𝜭𝜮𝜯𝜰𝜱𝜲𝜳𝜴\x{1D735}𝜶𝜷𝜸𝜹𝜺𝜻𝜼𝜽𝜾𝜿𝝀𝝁𝝂𝝃𝝄𝝅𝝆𝝇𝝈𝝉𝝊𝝋𝝌𝝍𝝎\x{1D74F}𝝐𝝑𝝒𝝓𝝔𝝕𝝖𝝗𝝘𝝙𝝚𝝛𝝜𝝝𝝞𝝟𝝠𝝡𝝢𝝣𝝤𝝥𝝦𝝧𝝨𝝩𝝪𝝫𝝬𝝭𝝮\x{1D76F}𝝰𝝱𝝲𝝳𝝴𝝵𝝶𝝷𝝸𝝹𝝺𝝻𝝼𝝽𝝾𝝿𝞀𝞁𝞂𝞃𝞄𝞅𝞆𝞇𝞈\x{1D789}𝞊𝞋𝞌𝞍𝞎𝞏𝞐𝞑𝞒𝞓𝞔𝞕𝞖𝞗𝞘𝞙𝞚𝞛𝞜𝞝𝞞𝞟𝞠𝞡𝞢𝞣𝞤𝞥𝞦𝞧𝞨\x{1D7A9}𝞪𝞫𝞬𝞭𝞮𝞯𝞰𝞱𝞲𝞳𝞴𝞵𝞶𝞷𝞸𝞹𝞺𝞻𝞼𝞽𝞾𝞿𝟀𝟁𝟂\x{1D7C3}𝟄𝟅𝟆𝟇𝟈𝟉𝟊𝟋𝟎𝟏𝟐𝟑𝟒𝟓𝟔𝟕𝟖𝟗𝟘𝟙𝟚𝟛𝟜𝟝𝟞𝟟𝟠𝟡𝟢𝟣𝟤𝟥𝟦𝟧𝟨𝟩𝟪𝟫𝟬𝟭𝟮𝟯𝟰𝟱𝟲𝟳𝟴𝟵𝟶𝟷𝟸𝟹𝟺𝟻𝟼𝟽𝟾𝟿𞤀𞤁𞤂𞤃𞤄𞤅𞤆𞤇𞤈𞤉𞤊𞤋𞤌𞤍𞤎𞤏𞤐𞤑𞤒𞤓𞤔𞤕𞤖𞤗𞤘𞤙𞤚𞤛𞤜𞤝𞤞𞤟𞤠𞤡𞸀𞸁𞸂𞸃𞸅𞸆𞸇𞸈𞸉𞸊𞸋𞸌𞸍𞸎𞸏𞸐𞸑𞸒𞸓𞸔𞸕𞸖𞸗𞸘𞸙𞸚𞸛𞸜𞸝𞸞𞸟𞸡𞸢𞸤𞸧𞸩𞸪𞸫𞸬𞸭𞸮𞸯𞸰𞸱𞸲𞸴𞸵𞸶𞸷𞸹𞸻𞹂𞹇𞹉𞹋𞹍𞹎𞹏𞹑𞹒𞹔𞹗𞹙𞹛𞹝𞹟𞹡𞹢𞹤𞹧𞹨𞹩𞹪𞹬𞹭𞹮𞹯𞹰𞹱𞹲𞹴𞹵𞹶𞹷𞹹𞹺𞹻𞹼𞹾𞺀𞺁𞺂𞺃𞺄𞺅𞺆𞺇𞺈𞺉𞺋𞺌𞺍𞺎𞺏𞺐𞺑𞺒𞺓𞺔𞺕𞺖𞺗𞺘𞺙𞺚𞺛𞺡𞺢𞺣𞺥𞺦𞺧𞺨𞺩𞺫𞺬𞺭𞺮𞺯𞺰𞺱𞺲𞺳𞺴𞺵𞺶𞺷𞺸𞺹𞺺𞺻\x{1F12B}\x{1F12C}🄰🄱🄲🄳🄴🄵🄶🄷🄸🄹🄺🄻🄼🄽🄾🄿🅀🅁🅂🅃🅄🅅🅆🅇🅈🅉\x{1F202}\x{1F210}\x{1F211}\x{1F212}\x{1F213}\x{1F214}\x{1F215}\x{1F216}\x{1F217}\x{1F218}\x{1F219}\x{1F21A}\x{1F21B}\x{1F21C}\x{1F21D}\x{1F21E}\x{1F21F}\x{1F220}\x{1F221}\x{1F222}\x{1F223}\x{1F224}\x{1F225}\x{1F226}\x{1F227}\x{1F228}\x{1F229}\x{1F22A}\x{1F22B}\x{1F22C}\x{1F22D}\x{1F22E}\x{1F22F}\x{1F230}\x{1F231}\x{1F232}\x{1F233}\x{1F234}\x{1F235}\x{1F236}\x{1F237}\x{1F238}\x{1F239}\x{1F23A}\x{1F23B}\x{1F250}\x{1F251}丽丸乁𠄢你侮侻倂偺備僧像㒞𠘺免兔兤具𠔜㒹內再𠕋冗冤仌冬况𩇟凵刃㓟刻剆割剷㔕勇勉勤勺包匆北卉卑博即卽卿卿卿𠨬灰及叟𠭣叫叱吆咞吸呈周咢哶唐啓啣善善喙喫喳嗂圖嘆圗噑噴切壮城埴堍型堲報墬𡓤売壷夆多夢奢𡚨𡛪姬娛娧姘婦㛮嬈嬾嬾𡧈寃寘寧寳𡬘寿将尢㞁屠屮峀岍𡷤嵃𡷦嵮嵫嵼巡巢㠯巽帨帽幩㡢𢆃㡼庰庳庶廊𪎒廾𢌱𢌱舁弢弢㣇𣊸𦇚形彫㣣徚忍志忹悁㤺㤜悔𢛔惇慈慌慎慌慺憎憲憤憯懞懲懶成戛扝抱拔捐𢬌挽拼捨掃揤𢯱搢揅掩㨮摩摾撝摷㩬敏敬𣀊旣書晉㬙暑㬈㫤冒冕最暜肭䏙朗望朡杞杓𣏃㭉柺枅桒梅𣑭梎栟椔㮝楂榣槪檨𣚣櫛㰘次𣢧歔㱎歲殟殺殻𣪍𡴋𣫺汎𣲼沿泍汧洖派海流浩浸涅𣴞洴港湮㴳滋滇𣻑淹潮𣽞𣾎濆瀹瀞瀛㶖灊災灷炭𠔥煅𤉣熜爨爵牐𤘈犀犕𤜵𤠔獺王㺬玥㺸㺸瑇瑜瑱璅瓊㼛甤𤰶甾𤲒異𢆟瘐𤾡𤾸𥁄㿼䀈直𥃳𥃲𥄙𥄳眞真真睊䀹瞋䁆䂖𥐝硎碌磌䃣𥘦祖𥚚𥛅福秫䄯穀穊穏𥥼𥪧𥪧䈂𥮫篆築䈧𥲀糒䊠糨糣紀𥾆絣䌁緇縂繅䌴𦈨𦉇䍙𦋙罺𦌾羕翺者𦓚𦔣聠𦖨聰𣍟䏕育脃䐋脾媵𦞧𦞵𣎓𣎜舁舄辞䑫芑芋芝劳花芳芽苦𦬼若茝荣莭茣莽菧著荓菊菌菜𦰶𦵫𦳕䔫蓱蓳蔖𧏊蕤𦼬䕝䕡𦾱𧃒䕫虐虜虧虩蚩蚈蜎蛢蝹蜨蝫螆蟡蠁䗹衠衣𧙧裗裞䘵裺㒻𧢮𧥦䚾䛇誠諭變豕𧲨貫賁贛起𧼯𠠄跋趼跰𠣞軔輸𨗒𨗭邔郱鄑𨜮鄛鈸鋗鋘鉼鏹鐕𨯺開䦕閷𨵷䧦雃嶲霣𩅅𩈚䩮䩶韠𩐊䪲𩒖頋頋頩𩖶飢䬳餩馧駂駾䯎𩬰鬒鱀鳽䳎䳭鵧𪃎䳸𪄅𪈎𪊑麻䵖黹黾鼅鼏鼖鼻𪘀/abcdefghijklmnopqrstuvwxyza23μ1oàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþāăąćĉċčďđēĕėęěĝğġģĥħĩīĭįĵķĺļľłńņňŋōŏőœŕŗřśŝşšţťŧũūŭůűųŵŷÿźżžsɓƃƅɔƈɖɗƌǝəɛƒɠɣɩɨƙɯɲɵơƣƥʀƨʃƭʈưʊʋƴƶʒƹƽǎǐǒǔǖǘǚǜǟǡǣǥǧǩǫǭǯǵƕƿǹǻǽǿȁȃȅȇȉȋȍȏȑȓȕȗșțȝȟƞȣȥȧȩȫȭȯȱȳⱥȼƚⱦɂƀʉʌɇɉɋɍɏhɦjrɹɻʁwyɣlsxʕ\x{0300}\x{0301}\x{0313}ιͱͳʹͷϳά\x{00B7}έήίόύώαβγδεζηθικλμνξοπρστυφχψωϊϋϗβθυύϋφπϙϛϝϟϡϣϥϧϩϫϭϯκρσθεϸσϻͻͼͽѐёђѓєѕіїјљњћќѝўџабвгдежзийклмнопрстуфхцчшщъыьэюяѡѣѥѧѩѫѭѯѱѳѵѷѹѻѽѿҁҋҍҏґғҕҗҙқҝҟҡңҥҧҩҫҭүұҳҵҷҹһҽҿӂӄӆӈӊӌӎӑӓӕӗәӛӝӟӡӣӥӧөӫӭӯӱӳӵӷӹӻӽӿԁԃԅԇԉԋԍԏԑԓԕԗԙԛԝԟԡԣԥԧԩԫԭԯաբգդեզէըթժիլխծկհձղճմյնշոչպջռսվտրցւփքօֆ\x{0F0B}ⴧⴭნᏰᏱᏲᏳᏴᏵвдосттъѣꙋaæbdeǝghijklmnoȣprtuwaɐɑᴂbdeəɛɜgkmŋoɔᴖᴗptuᴝɯvᴥβγδφχiruvβγρφχнɒcɕðɜfɟɡɥɨɩɪᵻʝɭᶅʟɱɰɲɳɴɵɸʂʃƫʉʊᴜʋʌzʐʑʒθḁḃḅḇḉḋḍḏḑḓḕḗḙḛḝḟḡḣḥḧḩḫḭḯḱḳḵḷḹḻḽḿṁṃṅṇṉṋṍṏṑṓṕṗṙṛṝṟṡṣṥṧṩṫṭṯṱṳṵṷṹṻṽṿẁẃẅẇẉẋẍẏẑẓẕṡạảấầẩẫậắằẳẵặẹẻẽếềểễệỉịọỏốồổỗộớờởỡợụủứừửữựỳỵỷỹỻỽỿἀἁἂἃἄἅἆἇἐἑἒἓἔἕἠἡἢἣἤἥἦἧἰἱἲἳἴἵἶἷὀὁὂὃὄὅὑὓὕὗὠὡὢὣὤὥὦὧάέήίόύώᾰᾱὰάιὲέὴήΐῐῑὶίΰῠῡὺύῥὸόὼώ\x{2010}0i456789\x{2212}n0123456789\x{2212}aeoxəhklmnpstcɛghhhhħiillnpqrrrzωzkåbceefmoאבגדiπγγπ\x{2211}ddeijivxlcdmivxlcdm\x{3008}\x{3009}123456789abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz0ⰰⰱⰲⰳⰴⰵⰶⰷⰸⰹⰺⰻⰼⰽⰾⰿⱀⱁⱂⱃⱄⱅⱆⱇⱈⱉⱊⱋⱌⱍⱎⱏⱐⱑⱒⱓⱔⱕⱖⱗⱘⱙⱚⱛⱜⱝⱞⱡɫᵽɽⱨⱪⱬɑɱɐɒⱳⱶjvȿɀⲁⲃⲅⲇⲉⲋⲍⲏⲑⲓⲕⲗⲙⲛⲝⲟⲡⲣⲥⲧⲩⲫⲭⲯⲱⲳⲵⲷⲹⲻⲽⲿⳁⳃⳅⳇⳉⳋⳍⳏⳑⳓⳕⳗⳙⳛⳝⳟⳡⳣⳬⳮⳳⵡ母龟一丨丶丿乙亅二亠人儿入八冂冖冫几凵刀力勹匕匚匸十卜卩厂厶又口囗土士夂夊夕大女子宀寸小尢尸屮山巛工己巾干幺广廴廾弋弓彐彡彳心戈戶手支攴文斗斤方无日曰月木欠止歹殳毋比毛氏气水火爪父爻爿片牙牛犬玄玉瓜瓦甘生用田疋疒癶白皮皿目矛矢石示禸禾穴立竹米糸缶网羊羽老而耒耳聿肉臣自至臼舌舛舟艮色艸虍虫血行衣襾見角言谷豆豕豸貝赤走足身車辛辰辵邑酉釆里金長門阜隶隹雨靑非面革韋韭音頁風飛食首香馬骨高髟鬥鬯鬲鬼魚鳥鹵鹿麥麻黃黍黑黹黽鼎鼓鼠鼻齊齒龍龜龠\.\x{3012}十卄卅ᄀᄁᆪᄂᆬᆭᄃᄄᄅᆰᆱᆲᆳᆴᆵᄚᄆᄇᄈᄡᄉᄊᄋᄌᄍᄎᄏᄐᄑ하ᅢᅣᅤᅥᅦᅧᅨᅩᅪᅫᅬᅭᅮᅯᅰᅱᅲᅳᅴᅵᄔᄕᇇᇈᇌᇎᇓᇗᇙᄜᇝᇟᄝᄞᄠᄢᄣᄧᄩᄫᄬᄭᄮᄯᄲᄶᅀᅇᅌᇱᇲᅗᅘᅙᆄᆅᆈᆑᆒᆔᆞᆡ一二三四上中下甲乙丙丁天地人問幼文箏ᄀᄂᄃᄅᄆᄇᄉᄋᄌᄎᄏᄐᄑᄒ가나다라마바사아자차카타파하우一二三四五六七八九十月火水木金土日株有社名特財祝労秘男女適優印注項休写正上中下左右医宗学監企資協夜アイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤユヨラリルレロワヰヱヲꙁꙃꙅꙇꙉꙋꙍꙏꙑꙓꙕꙗꙙꙛꙝꙟꙡꙣꙥꙧꙩꙫꙭꚁꚃꚅꚇꚉꚋꚍꚏꚑꚓꚕꚗꚙꚛъьꜣꜥꜧꜩꜫꜭꜯꜳꜵꜷꜹꜻꜽꜿꝁꝃꝅꝇꝉꝋꝍꝏꝑꝓꝕꝗꝙꝛꝝꝟꝡꝣꝥꝧꝩꝫꝭꝯꝯꝺꝼᵹꝿꞁꞃꞅꞇꞌɥꞑꞓꞗꞙꞛꞝꞟꞡꞣꞥꞧꞩɦɜɡɬɪʞʇʝꭓꞵꞷħœꜧꬷɫꭒᎠᎡᎢᎣᎤᎥᎦᎧᎨᎩᎪᎫᎬᎭᎮᎯᎰᎱᎲᎳᎴᎵᎶᎷᎸᎹᎺᎻᎼᎽᎾᎿᏀᏁᏂᏃᏄᏅᏆᏇᏈᏉᏊᏋᏌᏍᏎᏏᏐᏑᏒᏓᏔᏕᏖᏗᏘᏙᏚᏛᏜᏝᏞᏟᏠᏡᏢᏣᏤᏥᏦᏧᏨᏩᏪᏫᏬᏭᏮᏯ豈更車賈滑串句龜龜契金喇奈懶癩羅蘿螺裸邏樂洛烙珞落酪駱亂卵欄爛蘭鸞嵐濫藍襤拉臘蠟廊朗浪狼郎來冷勞擄櫓爐盧老蘆虜路露魯鷺碌祿綠菉錄鹿論壟弄籠聾牢磊賂雷壘屢樓淚漏累縷陋勒肋凜凌稜綾菱陵讀拏樂諾丹寧怒率異北磻便復不泌數索參塞省葉說殺辰沈拾若掠略亮兩凉梁糧良諒量勵呂女廬旅濾礪閭驪麗黎力曆歷轢年憐戀撚漣煉璉秊練聯輦蓮連鍊列劣咽烈裂說廉念捻殮簾獵令囹寧嶺怜玲瑩羚聆鈴零靈領例禮醴隸惡了僚寮尿料樂燎療蓼遼龍暈阮劉杻柳流溜琉留硫紐類六戮陸倫崙淪輪律慄栗率隆利吏履易李梨泥理痢罹裏裡里離匿溺吝燐璘藺隣鱗麟林淋臨立笠粒狀炙識什茶刺切度拓糖宅洞暴輻行降見廓兀嗀塚晴凞猪益礼神祥福靖精羽蘒諸逸都飯飼館鶴郞隷侮僧免勉勤卑喝嘆器塀墨層屮悔慨憎懲敏既暑梅海渚漢煮爫琢碑社祉祈祐祖祝禍禎穀突節練縉繁署者臭艹艹著褐視謁謹賓贈辶逸難響頻恵𤋮舘並况全侀充冀勇勺喝啕喙嗢塚墳奄奔婢嬨廒廙彩徭惘慎愈憎慠懲戴揄搜摒敖晴朗望杖歹殺流滛滋漢瀞煮瞧爵犯猪瑱甆画瘝瘟益盛直睊着磌窱節类絛練缾者荒華蝹襁覆視調諸請謁諾諭謹變贈輸遲醙鉶陼難靖韛響頋頻鬒龜𢡊𢡄𣏕㮝䀘䀹𥉉𥳐𧻓齃龎עאדהכלםרתٱٱٻٻٻٻپپپپڀڀڀڀٺٺٺٺٿٿٿٿٹٹٹٹڤڤڤڤڦڦڦڦڄڄڄڄڃڃڃڃچچچچڇڇڇڇڍڍڌڌڎڎڈڈژژڑڑککککگگگگڳڳڳڳڱڱڱڱںںڻڻڻڻۀۀہہہہھھھھےےۓۓڭڭڭڭۇۇۆۆۈۈۋۋۅۅۉۉېېېېىىیییی\x{3001}\x{3016}\x{3017}\x{2014}\x{2013}\x{3014}\x{3015}\x{3010}\x{3011}\x{300A}\x{300B}\x{3008}\x{3009}\x{300C}\x{300D}\x{300E}\x{300F}\x{3001}\x{2014}\x{3014}\x{3015}\-ءآآأأؤؤإإئئئئااببببةةتتتتثثثثججججححححخخخخددذذررززسسسسششششصصصصضضضضططططظظظظععععغغغغففففققققككككللللممممننننههههووىىيييي\-\.0123456789abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz\x{2985}\x{2986}\.\x{300C}\x{300D}\x{3001}\x{30FB}ヲァィゥェォャュョッーアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤユヨラリルレロワン\x{3099}\x{309A}ᄀᄁᆪᄂᆬᆭᄃᄄᄅᆰᆱᆲᆳᆴᆵᄚᄆᄇᄈᄡᄉᄊᄋᄌᄍᄎᄏᄐᄑ하ᅢᅣᅤᅥᅦᅧᅨᅩᅪᅫᅬᅭᅮᅯᅰᅱᅲᅳᅴᅵ\x{00A2}\x{00A3}\x{00AC}\x{00A6}\x{00A5}\x{20A9}\x{2502}\x{2190}\x{2191}\x{2192}\x{2193}\x{25A0}\x{25CB}𐐨𐐩𐐪𐐫𐐬𐐭𐐮𐐯𐐰𐐱𐐲𐐳𐐴𐐵𐐶𐐷𐐸𐐹𐐺𐐻𐐼𐐽𐐾𐐿𐑀𐑁𐑂𐑃𐑄𐑅𐑆𐑇𐑈𐑉𐑊𐑋𐑌𐑍𐑎𐑏𐓘𐓙𐓚𐓛𐓜𐓝𐓞𐓟𐓠𐓡𐓢𐓣𐓤𐓥𐓦𐓧𐓨𐓩𐓪𐓫𐓬𐓭𐓮𐓯𐓰𐓱𐓲𐓳𐓴𐓵𐓶𐓷𐓸𐓹𐓺𐓻𐳀𐳁𐳂𐳃𐳄𐳅𐳆𐳇𐳈𐳉𐳊𐳋𐳌𐳍𐳎𐳏𐳐𐳑𐳒𐳓𐳔𐳕𐳖𐳗𐳘𐳙𐳚𐳛𐳜𐳝𐳞𐳟𐳠𐳡𐳢𐳣𐳤𐳥𐳦𐳧𐳨𐳩𐳪𐳫𐳬𐳭𐳮𐳯𐳰𐳱𐳲𑣀𑣁𑣂𑣃𑣄𑣅𑣆𑣇𑣈𑣉𑣊𑣋𑣌𑣍𑣎𑣏𑣐𑣑𑣒𑣓𑣔𑣕𑣖𑣗𑣘𑣙𑣚𑣛𑣜𑣝𑣞𑣟abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefgijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzacdgjknopqstuvwxyzabcdfhijklmnpqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabdefgjklmnopqstuvwxyabcdefghijklmnopqrstuvwxyzabdefgijklmostuvwxyabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzıȷαβγδεζηθικλμνξοπρθστυφχψω\x{2207}αβγδεζηθικλμνξοπρσστυφχψω\x{2202}εθκφρπαβγδεζηθικλμνξοπρθστυφχψω\x{2207}αβγδεζηθικλμνξοπρσστυφχψω\x{2202}εθκφρπαβγδεζηθικλμνξοπρθστυφχψω\x{2207}αβγδεζηθικλμνξοπρσστυφχψω\x{2202}εθκφρπαβγδεζηθικλμνξοπρθστυφχψω\x{2207}αβγδεζηθικλμνξοπρσστυφχψω\x{2202}εθκφρπαβγδεζηθικλμνξοπρθστυφχψω\x{2207}αβγδεζηθικλμνξοπρσστυφχψω\x{2202}εθκφρπϝϝ01234567890123456789012345678901234567890123456789𞤢𞤣𞤤𞤥𞤦𞤧𞤨𞤩𞤪𞤫𞤬𞤭𞤮𞤯𞤰𞤱𞤲𞤳𞤴𞤵𞤶𞤷𞤸𞤹𞤺𞤻𞤼𞤽𞤾𞤿𞥀𞥁𞥂𞥃ابجدوزحطيكلمنسعفصقرشتثخذضظغٮںڡٯبجهحيكلمنسعفصقشتثخضغجحيلنسعصقشخضغںٯبجهحطيكمنسعفصقشتثخضظغٮڡابجدهوزحطيلمنسعفصقرشتثخذضظغبجدوزحطيلمنسعفصقرشتثخذضظغcrabcdefghijklmnopqrstuvwxyzサ手字双デ二多解天交映無料前後再新初終生販声吹演投捕一三遊左中右指走打禁空合満有月申割営配得可丽丸乁𠄢你侮侻倂偺備僧像㒞𠘺免兔兤具𠔜㒹內再𠕋冗冤仌冬况𩇟凵刃㓟刻剆割剷㔕勇勉勤勺包匆北卉卑博即卽卿卿卿𠨬灰及叟𠭣叫叱吆咞吸呈周咢哶唐啓啣善善喙喫喳嗂圖嘆圗噑噴切壮城埴堍型堲報墬𡓤売壷夆多夢奢𡚨𡛪姬娛娧姘婦㛮嬈嬾嬾𡧈寃寘寧寳𡬘寿将尢㞁屠屮峀岍𡷤嵃𡷦嵮嵫嵼巡巢㠯巽帨帽幩㡢𢆃㡼庰庳庶廊𪎒廾𢌱𢌱舁弢弢㣇𣊸𦇚形彫㣣徚忍志忹悁㤺㤜悔𢛔惇慈慌慎慌慺憎憲憤憯懞懲懶成戛扝抱拔捐𢬌挽拼捨掃揤𢯱搢揅掩㨮摩摾撝摷㩬敏敬𣀊旣書晉㬙暑㬈㫤冒冕最暜肭䏙朗望朡杞杓𣏃㭉柺枅桒梅𣑭梎栟椔㮝楂榣槪檨𣚣櫛㰘次𣢧歔㱎歲殟殺殻𣪍𡴋𣫺汎𣲼沿泍汧洖派海流浩浸涅𣴞洴港湮㴳滋滇𣻑淹潮𣽞𣾎濆瀹瀞瀛㶖灊災灷炭𠔥煅𤉣熜爨爵牐𤘈犀犕𤜵𤠔獺王㺬玥㺸㺸瑇瑜瑱璅瓊㼛甤𤰶甾𤲒異𢆟瘐𤾡𤾸𥁄㿼䀈直𥃳𥃲𥄙𥄳眞真真睊䀹瞋䁆䂖𥐝硎碌磌䃣𥘦祖𥚚𥛅福秫䄯穀穊穏𥥼𥪧𥪧䈂𥮫篆築䈧𥲀糒䊠糨糣紀𥾆絣䌁緇縂繅䌴𦈨𦉇䍙𦋙罺𦌾羕翺者𦓚𦔣聠𦖨聰𣍟䏕育脃䐋脾媵𦞧𦞵𣎓𣎜舁舄辞䑫芑芋芝劳花芳芽苦𦬼若茝荣莭茣莽菧著荓菊菌菜𦰶𦵫𦳕䔫蓱蓳蔖𧏊蕤𦼬䕝䕡𦾱𧃒䕫虐虜虧虩蚩蚈蜎蛢蝹蜨蝫螆蟡蠁䗹衠衣𧙧裗裞䘵裺㒻𧢮𧥦䚾䛇誠諭變豕𧲨貫賁贛起𧼯𠠄跋趼跰𠣞軔輸𨗒𨗭邔郱鄑𨜮鄛鈸鋗鋘鉼鏹鐕𨯺開䦕閷𨵷䧦雃嶲霣𩅅𩈚䩮䩶韠𩐊䪲𩒖頋頋頩𩖶飢䬳餩馧駂駾䯎𩬰鬒鱀鳽䳎䳭鵧𪃎䳸𪄅𪈎𪊑麻䵖黹黾鼅鼏鼖鼻𪘀/; $l =~ s/([\x{00BC}\x{00BD}\x{00BE}İIJijĿŀʼnDŽDždžLJLjljNJNjnjDZDzdz\x{0344}ևٵٶٷٸक़ख़ग़ज़ड़ढ़फ़य़ড়ঢ়য়ਲ਼ਸ਼ਖ਼ਗ਼ਜ਼ਫ਼ଡ଼ଢ଼ำຳໜໝགྷཌྷདྷབྷཛྷཀྵཱཱིུྲྀཷླྀཹཱྀྒྷྜྷྡྷྦྷྫྷྐྵẚẞᾀᾁᾂᾃᾄᾅᾆᾇᾈᾉᾊᾋᾌᾍᾎᾏᾐᾑᾒᾓᾔᾕᾖᾗᾘᾙᾚᾛᾜᾝᾞᾟᾠᾡᾢᾣᾤᾥᾦᾧᾨᾩᾪᾫᾬᾭᾮᾯᾲᾳᾴᾷᾼῂῃῄῇῌῲῳῴῷῼ\x{2033}\x{2034}\x{2036}\x{2037}\x{2057}\x{20A8}\x{2103}\x{2109}\x{2116}\x{2120}\x{2121}\x{2122}\x{213B}\x{2150}\x{2151}\x{2152}\x{2153}\x{2154}\x{2155}\x{2156}\x{2157}\x{2158}\x{2159}\x{215A}\x{215B}\x{215C}\x{215D}\x{215E}\x{215F}ⅡⅢⅣⅥⅦⅧⅨⅪⅫⅱⅲⅳⅵⅶⅷⅸⅺⅻ\x{2189}\x{222C}\x{222D}\x{222F}\x{2230}\x{2469}\x{246A}\x{246B}\x{246C}\x{246D}\x{246E}\x{246F}\x{2470}\x{2471}\x{2472}\x{2473}\x{2A0C}\x{2ADC}ゟヿ\x{3250}\x{3251}\x{3252}\x{3253}\x{3254}\x{3255}\x{3256}\x{3257}\x{3258}\x{3259}\x{325A}\x{325B}\x{325C}\x{325D}\x{325E}\x{325F}\x{327C}\x{327D}\x{32B1}\x{32B2}\x{32B3}\x{32B4}\x{32B5}\x{32B6}\x{32B7}\x{32B8}\x{32B9}\x{32BA}\x{32BB}\x{32BC}\x{32BD}\x{32BE}\x{32BF}\x{32C0}\x{32C1}\x{32C2}\x{32C3}\x{32C4}\x{32C5}\x{32C6}\x{32C7}\x{32C8}\x{32C9}\x{32CA}\x{32CB}\x{32CC}\x{32CD}\x{32CE}\x{32CF}\x{3300}\x{3301}\x{3302}\x{3303}\x{3304}\x{3305}\x{3306}\x{3307}\x{3308}\x{3309}\x{330A}\x{330B}\x{330C}\x{330D}\x{330E}\x{330F}\x{3310}\x{3311}\x{3312}\x{3313}\x{3314}\x{3315}\x{3316}\x{3317}\x{3318}\x{3319}\x{331A}\x{331B}\x{331C}\x{331D}\x{331E}\x{331F}\x{3320}\x{3321}\x{3322}\x{3323}\x{3324}\x{3325}\x{3326}\x{3327}\x{3328}\x{3329}\x{332A}\x{332B}\x{332C}\x{332D}\x{332E}\x{332F}\x{3330}\x{3331}\x{3332}\x{3333}\x{3334}\x{3335}\x{3336}\x{3337}\x{3338}\x{3339}\x{333A}\x{333B}\x{333C}\x{333D}\x{333E}\x{333F}\x{3340}\x{3341}\x{3342}\x{3343}\x{3344}\x{3345}\x{3346}\x{3347}\x{3348}\x{3349}\x{334A}\x{334B}\x{334C}\x{334D}\x{334E}\x{334F}\x{3350}\x{3351}\x{3352}\x{3353}\x{3354}\x{3355}\x{3356}\x{3357}\x{3358}\x{3359}\x{335A}\x{335B}\x{335C}\x{335D}\x{335E}\x{335F}\x{3360}\x{3361}\x{3362}\x{3363}\x{3364}\x{3365}\x{3366}\x{3367}\x{3368}\x{3369}\x{336A}\x{336B}\x{336C}\x{336D}\x{336E}\x{336F}\x{3370}\x{3371}\x{3372}\x{3373}\x{3374}\x{3375}\x{3376}\x{3377}\x{3378}\x{3379}\x{337A}\x{337B}\x{337C}\x{337D}\x{337E}\x{337F}\x{3380}\x{3381}\x{3382}\x{3383}\x{3384}\x{3385}\x{3386}\x{3387}\x{3388}\x{3389}\x{338A}\x{338B}\x{338C}\x{338D}\x{338E}\x{338F}\x{3390}\x{3391}\x{3392}\x{3393}\x{3394}\x{3395}\x{3396}\x{3397}\x{3398}\x{3399}\x{339A}\x{339B}\x{339C}\x{339D}\x{339E}\x{339F}\x{33A0}\x{33A1}\x{33A2}\x{33A3}\x{33A4}\x{33A5}\x{33A6}\x{33A7}\x{33A8}\x{33A9}\x{33AA}\x{33AB}\x{33AC}\x{33AD}\x{33AE}\x{33AF}\x{33B0}\x{33B1}\x{33B2}\x{33B3}\x{33B4}\x{33B5}\x{33B6}\x{33B7}\x{33B8}\x{33B9}\x{33BA}\x{33BB}\x{33BC}\x{33BD}\x{33BE}\x{33BF}\x{33C0}\x{33C1}\x{33C3}\x{33C4}\x{33C5}\x{33C6}\x{33C8}\x{33C9}\x{33CA}\x{33CB}\x{33CC}\x{33CD}\x{33CE}\x{33CF}\x{33D0}\x{33D1}\x{33D2}\x{33D3}\x{33D4}\x{33D5}\x{33D6}\x{33D7}\x{33D9}\x{33DA}\x{33DB}\x{33DC}\x{33DD}\x{33DE}\x{33DF}\x{33E0}\x{33E1}\x{33E2}\x{33E3}\x{33E4}\x{33E5}\x{33E6}\x{33E7}\x{33E8}\x{33E9}\x{33EA}\x{33EB}\x{33EC}\x{33ED}\x{33EE}\x{33EF}\x{33F0}\x{33F1}\x{33F2}\x{33F3}\x{33F4}\x{33F5}\x{33F6}\x{33F7}\x{33F8}\x{33F9}\x{33FA}\x{33FB}\x{33FC}\x{33FD}\x{33FE}\x{33FF}fffiflffifflſtstﬓﬔﬕﬖﬗיִײַשׁשׂשּׁשּׂאַאָאּבּגּדּהּוּזּטּיּךּכּלּמּנּסּףּפּצּקּרּשּתּוֹבֿכֿפֿﭏﯝﯪﯫﯬﯭﯮﯯﯰﯱﯲﯳﯴﯵﯶﯷﯸﯹﯺﯻﰀﰁﰂﰃﰄﰅﰆﰇﰈﰉﰊﰋﰌﰍﰎﰏﰐﰑﰒﰓﰔﰕﰖﰗﰘﰙﰚﰛﰜﰝﰞﰟﰠﰡﰢﰣﰤﰥﰦﰧﰨﰩﰪﰫﰬﰭﰮﰯﰰﰱﰲﰳﰴﰵﰶﰷﰸﰹﰺﰻﰼﰽﰾﰿﱀﱁﱂﱃﱄﱅﱆﱇﱈﱉﱊﱋﱌﱍﱎﱏﱐﱑﱒﱓﱔﱕﱖﱗﱘﱙﱚﱛﱜﱝﱤﱥﱦﱧﱨﱩﱪﱫﱬﱭﱮﱯﱰﱱﱲﱳﱴﱵﱶﱷﱸﱹﱺﱻﱼﱽﱾﱿﲀﲁﲂﲃﲄﲅﲆﲇﲈﲉﲊﲋﲌﲍﲎﲏﲐﲑﲒﲓﲔﲕﲖﲗﲘﲙﲚﲛﲜﲝﲞﲟﲠﲡﲢﲣﲤﲥﲦﲧﲨﲩﲪﲫﲬﲭﲮﲯﲰﲱﲲﲳﲴﲵﲶﲷﲸﲹﲺﲻﲼﲽﲾﲿﳀﳁﳂﳃﳄﳅﳆﳇﳈﳉﳊﳋﳌﳍﳎﳏﳐﳑﳒﳓﳔﳕﳖﳗﳘﳙﳚﳛﳜﳝﳞﳟﳠﳡﳢﳣﳤﳥﳦﳧﳨﳩﳪﳫﳬﳭﳮﳯﳰﳱﳲﳳﳴﳵﳶﳷﳸﳹﳺﳻﳼﳽﳾﳿﴀﴁﴂﴃﴄﴅﴆﴇﴈﴉﴊﴋﴌﴍﴎﴏﴐﴑﴒﴓﴔﴕﴖﴗﴘﴙﴚﴛﴜﴝﴞﴟﴠﴡﴢﴣﴤﴥﴦﴧﴨﴩﴪﴫﴬﴭﴮﴯﴰﴱﴲﴳﴴﴵﴶﴷﴸﴹﴺﴻﴼﴽﵐﵑﵒﵓﵔﵕﵖﵗﵘﵙﵚﵛﵜﵝﵞﵟﵠﵡﵢﵣﵤﵥﵦﵧﵨﵩﵪﵫﵬﵭﵮﵯﵰﵱﵲﵳﵴﵵﵶﵷﵸﵹﵺﵻﵼﵽﵾﵿﶀﶁﶂﶃﶄﶅﶆﶇﶈﶉﶊﶋﶌﶍﶎﶏﶒﶓﶔﶕﶖﶗﶘﶙﶚﶛﶜﶝﶞﶟﶠﶡﶢﶣﶤﶥﶦﶧﶨﶩﶪﶫﶬﶭﶮﶯﶰﶱﶲﶳﶴﶵﶶﶷﶸﶹﶺﶻﶼﶽﶾﶿﷀﷁﷂﷃﷄﷅﷆﷇﷰﷱﷲﷳﷴﷵﷶﷷﷸﷹ\x{FDFC}ﹱﹷﹹﹻﹽﹿﻵﻶﻷﻸﻹﻺﻻﻼ\x{1D15E}\x{1D15F}\x{1D160}\x{1D161}\x{1D162}\x{1D163}\x{1D164}\x{1D1BB}\x{1D1BC}\x{1D1BD}\x{1D1BE}\x{1D1BF}\x{1D1C0}\x{1F12A}\x{1F12D}\x{1F12E}\x{1F14A}\x{1F14B}\x{1F14C}\x{1F14D}\x{1F14E}\x{1F14F}\x{1F16A}\x{1F16B}\x{1F190}\x{1F200}\x{1F201}\x{1F240}\x{1F241}\x{1F242}\x{1F243}\x{1F244}\x{1F245}\x{1F246}\x{1F247}\x{1F248}])/$MAPPED{ord($1)}/eg; return $l; }; __END__ =encoding utf8 =head1 NAME Net::IDN::UTS46::_Mapping - Tables from Unicode Technical Standard #46 (S) =head1 DESCRIPTION This module contains tables and private functions used by L. The interface may change without further notice. =head1 AUTHOR Claus FErber =head1 LICENSE Copyright 2011-2018 Claus FErber. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO IDN/Punycode/PP.pm000044400000011205152345050350007620 0ustar00package Net::IDN::Punycode::PP; use 5.008; use strict; use utf8; use warnings; use Carp; use Exporter; our $VERSION = "2.500"; our @ISA = qw(Exporter); our @EXPORT = (); our @EXPORT_OK = qw(encode_punycode decode_punycode); our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); use integer; use constant BASE => 36; use constant TMIN => 1; use constant TMAX => 26; use constant SKEW => 38; use constant DAMP => 700; use constant INITIAL_BIAS => 72; use constant INITIAL_N => 128; use constant UNICODE_MIN => 0; use constant UNICODE_MAX => 0x10FFFF; my $Delimiter = chr 0x2D; my $BasicRE = "\x00-\x7f"; my $PunyRE = "A-Za-z0-9"; sub _adapt { my($delta, $numpoints, $firsttime) = @_; $delta = int($firsttime ? $delta / DAMP : $delta / 2); $delta += int($delta / $numpoints); my $k = 0; while ($delta > int(((BASE - TMIN) * TMAX) / 2)) { $delta /= BASE - TMIN; $k += BASE; } return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW)); } sub decode_punycode { die("Usage: Net::IDN::Punycode::decode_punycode(input)") unless @_; no warnings 'utf8'; my $input = shift; my $n = INITIAL_N; my $i = 0; my $bias = INITIAL_BIAS; my @output; return undef unless defined $input; return '' unless length $input; if($input =~ s/(.*)$Delimiter//os) { my $base_chars = $1; croak("non-base character in input for decode_punycode") if $base_chars =~ m/[^$BasicRE]/os; push @output, split //, $base_chars; } my $code = $input; croak('invalid digit in input for decode_punycode') if $code =~ m/[^$PunyRE]/os; utf8::downgrade($input); ## handling failure of downgrade is more expensive than ## doing the above regexp w/ utf8 semantics while(length $code) { my $oldi = $i; my $w = 1; LOOP: for (my $k = BASE; 1; $k += BASE) { my $cp = substr($code, 0, 1, ''); croak("incomplete encoded code point in decode_punycode") if !defined $cp; my $digit = ord $cp; ## NB: this depends on the PunyRE catching invalid digit characters ## before they turn up here ## $digit = $digit < 0x40 ? $digit + (26-0x30) : ($digit & 0x1f) -1; $i += $digit * $w; my $t = $k - $bias; $t = $t < TMIN ? TMIN : $t > TMAX ? TMAX : $t; last LOOP if $digit < $t; $w *= (BASE - $t); } $bias = _adapt($i - $oldi, @output + 1, $oldi == 0); $n += $i / (@output + 1); $i = $i % (@output + 1); croak('invalid code point') if $n < UNICODE_MIN or $n > UNICODE_MAX; splice(@output, $i, 0, chr($n)); $i++; } return join '', @output; } sub encode_punycode { die("Usage: Net::IDN::Punycode::encode_punycode(input)") unless @_; no warnings 'utf8'; my $input = shift; my $input_length = length $input; ## my $output = join '', $input =~ m/([$BasicRE]+)/og; ## slower my $output = $input; $output =~ s/[^$BasicRE]+//ogs; my $h = my $bb = length $output; $output .= $Delimiter if $bb > 0; utf8::downgrade($output); ## no unnecessary use of utf8 semantics my @input = map ord, split //, $input; my @chars = sort { $a<=> $b } grep { $_ >= INITIAL_N } @input; my $n = INITIAL_N; my $delta = 0; my $bias = INITIAL_BIAS; foreach my $m (@chars) { next if $m < $n; $delta += ($m - $n) * ($h + 1); $n = $m; for(my $i = 0; $i < $input_length; $i++) { my $c = $input[$i]; $delta++ if $c < $n; if ($c == $n) { my $q = $delta; LOOP: for (my $k = BASE; 1; $k += BASE) { my $t = $k - $bias; $t = $t < TMIN ? TMIN : $t > TMAX ? TMAX : $t; last LOOP if $q < $t; my $o = $t + (($q - $t) % (BASE - $t)); $output .= chr $o + ($o < 26 ? 0x61 : 0x30-26); $q = int(($q - $t) / (BASE - $t)); } croak("input exceeds punycode limit") if $q > BASE; $output .= chr $q + ($q < 26 ? 0x61 : 0x30-26); $bias = _adapt($delta, $h + 1, $h == $bb); $delta = 0; $h++; } } $delta++; $n++; } return $output; } 1; __END__ =head1 NAME Net::IDN::Punycode::PP - pure-perl implementation of Net::IDN::Punycode =head1 DESCRIPTION See L. =head1 AUTHORS Tatsuhiko Miyagawa Emiyagawa@bulknews.netE (versions 0.01 to 0.02) Claus FErber ECFAERBER@cpan.orgE (from version 1.00) =head1 LICENSE Copyright 2002-2004 Tatsuhiko Miyagawa Emiyagawa@bulknews.netE Copyright 2007-2018 Claus FErber ECFAERBER@cpan.orgE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO S (L), L, L =cut IDN/Overview.pod000044400000010000152345050350007457 0ustar00=encoding utf8 =head1 NAME Net::IDN::Overwiew - Internationalized Domain Names for Applications (IDNA) =head1 DESCRIPTION The C modules provide a framework for the handling of Internationalized Domain Names for Applications (IDNA) in perl programmes. This document provides an overview of the available modules in order to allow you to choose the best module for the task at hand. =head2 AVAILABLE MODULES =head3 HIGH-LEVEL (USE THIS) =over =item L provides a high-level interface for converting domain names (and for convenience, email addresses). Use this module if you just want to convert domain names and don't care about how this is done internally. Currently, this module uses L. However, this might change in the future if another specification (e.g. a revision of IDNA2008) becomes more appropriate. The author aims for Net::IDN::Encode to always use the specification that will provide the "least surprising" results. =back =head3 STANDARD-SPECIFIC These modules implement different versions of the the IDNA specifications. Use one of these modules only if you require compatibility with a specific incarnation of IDNA. =over =item L implements the original IDNA specification, released in 2003 (IDNA2003), which is now obsolete. IDNA2003 is defined in RFC 3490 L and related documents. =begin comment =item L implements the current IDNA specification, released in early 2010 (IDNA2008 or IDNAbis). Please note that this module will not allow you to convert some domain names, such as C<√.com> or C, which were allowed in IDNA2003 but are disallowed in IDNA2008. IDNA2008 is defined in RFC 5890 L and related documents. =end comment =item L implements Unicode Technical Standard #46 (UTS #46 L), Unicode IDNA Compatibility Processing. This specification supports all domain names allowed under either IDNA2003 or IDNA2008. =back =head3 ENCODING =over =item L performs the actual conversion between the ASCII and Unicode form of strings. Punycode is defined in RFC 3492 L and related documents. Usually, it is not a good idea to use this module directly. If you convert domain labels (or other strings) without proper preparation, you may end up with an ASCII encoding that is not interoperable or poses security issues due to spoofing. Even if you think that your domain names are valid and in already-mapped format, you might be fooled by different Unicode normalization forms (for example, some environments might automatically convert your data to NFD, which breaks IDNA). =back =head3 DEPRECATED/COMPATIBILITY These modules are only maintained in order to not break applications that might rely on them =over =item L provides an L plugin for Punycode. As Punycode is not a general-purpose encoding, there are limited applications. =item L has an API depending on global variables. Don't use this module. =back =head2 DISTRIBUTIONS =over =item Net-IDN-Encode is the main distribution covering the most common cases for converting domain names between ASCII and Unicode. The author tries to keep the dependency chain as small as possible; currently this distribution only depends on perl 5.8.5 (including the core module L ). =item Net-IDN-IDNA2003 provides the L module. This is separate because it has an dependency on L (through L). =begin comment =item Net-IDN-IDNA2008 provides the L module. This is separate because it has an dependency on perl 5.10 or higher (through L). =end comment =item Encode-Punycode =item IDNA-Punycode are separate because they are of limited use to the average user/perl programmer. =back =head1 AUTHOR Claus FErber =cut IDN/Punycode.pm000044400000006233152345050350007306 0ustar00package Net::IDN::Punycode; use 5.006; use strict; use utf8; use warnings; use Exporter; our $VERSION = "2.500"; $VERSION = eval $VERSION; our @ISA = qw(Exporter); our @EXPORT = (); our @EXPORT_OK = (); our %EXPORT_TAGS = ( 'all' => [ qw(encode_punycode decode_punycode) ], ); Exporter::export_ok_tags(keys %EXPORT_TAGS); our $_NO_XS; eval { die if $_NO_XS; require XSLoader; XSLoader::load('Net::IDN::Punycode'); }; if (!defined(&encode_punycode)) { require Net::IDN::Punycode::PP; Net::IDN::Punycode::PP->import(qw(:all)); } 1; __END__ =head1 NAME Net::IDN::Punycode - A Bootstring encoding of Unicode for IDNA (S) =head1 SYNOPSIS use Net::IDN::Punycode qw(:all); $punycode = encode_punycode($unicode); $unicode = decode_punycode($punycode); =head1 DESCRIPTION This module implements the Punycode encoding, and only the Punycode encoding. This module does not implement any other steps required for converting internationalized domain names (IDNs) to and from ASCII. In particular, it does not do any string preparation as specified by I/I/I and does not add nor remove the ACE prefix (C). Thus, use L if you want to convert domain names. Punycode is an instance of a more general algorithm called Bootstring, which allows strings composed from a small set of "basic" code points to uniquely represent any string of code points drawn from a larger set. Punycode is Bootstring with particular parameter values appropriate for IDNA. =head1 WARNING You may be tempted to use this module directly and add/remove the ACE prefix (C) in your code for performance reasons. Usually, this is not a good idea. If you convert domain labels (or other strings) without proper preparation, you may end up with an ASCII encoding that is not interoperable or even poses security issues due to spoofing. Even if you think that your domain names are valid and already mapped to the correct form, this may not be true. For example, some environments might automatically convert your perfectly valid domain names to a different but equivalent Unicode normalization form (e.g., NFD instead of NFC), which already breaks IDNA. =head1 FUNCTIONS No functions are exported by default. You can use the tag C<:all> or import them individually. The following functions are available: =over =item encode_punycode($input) Encodes C<$input> with Punycode and returns the result. This function will throw an exception on invalid/unencodable input. =item decode_punycode($input) Decodes C<$input> with Punycode and returns the result. This function will throw an exception on invalid input. =back =head1 AUTHORS Tatsuhiko Miyagawa Emiyagawa@bulknews.netE (versions 0.01 to 0.02) Claus FErber ECFAERBER@cpan.orgE (versions 1.000 and higher) =head1 LICENSE Copyright 2002-2004 Tatsuhiko Miyagawa Emiyagawa@bulknews.netE Copyright 2007-2014 Claus FErber ECFAERBER@cpan.orgE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO S (L), L, L =cut IDN/UTS46.pm000044400000043252152345050350006347 0ustar00package Net::IDN::UTS46; require 5.008005; # Unicode BiDi classes use strict; use utf8; use warnings; use Carp; our $VERSION = "2.500"; $VERSION = eval $VERSION; our @ISA = ('Exporter'); our @EXPORT = (); our @EXPORT_OK = ('uts46_to_ascii', 'uts46_to_unicode'); our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); use Unicode::Normalize (); use Net::IDN::Punycode 1.1 (':all'); use Net::IDN::Encode 2.100 (':_var'); use Net::IDN::UTS46::_Mapping 5.002 ('/^(Is|Map).*/'); # UTS #46 is only defined from Unicode 5.2.0 sub uts46_to_unicode { my ($label, %param) = @_; croak "Transitional processing is not defined for ToUnicode" if $param{'TransitionalProcessing'}; splice @_, 1, 0, undef; goto &_process; } sub uts46_to_ascii { my ($label, %param) = @_; splice @_, 1, 0, sub { local $_ = shift; if(m/\P{ASCII}/) { eval { $_ = $IDNA_PREFIX . encode_punycode($_) }; croak "$@ [A3]" if $@; } return $_; }; goto &_process; } *to_unicode = \&uts46_to_unicode; *to_ascii = \&uts46_to_ascii; sub _process { my ($label, $to_ascii, %param) = @_; no warnings 'utf8'; croak "The following parameter is invalid: $_" foreach(grep { !m/^(?:TransitionalProcessing|UseSTD3ASCIIRules|AllowUnassigned)$/ } keys %param); $param{'TransitionalProcessing'} = 0 unless exists $param{'TransitionalProcessing'}; $param{'UseSTD3ASCIIRules'} = 1 unless exists $param{'UseSTD3ASCIIRules'}; $param{'AllowUnassigned'} = 0 unless exists $param{'AllowUnassigned'}; # 1. Map # - disallowed # if($param{'AllowUnassigned'}) { $label =~ m/(\p{Is_DisallowedAssigned})/ and croak sprintf('disallowed character U+%04X', ord($1)); } else { $label =~ m/(\p{IsDisallowed})/ and croak sprintf('disallowed character U+%04X', ord($1)); } if($param{'UseSTD3ASCIIRules'}) { $label =~ m/(\p{IsDisallowedSTD3Valid})/ and croak sprintf('disallowed_STD3_valid character U+%04X', ord($1)); $label =~ m/(\p{IsDisallowedSTD3Mapped})/ and croak sprintf('disallowed_STD3_mapped character U+%04X', ord($1)); }; # - ignored # $label = MapIgnored($label); ## $label = MapDisallowedSTD3Ignored($label) if(!$param{'UseSTD3ASCIIRules'}); # - mapped # $label = MapMapped($label); $label = MapDisallowedSTD3Mapped($label) if(!$param{'UseSTD3ASCIIRules'}); # - deviation $label = MapDeviation($label) if($param{'TransitionalProcessing'}); # 2. Normalize # $label = Unicode::Normalize::NFC($label); # 3. Break # my @ll = split /\./, $label, -1; ## IDNA test vectors: an empty label at the end (separating the root domain ## "", if present) must be preserved. It is not checked for ## the minumum length criteria and the dot separting it is ## not included in the maximum length of the domain. ## my $rooted = @ll && length($ll[$#ll]) < 1; pop @ll if $rooted; my $is_bidi = 0; # 4. Convert/Validate # foreach my $l (@ll) { if($l =~ m/^(?:(?i)$IDNA_PREFIX)(\p{ASCII}+)$/o) { eval { $l = decode_punycode($1); }; croak 'Invalid Punycode sequence [P4]' if $@; _validate_label($l, %param, 'TransitionalProcessing' => 0, ) unless $@; } else { _validate_label($l,%param,'_AssumeNFC' => 1); } $is_bidi = 1 if !$is_bidi && $l =~ m/[\p{Bc:R}\p{Bc:AL}\p{Bc:AN}]/; } foreach my $l (@ll) { _validate_bidi($l,%param) if $is_bidi; _validate_contextj($l,%param); if(defined $to_ascii) { $l = $to_ascii->($l, %param); } ## IDNA test vectors: labels have to be checked for the minimum length of 1 (but not for the ## maximum length of 63) even in to_unicode. ## croak "empty label [A4_2]" if length($l) < 1; croak "label too long [A4_2]" if length($l) > 63 and defined $to_ascii; } my $domain = join('.', @ll); ## IDNA test vectors: domains have to be checked for the minimum length of 1 (but not for the ## maximum length of 253 excluding a final dot) even in to_unicode. ## croak "empty domain name [A4_1]" if length($domain) < 1; croak "domain name too long [A4_1]" if length($domain) > 253 and defined $to_ascii; $domain .= '.' if $rooted; return $domain; } sub _validate_label { my($l,%param) = @_; no warnings 'utf8'; $l eq Unicode::Normalize::NFC($l) or croak "not in Unicode Normalization Form NFC [V1]" unless $param{'_AssumeNFC'}; $l =~ m/^..--/ and croak "contains U+002D HYPHEN-MINUS in both third and forth position [V2]"; $l =~ m/^-/ and croak "begins with U+002D HYPHEN-MINUS [V3]"; $l =~ m/-$/ and croak "ends with U+002D HYPHEN-MINUS [V3]"; $l =~ m/\./ and croak "contains U+0023 FULL STOP [V4]"; $l =~ m/^\p{IsMark}/ and croak "begins with General_Category=Mark [V5]"; unless($param{'AllowUnassigned'}) { $l =~m/(\p{Unassigned})/ and croak sprintf "contains unassigned character U+%04X [V6]", ord $1; } if($param{'UseSTD3ASCIIRules'}) { $l =~m/(\p{IsDisallowedSTD3Valid})/ and croak sprintf "contains disallowed_STD3_valid character U+%04X [V6]", ord $1; } if($param{'TransitionalProcessing'}) { $l =~ m/(\p{IsDeviation})/ and croak sprintf "contains deviation character U+%04X [V6]", ord $1; } $l =~ m/(\p{IsIgnored})/ and croak sprintf "contains ignored character U+%04X [V6]", ord $1; $l =~ m/(\p{IsMapped}|\p{IsDisallowedSTD3Mapped})/ and croak sprintf "contains mapped character U+%04X [V6]", ord $1; $l =~ m/(\p{IsDisallowed})/ and croak sprintf "contains disallowed character U+%04X [V6]", ord $1; return 1; } # For perl versions < 5.11, there is a bug where Bc:L does not match some # character blocks that are not fully included in the main UnicodeData.txt file: # # 3400;;Lo;0;L;;;;;N;;;;; # 4DB5;;Lo;0;L;;;;;N;;;;; # 4E00;;Lo;0;L;;;;;N;;;;; # 9FBB;;Lo;0;L;;;;;N;;;;; # AC00;;Lo;0;L;;;;;N;;;;; # D7A3;;Lo;0;L;;;;;N;;;;; # 20000;;Lo;0;L;;;;;N;;;;; # 2A6D6;;Lo;0;L;;;;;N;;;;; # my $_RE_BidiClass_L = $] >= 5.011 ? '\p{Bc:L}' : '\p{Bc:L}\x{3400}-\x{4DB5}\x{4E00}-\x{9FBB}\x{AC00}-\x{D7A3}\x{20000}-\x{2A6D6}'; sub _validate_bidi { my($l,%param) = @_; no warnings 'utf8'; return 1 unless length($l); if( $l =~ m/^[$_RE_BidiClass_L]/o ) { # LTR (left-to-right) $l =~ m/[^$_RE_BidiClass_L\p{Bc:EN}\p{Bc:ES}\p{Bc:CS}\p{Bc:ET}\p{Bc:BN}\p{Bc:ON}\p{Bc:NSM}]/o and croak 'contains characters with wrong bidi class for LTR [B5]'; $l =~ m/[$_RE_BidiClass_L\p{Bc:EN}][\p{Bc:NSM}\P{Assigned}]*$/o or croak 'ends with character of wrong bidi class for LTR [B6]'; return 1; } if( $l =~ m/^[\p{Bc:R}\p{Bc:AL}]/ ) { # RTL (right-to-left) $l =~ m/[^\p{Bc:R}\p{Bc:AL}\p{Bc:AN}\p{Bc:EN}\p{Bc:ES}\p{Bc:CS}\p{Bc:ET}\p{Bc:ON}\p{Bc:BN}\p{Bc:NSM}]/ and croak 'contains characters with wrong bidi class for RTL [B2]'; $l =~ m/[\p{Bc:R}\p{Bc:AL}\p{Bc:EN}\p{Bc:AN}][\p{Bc:NSM}\P{Assigned}]*$/ or croak 'ends with character of wrong bidi class for RTL [B3]'; $l =~ m/\p{Bc:EN}.*\p{Bc:AN}|\p{Bc:AN}.*\p{Bc:EN}/ and croak 'contains characters with both bidi class EN and AN [B4]'; return 1; } croak 'starts with character of wrong bidi class [B1]'; } # For perl versions < 5.11, some Unicode properties such as Ccc or Joining_Type # are not supported. Instead, we use a conrete list of characters; this is safe # because the Unicode version supported by theses perl versions will not be # updated. For newer perl versions, we use the Unicode property (which is # supported from 5.11), so we will always be up-to-date with the Unicode # version supported by our underlying perl. # my $_RE_Ccc_Virama = $] >= 5.011 ? qr/\p{Ccc:Virama}/ : qr/[\x{094D}\x{09CD}\x{0A4D}\x{0ACD}\x{0B4D}\x{0BCD}\x{0C4D}\x{0CCD}\x{0D4D}\x{0DCA}\x{0E3A}\x{0F84}\x{1039}\x{103A}\x{1714}\x{1734}\x{17D2}\x{1A60}\x{1B44}\x{1BAA}\x{1BF2}\x{1BF3}\x{2D7F}\x{A806}\x{A8C4}\x{A953}\x{A9C0}\x{ABED}\x{00010A3F}\x{00011046}\x{000110B9}]/; my $_RE_JoiningType_L = $] >= 5.011 ? qr/\p{Joining_Type:L}/ : qr/(?!)/; my $_RE_JoiningType_R = $] >= 5.011 ? qr/\p{Joining_Type:R}/ : qr/[\x{0622}-\x{0625}\x{0627}\x{0629}\x{062F}-\x{0632}\x{0648}\x{0671}-\x{0673}\x{0675}-\x{0677}\x{0688}-\x{0699}\x{06C0}\x{06C3}-\x{06CB}\x{06CD}\x{06CF}\x{06D2}\x{06D3}\x{06D5}\x{06EE}\x{06EF}\x{0710}\x{0715}-\x{0719}\x{071E}\x{0728}\x{072A}\x{072C}\x{072F}\x{074D}\x{0759}-\x{075B}\x{076B}\x{076C}\x{0771}\x{0773}\x{0774}\x{0778}\x{0779}]/; my $_RE_JoiningType_D = $] >= 5.011 ? qr/\p{Joining_Type:D}/ : qr/[\x{0620}\x{0626}\x{0628}\x{062A}-\x{062E}\x{0633}-\x{063F}\x{0641}-\x{0647}\x{0649}\x{064A}\x{066E}\x{066F}\x{0678}-\x{0687}\x{069A}-\x{06BF}\x{06C1}\x{06C2}\x{06CC}\x{06CE}\x{06D0}\x{06D1}\x{06FA}-\x{06FC}\x{06FF}\x{0712}-\x{0714}\x{071A}-\x{071D}\x{071F}-\x{0727}\x{0729}\x{072B}\x{072D}\x{072E}\x{074E}-\x{0758}\x{075C}-\x{076A}\x{076D}-\x{0770}\x{0772}\x{0775}-\x{0777}\x{077A}-\x{077F}\x{07CA}-\x{07EA}]/; my $_RE_JoiningType_T = $] >= 5.011 ? qr/\p{Joining_Type:T}/ : qr/[\x{00AD}\x{0300}-\x{036F}\x{0483}-\x{0489}\x{0591}-\x{05BD}\x{05BF}\x{05C1}\x{05C2}\x{05C4}\x{05C5}\x{05C7}\x{0610}-\x{061A}\x{064B}-\x{065F}\x{0670}\x{06D6}-\x{06DC}\x{06DF}-\x{06E4}\x{06E7}\x{06E8}\x{06EA}-\x{06ED}\x{070F}\x{0711}\x{0730}-\x{074A}\x{07A6}-\x{07B0}\x{07EB}-\x{07F3}\x{0816}-\x{0819}\x{081B}-\x{0823}\x{0825}-\x{0827}\x{0829}-\x{082D}\x{0859}-\x{085B}\x{0900}-\x{0902}\x{093A}\x{093C}\x{0941}-\x{0948}\x{094D}\x{0951}-\x{0957}\x{0962}\x{0963}\x{0981}\x{09BC}\x{09C1}-\x{09C4}\x{09CD}\x{09E2}\x{09E3}\x{0A01}\x{0A02}\x{0A3C}\x{0A41}\x{0A42}\x{0A47}\x{0A48}\x{0A4B}-\x{0A4D}\x{0A51}\x{0A70}\x{0A71}\x{0A75}\x{0A81}\x{0A82}\x{0ABC}\x{0AC1}-\x{0AC5}\x{0AC7}\x{0AC8}\x{0ACD}\x{0AE2}\x{0AE3}\x{0B01}\x{0B3C}\x{0B3F}\x{0B41}-\x{0B44}\x{0B4D}\x{0B56}\x{0B62}\x{0B63}\x{0B82}\x{0BC0}\x{0BCD}\x{0C3E}-\x{0C40}\x{0C46}-\x{0C48}\x{0C4A}-\x{0C4D}\x{0C55}\x{0C56}\x{0C62}\x{0C63}\x{0CBC}\x{0CBF}\x{0CC6}\x{0CCC}\x{0CCD}\x{0CE2}\x{0CE3}\x{0D41}-\x{0D44}\x{0D4D}\x{0D62}\x{0D63}\x{0DCA}\x{0DD2}-\x{0DD4}\x{0DD6}\x{0E31}\x{0E34}-\x{0E3A}\x{0E47}-\x{0E4E}\x{0EB1}\x{0EB4}-\x{0EB9}\x{0EBB}\x{0EBC}\x{0EC8}-\x{0ECD}\x{0F18}\x{0F19}\x{0F35}\x{0F37}\x{0F39}\x{0F71}-\x{0F7E}\x{0F80}-\x{0F84}\x{0F86}\x{0F87}\x{0F8D}-\x{0F97}\x{0F99}-\x{0FBC}\x{0FC6}\x{102D}-\x{1030}\x{1032}-\x{1037}\x{1039}\x{103A}\x{103D}\x{103E}\x{1058}\x{1059}\x{105E}-\x{1060}\x{1071}-\x{1074}\x{1082}\x{1085}\x{1086}\x{108D}\x{109D}\x{135D}-\x{135F}\x{1712}-\x{1714}\x{1732}-\x{1734}\x{1752}\x{1753}\x{1772}\x{1773}\x{17B4}\x{17B5}\x{17B7}-\x{17BD}\x{17C6}\x{17C9}-\x{17D3}\x{17DD}\x{180B}-\x{180D}\x{18A9}\x{1920}-\x{1922}\x{1927}\x{1928}\x{1932}\x{1939}-\x{193B}\x{1A17}\x{1A18}\x{1A56}\x{1A58}-\x{1A5E}\x{1A60}\x{1A62}\x{1A65}-\x{1A6C}\x{1A73}-\x{1A7C}\x{1A7F}\x{1B00}-\x{1B03}\x{1B34}\x{1B36}-\x{1B3A}\x{1B3C}\x{1B42}\x{1B6B}-\x{1B73}\x{1B80}\x{1B81}\x{1BA2}-\x{1BA5}\x{1BA8}\x{1BA9}\x{1BE6}\x{1BE8}\x{1BE9}\x{1BED}\x{1BEF}-\x{1BF1}\x{1C2C}-\x{1C33}\x{1C36}\x{1C37}\x{1CD0}-\x{1CD2}\x{1CD4}-\x{1CE0}\x{1CE2}-\x{1CE8}\x{1CED}\x{1DC0}-\x{1DE6}\x{1DFC}-\x{1DFF}\x{200B}\x{200E}\x{200F}\x{202A}-\x{202E}\x{2060}-\x{2064}\x{206A}-\x{206F}\x{20D0}-\x{20F0}\x{2CEF}-\x{2CF1}\x{2D7F}\x{2DE0}-\x{2DFF}\x{302A}-\x{302F}\x{3099}\x{309A}\x{A66F}-\x{A672}\x{A67C}\x{A67D}\x{A6F0}\x{A6F1}\x{A802}\x{A806}\x{A80B}\x{A825}\x{A826}\x{A8C4}\x{A8E0}-\x{A8F1}\x{A926}-\x{A92D}\x{A947}-\x{A951}\x{A980}-\x{A982}\x{A9B3}\x{A9B6}-\x{A9B9}\x{A9BC}\x{AA29}-\x{AA2E}\x{AA31}\x{AA32}\x{AA35}\x{AA36}\x{AA43}\x{AA4C}\x{AAB0}\x{AAB2}-\x{AAB4}\x{AAB7}\x{AAB8}\x{AABE}\x{AABF}\x{AAC1}\x{ABE5}\x{ABE8}\x{ABED}\x{FB1E}\x{FE00}-\x{FE0F}\x{FE20}-\x{FE26}\x{FEFF}\x{FFF9}-\x{FFFB}\x{101FD}\x{10A01}-\x{10A03}\x{10A05}\x{10A06}\x{10A0C}-\x{10A0F}\x{10A38}-\x{10A3A}\x{10A3F}\x{11001}\x{11038}-\x{11046}\x{11080}\x{11081}\x{110B3}-\x{110B6}\x{110B9}\x{110BA}\x{110BD}\x{1D167}-\x{1D169}\x{1D173}-\x{1D182}\x{1D185}-\x{1D18B}\x{1D1AA}-\x{1D1AD}\x{1D242}-\x{1D244}\x{E0001}\x{E0020}-\x{E007F}\x{E0100}-\x{E01EF}]/; sub _validate_contextj { my($l,%param) = @_; no warnings 'utf8'; return 1 unless defined($l) && length($l); # catch ContextJ characters without defined rule (as of Unicode 6.0.0, this cannot match) # $l =~ m/([^\x{200C}\x{200D}\P{Join_Control}])/ and croak sprintf "contains CONTEXTJ character U+%04X without defined rule [C1]", ord($1); # RFC 5892, Appendix A.1. ZERO WIDTH NON-JOINER # Code point: # U+200C # # Overview: # This may occur in a formally cursive script (such as Arabic) in a # context where it breaks a cursive connection as required for # orthographic rules, as in the Persian language, for example. It # also may occur in Indic scripts in a consonant-conjunct context # (immediately following a virama), to control required display of # such conjuncts. # # # Lookup: # True # # Rule Set: # False; # If Canonical_Combining_Class(Before(cp)) .eq. Virama Then True; # If RegExpMatch((Joining_Type:{L,D})(Joining_Type:T)*\u200C # (Joining_Type:T)*(Joining_Type:{R,D})) Then True; $l =~ m/ $_RE_Ccc_Virama \x{200C} | (?: $_RE_JoiningType_L | $_RE_JoiningType_D) $_RE_JoiningType_T* \x{200C} $_RE_JoiningType_T*(?: $_RE_JoiningType_R | $_RE_JoiningType_D) | (\x{200C}) /xo and defined($1) and croak sprintf "rule for CONTEXTJ character U+%04X not satisfied [C2]", ord($1); # RFC 5892, Appendix A.2. ZERO WIDTH JOINER # # Code point: # U+200D # # Overview: # This may occur in Indic scripts in a consonant-conjunct context # (immediately following a virama), to control required display of # such conjuncts. # # Lookup: # True # Rule Set: # False; # If Canonical_Combining_Class(Before(cp)) .eq. Virama Then True; $l =~ m/ $_RE_Ccc_Virama \x{200D} | (\x{200D}) /xo and defined($1) and croak sprintf "rule for CONTEXTJ character U+%04X not satisfied [C2]", ord($1); } 1; __END__ =encoding utf8 =head1 NAME Net::IDN::UTS46 - Unicode IDNA Compatibility Processing (S) =head1 SYNOPSIS use Net::IDN:: ':all'; my $a = uts46_to_ascii("müller.example.org"); my $b = Net::IDN::UTS46::to_unicode('EXAMPLE.XN--11B5BS3A9AJ6G'); $domain =~ m/\P{Net::IDN::UTS46::IsDisallowed} and die 'oops'; =head1 DESCRIPTION This module implements the Unicode Technical Standard #46 (Unicode IDNA Compatibility Processing). UTS #46 is one variant of Internationalized Domain Names (IDN), which aims to be compatible with domain names registered under either IDNA2003 or IDNA2008. You should use this module if you want an exact implementation of the UTS #46 specification. However, if you just want to convert domain names and don't care which standard is used internally, you should use L instead. =head1 FUNCTIONS By default, this module does not export any subroutines. You may use the C<:all> tag to import everything. You can omit the C<'uts46_'> prefix when accessing the functions with a full-qualified module name (e.g. you can access C as C or C. The following functions are available: =over =item uts46_to_ascii( $domain, %param ) Implements the "ToASCII" function from UTS #46, section 4.2. It converts a domain name to ASCII and throws an exception on invalid input. This function takes the following optional parameters (C<%param>): =over =item AllowUnassigned (boolean) If set to a true value, unassigned code points in the label are allowed. This is an extension over UTS #46. The default is false. =item UseSTD3ASCIIRules (boolean) If set to a true value, checks the label for compliance with S (S) syntax for host name parts. The default is true. =item TransitionalProcessing (boolean) If set to true, the conversion will be compatible with IDNA2003. This only affects four characters: C<'ß'> (U+00DF), 'ς' (U+03C2), ZWJ (U+200D) and ZWNJ (U+200C). Usually, you will want to set this to false. The default is false. =back =item uts46_to_unicode( $label, %param ) Implements the "ToUnicode" function from UTS #46, section 4.3. It converts a domain name to Unicode and throws an exception on invalid input. This function takes the following optional parameters (C<%param>): =over =item AllowUnassigned see above. =item UseSTD3ASCIIRules see above. =item TransitionalProcessing (boolean) If given, this parameter must be false. The UTS #46 specification does not define transitional processing for ToUnicode. =back =back =head1 UNICODE CHARACTER PROPERTIES This module also defines the character properties listed below. Each character has exactly one of the following properties: =over =item C<\p{Net::IDN::UTS46::IsValid}> The code point is valid, and not modified (i.e. a deviation character) in UTS #46. =item C<\p{Net::IDN::UTS46::IsIgnored}> The code point is removed (i.e. mapped to an empty string) in UTS #46. =item C<\p{Net::IDN::UTS46::IsMapped}> The code point is replaced by another string in UTS #46. =item C<\p{Net::IDN::UTS46::IsDeviation}> The code point is either mapped or valid, depending on whether the processing is transitional or not. =item C<\p{Net::IDN::UTS46::IsDisallowed}> The code point is not allowed in UTS #46. =item C<\p{Net::IDN::UTS46::IsDisallowedSTD3Ignored}> The code point is not allowed in UTS #46 if C are used but would be ignored otherwise. =item C<\p{Net::IDN::UTS46::IsDisallowedSTD3Mapped}> The code point is not allowed in UTS #46 if C are used but would be mapped otherwise. =back =head1 AUTHOR Claus FErber =head1 LICENSE Copyright 2011-2018 Claus FErber. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, S (L) IDN/Encode.pm000055500000024446152345050350006726 0ustar00package Net::IDN::Encode; require 5.006; use strict; use utf8; use warnings; our $VERSION = "2.500"; $VERSION = eval $VERSION; use Carp; use Exporter; our @ISA = ('Exporter'); our @EXPORT = (); our %EXPORT_TAGS = ( 'all' => [ 'to_ascii', 'to_unicode', 'domain_to_ascii', 'domain_to_unicode', 'email_to_ascii', 'email_to_unicode', ], '_var' => [ '$IDNA_PREFIX', 'IsIDNADot', 'IsIDNAAtsign', ] ); Exporter::export_ok_tags(keys %EXPORT_TAGS); use Net::IDN::Punycode 1.102 (); our $IDNA_PREFIX = 'xn--'; sub IsIDNADot { "002E\n3002\nFF0E\nFF61" } sub IsIDNAAtsign{ "0040\nFE6B\nFF20" } require Net::IDN::UTS46; # after declaration of vars! sub to_ascii { my($label,%param) = @_; croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o; if($label =~ m/\P{ASCII}/o) { $label = Net::IDN::UTS46::to_ascii(@_); } else { croak 'label empty' if length($label) < 1; croak 'label too long' if length($label) > 63; } return $label; } sub to_unicode { my($label,%param) = @_; croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o; if($label =~ m/\P{ASCII}|^(?:(?i)$IDNA_PREFIX)/o) { $label = Net::IDN::UTS46::to_unicode(@_); } return $label; } sub _domain { my ($domain,$to_function,$ascii,%param) = @_; $param{'UseSTD3ASCIIRules'} = 1 unless exists $param{'UseSTD3ASCIIRules'}; my $even_odd = 1; return join '', map { $even_odd++ % 2 ? $to_function->($_, %param) : $ascii ? '.' : $_ } split /(\p{IsIDNADot})/o, $domain; } sub _email { my ($email,$to_function,$ascii,%param) = @_; return $email if !defined($email) || $email eq ''; $email =~ m/^( (?(?!\p{IsIDNAAtsign}|").|(?!))+ | "(?:(?:[^"]|\\.)*[^\\])?" ) (?: (\p{IsIDNAAtsign}) (?:([^\[\]]*)|(\[.*\]))? )?$/xo || croak "Invalid email address"; my($local_part,$at,$domain,$domain_literal) = ($1,$2,$3); $local_part =~ m/\P{ASCII}/ && croak "Non-ASCII characters in local-part"; $domain_literal =~ m/\P{ASCII}/ && croak "Non-ASCII characters in domain-literal" if $domain_literal; $domain = $to_function->($domain,%param) if $domain; $at = '@' if $ascii; return ($domain || $domain_literal) ? ($local_part.$at.($domain || $domain_literal)) : ($local_part); } sub domain_to_ascii { _domain(shift, \&to_ascii, 1, @_) } sub domain_to_unicode { _domain(shift, \&to_unicode, 0, @_) } sub email_to_ascii { _email(shift, \&domain_to_ascii, 1, @_) } sub email_to_unicode { _email(shift, \&domain_to_unicode, 0, @_) } 1; __END__ =encoding utf8 =head1 NAME Net::IDN::Encode - Internationalizing Domain Names in Applications (IDNA) =head1 SYNOPSIS use Net::IDN::Encode ':all'; my $a = domain_to_ascii("müller.example.org"); my $e = email_to_ascii("POSTMASTER@例。テスト"); my $u = domain_to_unicode('EXAMPLE.XN--11B5BS3A9AJ6G'); =head1 DESCRIPTION This module provides an easy-to-use interface for encoding and decoding Internationalized Domain Names (IDNs). IDNs use characters drawn from a large repertoire (Unicode), but IDNA allows the non-ASCII characters to be represented using only the ASCII characters already allowed in so-called host names today (letter-digit-hyphen, C). Use this module if you just want to convert domain names (or email addresses), using whatever IDNA standard is the best choice at the moment. You should be familiar with Unicode support in perl, as this module expects correctly encoded input. See L, L and L for details. =head1 UNICODE VERSION To convert labels correctly between Unicode and ASCII, each character in the label must be present in the Unicode version supported by your perl. Consequently, this module will refuse to convert labels with new Unicode characters on older perl versions (see below). =head1 FUNCTIONS By default, this module does not export any subroutines. You may use the C<:all> tag to import everything. You can also use regular expressions such as C or C to select some of the functions, see L for details. The following functions are available: =over =item to_ascii( $label, %param ) Converts a single label C<$label> to ASCII. Will throw an exception on invalid input. If C<$label> is already a valid ASCII domain label (including most NON-LDH labels such as those used for SRV records and fake A-labels), this function will never fail but return C<$label> as-is if conversion would fail. This function takes the following optional parameters (C<%param>): =over =item AllowUnassigned (boolean) If set to a true value, code points that are unassigned in the Unicode version supported by your perl are allowed. This is an extension over UTS #46. While this increases the number of labels that can be converted successfully (especially on older perls) and may thus maximizes the compatibility with domain names created under future versions of Unicode, it also introduces the risk of incorrect conversions. Characters added in later versions of Unicode might have properties that affect the conversion; if these properties are not known on your version of perl, you might therefore end up with an incorrect conversion. The default is false. =item UseSTD3ASCIIRules (boolean) If set to a true value, checks the label for compliance with S (S) syntax for host name parts. The exact checks done depend on the IDNA standard used. Usually, you will want to set this to true. Please note that UseSTD3ASCIIRules only affects the conversion between ASCII labels (A-labels) and Unicode labels (U-labels). Labels that are in ASCII may still be passed-through as-is. For historical reasons, the default is false (unlike C). =item TransitionalProcessing (boolean) If set to true, the conversion will be compatible with IDNA2003. This only affects four characters: C<'ß'> (U+00DF), 'ς' (U+03C2), ZWJ (U+200D) and ZWNJ (U+200C). Usually, you will want to set this to false. The default is false. =back This function does not handle strings that consist of multiple labels (such as domain names). Use C instead. =item to_unicode( $label, %param ) Converts a single label C<$label> to Unicode. Will throw an exception on invalid input. If C<$label> is an ASCII label (including most NON-LDH labels such as those used for SRV records), this function will not fail but return C<$label> as-is if conversion would fail. This function takes the same optional parameters as C, with the same defaults. If C<$label> is already in ASCII, this function will never fail but return C<$label> as is as a last resort (i.e. pass-through). This function takes the following optional parameters (C<%param>): =over =item AllowUnassigned =item UseSTD3ASCIIRules See C above. Please note that there is no need for C for C. =back This function does not handle strings that consist of multiple labels (such as domain names). Use C instead. =item domain_to_ascii( $label, %param ) Converts all labels of the hostname C<$domain> (with labels separated by dots) to ASCII (using C). Will throw an exception on invalid input. This function takes the following optional parameters (C<%param>): =over =item AllowUnassigned =item TransitionalProcessing See C above. =item UseSTD3ASCIIRules (boolean) If set to a true value, checks the label for compliance with S (S) syntax for host name parts. The default is true (unlike C). =back This function will convert all dots to ASCII, i.e. to U+002E (full stop). The following characters are recognized as dots: U+002E (full stop), U+3002 (ideographic full stop), U+FF0E (fullwidth full stop), U+FF61 (halfwidth ideographic full stop). =item domain_to_unicode( $domain, %param ) Converts all labels of the hostname C<$domain> (with labels separated by dots) to Unicode. Will throw an exception on invalid input. This function takes the same optional parameters as C, with the same defaults. This function takes the following optional parameters (C<%param>): =over =item AllowUnassigned =item UseSTD3ASCIIRules See C above. Please note that there is no C for C. =back This function will preserve the original version of dots. The following characters are recognized as dots: U+002E (full stop), U+3002 (ideographic full stop), U+FF0E (fullwidth full stop), U+FF61 (halfwidth ideographic full stop). =item email_to_ascii( $email, %param ) Converts the domain part (right hand side, separated by an at sign) of an S/2822 email address to ASCII, using C. May throw an exception on invalid input. It takes the same parameters as C. This function currently does not handle internationalization of the local-part (left hand side). Future versions of this module might implement an ASCII conversion for the local-part, should one be standardized. This function will convert the at sign to ASCII, i.e. to U+0040 (commercial at), as well as label separators. The following characters are recognized as at signs: U+0040 (commercial at), U+FE6B (small commercial at) and U+FF20 (fullwidth commercial at). =item email_to_unicode( $email, %param ) Converts the domain part (right hand side, separated by an at sign) of an S/2822 email address to Unicode, using C. May throw an exception on invalid input. It takes the same parameters as C. This function currently does not handle internationalization of the local-part (left hand side). Future versions of this module might implement a conversion from ASCII for the local-part, should one be standardized. This function will preserve the original version of at signs (and label separators). The following characters are recognized as at signs: U+0040 (commercial at), U+FE6B (small commercial at) and U+FF20 (fullwidth commercial at). =back =head1 AUTHOR Claus FErber =head1 LICENSE Copyright 2007-2014 Claus FErber. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =head1 SEE ALSO L, L, L, L, S (L), S (L). =cut DNS.pm000044400000037241152345050350005535 0ustar00package Net::DNS; use strict; use warnings; our $VERSION; $VERSION = '1.50'; $VERSION = eval {$VERSION}; our $SVNVERSION = (qw$Id: DNS.pm 2015 2025-02-21 08:37:21Z willem $)[2]; =head1 NAME Net::DNS - Perl Interface to the Domain Name System =head1 SYNOPSIS use Net::DNS; my $resolver = Net::DNS::Resolver->new(...); my $response = $resolver->send(...); =head1 DESCRIPTION Net::DNS is a collection of Perl modules that act as a Domain Name System (DNS) resolver. It allows the programmer to perform DNS queries that are beyond the capabilities of "gethostbyname" and "gethostbyaddr". The programmer should be familiar with the structure of a DNS packet and the zone file presentation format described in RFC1035. =cut use integer; use base qw(Exporter); our @EXPORT = qw(SEQUENTIAL UNIXTIME YYYYMMDDxx yxrrset nxrrset yxdomain nxdomain rr_add rr_del mx rr rrsort); local $SIG{__DIE__}; require Net::DNS::Resolver; require Net::DNS::Packet; require Net::DNS::RR; require Net::DNS::Update; sub version { return $VERSION; } # # rr() # # Usage: # @rr = rr('example.com'); # @rr = rr('example.com', 'A', 'IN'); # @rr = rr($res, 'example.com' ... ); # sub rr { my @arg = @_; my $res = ( ref( $arg[0] ) ? shift @arg : Net::DNS::Resolver->new() ); my $reply = $res->query(@arg); my @list = $reply ? $reply->answer : (); return @list; } # # mx() # # Usage: # @mx = mx('example.com'); # @mx = mx($res, 'example.com'); # sub mx { my @arg = @_; my @res = ( ref( $arg[0] ) ? shift @arg : () ); my ( $name, @class ) = @arg; # This construct is best read backwards. # # First we take the answer section of the packet. # Then we take just the MX records from that list # Then we sort the list by preference # We do this into an array to force list context. # Then we return the list. my @list = sort { $a->preference <=> $b->preference } grep { $_->type eq 'MX' } &rr( @res, $name, 'MX', @class ); return @list; } # # rrsort() # # Usage: # @prioritysorted = rrsort( "SRV", "priority", @rr_array ); # sub rrsort { my @arg = @_; my $rrtype = uc shift @arg; my ( $attribute, @rr ) = @arg; ## NB: attribute is optional ( @rr, $attribute ) = @arg if ref($attribute) =~ /^Net::DNS::RR/; my @extracted = grep { $_->type eq $rrtype } @rr; return @extracted unless scalar @extracted; my $func = "Net::DNS::RR::$rrtype"->get_rrsort_func($attribute); my @sorted = sort $func @extracted; return @sorted; } # # Auxiliary functions to support policy-driven zone serial numbering. # # $successor = $soa->serial(SEQUENTIAL); # $successor = $soa->serial(UNIXTIME); # $successor = $soa->serial(YYYYMMDDxx); # sub SEQUENTIAL { return (undef) } sub UNIXTIME { return CORE::time; } sub YYYYMMDDxx { my ( $dd, $mm, $yy ) = (localtime)[3 .. 5]; return 1900010000 + sprintf '%d%0.2d%0.2d00', $yy, $mm, $dd; } # # Auxiliary functions to support dynamic update. # sub yxrrset { my @arg = @_; my $rr = Net::DNS::RR->new(@arg); $rr->ttl(0); $rr->class('ANY') unless $rr->rdata; return $rr; } sub nxrrset { my @arg = @_; my $rr = Net::DNS::RR->new(@arg); return Net::DNS::RR->new( name => $rr->name, type => $rr->type, class => 'NONE' ); } sub yxdomain { my @arg = @_; my ( $domain, @etc ) = map {split} @arg; my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain ) ); return Net::DNS::RR->new( name => $rr->name, type => 'ANY', class => 'ANY' ); } sub nxdomain { my @arg = @_; my ( $domain, @etc ) = map {split} @arg; my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain ) ); return Net::DNS::RR->new( name => $rr->name, type => 'ANY', class => 'NONE' ); } sub rr_add { my @arg = @_; my $rr = Net::DNS::RR->new(@arg); $rr->{ttl} = 86400 unless defined $rr->{ttl}; return $rr; } sub rr_del { my @arg = @_; my ( $domain, @etc ) = map {split} @arg; my $rr = Net::DNS::RR->new( scalar(@etc) ? @arg : ( name => $domain, type => 'ANY' ) ); $rr->class( $rr->rdata ? 'NONE' : 'ANY' ); $rr->ttl(0); return $rr; } 1; __END__ =head2 Resolver Objects A resolver object is an instance of the L class. A program may have multiple resolver objects, each maintaining its own state information such as the nameservers to be queried, whether recursion is desired, etc. =head2 Packet Objects L queries return L objects. A packet object has five sections: =over 3 =item * header, represented by a L object =item * question, a list of no more than one L object =item * answer, a list of L objects =item * authority, a list of L objects =item * additional, a list of L objects =back =head2 Update Objects L is a subclass of L useful for creating dynamic update requests. =head2 Header Object The L object mediates access to the header data which resides within the corresponding L. =head2 Question Object The L object represents the content of the question section of the DNS packet. =head2 RR Objects L is the base class for DNS resource record (RR) objects in the answer, authority, and additional sections of a DNS packet. Do not assume that RR objects will be of the type requested. The type of an RR object must be checked before calling any methods. =head1 METHODS Net::DNS exports methods and auxiliary functions to support DNS updates, zone serial number management, and simple DNS queries. =head2 version use Net::DNS; print Net::DNS->version, "\n"; Returns the version of Net::DNS. =head2 rr # Use a default resolver -- can not get an error string this way. use Net::DNS; my @rr = rr("example.com"); my @rr = rr("example.com", "AAAA"); my @rr = rr("example.com", "AAAA", "IN"); # Use your own resolver object. my $res = Net::DNS::Resolver->new; my @rr = rr($res, "example.com" ... ); my ($ptr) = rr("2001:DB8::dead:beef"); The C method provides simple RR lookup for scenarios where the full flexibility of Net::DNS is not required. Returns a list of L objects for the specified name or an empty list if the query failed or no record was found. See L for more complete examples. =head2 mx # Use a default resolver -- can not get an error string this way. use Net::DNS; my @mx = mx("example.com"); # Use your own resolver object. my $res = Net::DNS::Resolver->new; my @mx = mx($res, "example.com"); Returns a list of L objects representing the MX records for the specified name. The list will be sorted by preference. Returns an empty list if the query failed or no MX record was found. This method does not look up address records; it resolves MX only. =head1 Dynamic DNS Update Support The Net::DNS module provides auxiliary functions which support dynamic DNS update requests. $update = Net::DNS::Update->new( 'example.com' ); $update->push( prereq => nxrrset('example.com. AAAA') ); $update->push( update => rr_add('example.com. 86400 AAAA 2001::DB8::F00') ); =head2 yxrrset Use this method to add an "RRset exists" prerequisite to a dynamic update packet. There are two forms, value-independent and value-dependent: # RRset exists (value-independent) $update->push( pre => yxrrset("host.example.com AAAA") ); Meaning: At least one RR with the specified name and type must exist. # RRset exists (value-dependent) $update->push( pre => yxrrset("host.example.com AAAA 2001:DB8::1") ); Meaning: At least one RR with the specified name and type must exist and must have matching data. Returns a L object or C if the object could not be created. =head2 nxrrset Use this method to add an "RRset does not exist" prerequisite to a dynamic update packet. $update->push( pre => nxrrset("host.example.com AAAA") ); Meaning: No RRs with the specified name and type can exist. Returns a L object or C if the object could not be created. =head2 yxdomain Use this method to add a "name is in use" prerequisite to a dynamic update packet. $update->push( pre => yxdomain("host.example.com") ); Meaning: At least one RR with the specified name must exist. Returns a L object or C if the object could not be created. =head2 nxdomain Use this method to add a "name is not in use" prerequisite to a dynamic update packet. $update->push( pre => nxdomain("host.example.com") ); Meaning: No RR with the specified name can exist. Returns a L object or C if the object could not be created. =head2 rr_add Use this method to add RRs to a zone. $update->push( update => rr_add("host.example.com AAAA 2001:DB8::c001:a1e") ); Meaning: Add this RR to the zone. RR objects created by this method should be added to the "update" section of a dynamic update packet. The TTL defaults to 86400 seconds (24 hours) if not specified. Returns a L object or C if the object could not be created. =head2 rr_del Use this method to delete RRs from a zone. There are three forms: delete all RRsets, delete an RRset, and delete a specific RR. # Delete all RRsets. $update->push( update => rr_del("host.example.com") ); Meaning: Delete all RRs having the specified name. # Delete an RRset. $update->push( update => rr_del("host.example.com AAAA") ); Meaning: Delete all RRs having the specified name and type. # Delete a specific RR. $update->push( update => rr_del("host.example.com AAAA 2001:DB8::dead:beef") ); Meaning: Delete the RR which matches the specified argument. RR objects created by this method should be added to the "update" section of a dynamic update packet. Returns a L object or C if the object could not be created. =head1 Zone Serial Number Management The Net::DNS module provides auxiliary functions which support policy-driven zone serial numbering regimes. $soa->serial(SEQUENTIAL); $soa->serial(YYYMMDDxx); =head2 SEQUENTIAL $successor = $soa->serial( SEQUENTIAL ); The existing serial number is incremented modulo 2**32. =head2 UNIXTIME $successor = $soa->serial( UNIXTIME ); The Unix time scale will be used as the basis for zone serial numbering. The serial number will be incremented if the time elapsed since the previous update is less than one second. =head2 YYYYMMDDxx $successor = $soa->serial( YYYYMMDDxx ); The 32 bit value returned by the auxiliary C function will be used as the base for the date-coded zone serial number. Serial number increments must be limited to 100 per day for the date information to remain useful. =head1 Sorting of RR arrays C provides functionality to help you sort RR arrays. In most cases this will give you the result that you expect, but you can specify your own sorting method by using the C<< Net::DNS::RR::FOO->set_rrsort_func() >> class method. See L for details. =head2 rrsort use Net::DNS; my @sorted = rrsort( $rrtype, $attribute, @rr_array ); C selects all RRs from the input array that are of the type defined by the first argument. Those RRs are sorted based on the attribute that is specified as second argument. There are a number of RRs for which the sorting function is defined in the code. For instance: my @prioritysorted = rrsort( "SRV", "priority", @rr_array ); returns the SRV records sorted from lowest to highest priority and for equal priorities from highest to lowest weight. If the function does not exist then a numerical sort on the attribute value is performed. my @portsorted = rrsort( "SRV", "port", @rr_array ); If the attribute is not defined then either the C function or "canonical sorting" (as defined by DNSSEC) will be used. C returns a sorted array containing only elements of the specified RR type. Any other RR types are silently discarded. C returns an empty list when arguments are incorrect. =head1 EXAMPLES The following brief examples illustrate some of the features of Net::DNS. The documentation for individual modules and the demo scripts included with the distribution provide more extensive examples. See L for an example of performing dynamic updates. =head2 Look up host addresses. use Net::DNS; my $res = Net::DNS::Resolver->new; my $reply = $res->search( "www.example.com", "AAAA" ); die "query failed: ", $res->errorstring unless $reply; foreach my $rr ( $reply->answer ) { print $rr->address, "\n" if $rr->can("address"); } =head2 Find the nameservers for a domain. use Net::DNS; my $res = Net::DNS::Resolver->new; my $reply = $res->query( "example.com", "NS"); die "query failed: ", $res->errorstring unless $reply; foreach $rr ( grep {$_->type eq "NS"} $reply->answer ) { print $rr->nsdname, "\n"; } =head2 Find the MX records for a domain. use Net::DNS; my $name = "example.com"; my $res = Net::DNS::Resolver->new; my @mx = mx( $res, $name ); foreach $rr (@mx) { print $rr->preference, "\t", $rr->exchange, "\n"; } =head2 Print domain SOA record in zone file format. use Net::DNS; my $res = Net::DNS::Resolver->new; my $reply = $res->query( "example.com", "SOA" ); die "query failed: ", $res->errorstring unless $reply; foreach my $rr ( $reply->answer ) { $rr->print; } =head2 Perform a zone transfer and print all the records. use Net::DNS; my $res = Net::DNS::Resolver->new( nameservers => ["a.iana-servers.net", "b.iana-servers.net"], tcp_timeout => 20 ); my @zone = $res->axfr("example.com"); warn $res->errorstring if $res->errorstring; foreach $rr (@zone) { $rr->print; } =head2 Perform a background query and print the reply. use Net::DNS; my $res = Net::DNS::Resolver->new; $res->udp_timeout(10); $res->tcp_timeout(20); my $socket = $res->bgsend( "www.example.com", "AAAA" ); while ( $res->bgbusy($socket) ) { # do some work here whilst awaiting the response # ...and some more here } my $packet = $res->bgread($socket); die "query failed: ", $res->errorstring unless $packet; $packet->print; =head1 BUGS Net::DNS is slow. For other items to be fixed, or if you discover a bug in this distribution please use the CPAN bug reporting system. =head1 COPYRIGHT Copyright (c)1997-2000 Michael Fuhr. Portions Copyright (c)2002,2003 Chris Reinhardt. Portions Copyright (c)2005 Olaf Kolkman (RIPE NCC) Portions Copyright (c)2006 Olaf Kolkman (NLnet Labs) Portions Copyright (c)2014 Dick Franks All rights reserved. =head1 LICENSE Permission to use, copy, modify, and distribute this software and its documentation for any purpose and without fee is hereby granted, provided that the original copyright notices appear in all copies and that both copyright notice and this permission notice appear in supporting documentation, and that the name of the author not be used in advertising or publicity pertaining to distribution of the software without specific prior written permission. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =head1 AUTHOR INFORMATION Net::DNS is maintained at NLnet Labs (www.nlnetlabs.nl) by Willem Toorop and Dick Franks. Between 2005 and 2012 Net::DNS was maintained by Olaf Kolkman. Between 2002 and 2004 Net::DNS was maintained by Chris Reinhardt. Net::DNS was created in 1997 by Michael Fuhr. =head1 SEE ALSO L L L L L L L =cut IDNA2/Exception/Nameprep.php000064400000000162152345735560011575 0ustar00 | // | Jon Parise | // | Damian Alejandro Fernandez Sosa | // +----------------------------------------------------------------------+ require_once 'PEAR.php'; require_once 'Net/Socket.php'; /** * Provides an implementation of the SMTP protocol using PEAR's * Net_Socket class. * * @package Net_SMTP * @author Chuck Hagenbuch * @author Jon Parise * @author Damian Alejandro Fernandez Sosa * @license http://opensource.org/licenses/bsd-license.php BSD-2-Clause * * @example basic.php A basic implementation of the Net_SMTP package. */ class Net_SMTP { /** * The server to connect to. * @var string */ public $host = 'localhost'; /** * The port to connect to. * @var int */ public $port = 25; /** * The value to give when sending EHLO or HELO. * @var string */ public $localhost = 'localhost'; /** * List of supported authentication methods, in preferential order. * @var array */ public $auth_methods = array(); /** * Use SMTP command pipelining (specified in RFC 2920) if the SMTP * server supports it. * * When pipeling is enabled, rcptTo(), mailFrom(), sendFrom(), * somlFrom() and samlFrom() do not wait for a response from the * SMTP server but return immediately. * * @var bool */ public $pipelining = false; /** * Number of pipelined commands. * @var int */ protected $pipelined_commands = 0; /** * Should debugging output be enabled? * @var boolean */ protected $debug = false; /** * Debug output handler. * @var callback */ protected $debug_handler = null; /** * The socket resource being used to connect to the SMTP server. * @var resource */ protected $socket = null; /** * Array of socket options that will be passed to Net_Socket::connect(). * @see stream_context_create() * @var array */ protected $socket_options = null; /** * The socket I/O timeout value in seconds. * @var int */ protected $timeout = 0; /** * The most recent server response code. * @var int */ protected $code = -1; /** * The most recent server response arguments. * @var array */ protected $arguments = array(); /** * Stores the SMTP server's greeting string. * @var string */ protected $greeting = null; /** * Stores detected features of the SMTP server. * @var array */ protected $esmtp = array(); /** * Instantiates a new Net_SMTP object, overriding any defaults * with parameters that are passed in. * * If you have SSL support in PHP, you can connect to a server * over SSL using an 'ssl://' prefix: * * // 465 is a common smtps port. * $smtp = new Net_SMTP('ssl://mail.host.com', 465); * $smtp->connect(); * * @param string $host The server to connect to. * @param integer $port The port to connect to. * @param string $localhost The value to give when sending EHLO or HELO. * @param boolean $pipelining Use SMTP command pipelining * @param integer $timeout Socket I/O timeout in seconds. * @param array $socket_options Socket stream_context_create() options. * @param string $gssapi_principal GSSAPI service principal name * @param string $gssapi_cname GSSAPI credentials cache * * @since 1.0 */ public function __construct($host = null, $port = null, $localhost = null, $pipelining = false, $timeout = 0, $socket_options = null, $gssapi_principal=null, $gssapi_cname=null ) { if (isset($host)) { $this->host = $host; } if (isset($port)) { $this->port = $port; } if (isset($localhost)) { $this->localhost = $localhost; } $this->pipelining = $pipelining; $this->socket = new Net_Socket(); $this->socket_options = $socket_options; $this->timeout = $timeout; $this->gssapi_principal = $gssapi_principal; $this->gssapi_cname = $gssapi_cname; /* If PHP krb5 extension is loaded, we enable GSSAPI method. */ if (extension_loaded('krb5')) { $this->setAuthMethod('GSSAPI', array($this, 'authGSSAPI')); } /* Include the Auth_SASL package. If the package is available, we * enable the authentication methods that depend upon it. */ if (@include_once 'Auth/SASL.php') { $this->setAuthMethod('CRAM-MD5', array($this, 'authCramMD5')); $this->setAuthMethod('DIGEST-MD5', array($this, 'authDigestMD5')); } /* These standard authentication methods are always available. */ $this->setAuthMethod('LOGIN', array($this, 'authLogin'), false); $this->setAuthMethod('PLAIN', array($this, 'authPlain'), false); $this->setAuthMethod('XOAUTH2', array($this, 'authXOAuth2'), false); } /** * Set the socket I/O timeout value in seconds plus microseconds. * * @param integer $seconds Timeout value in seconds. * @param integer $microseconds Additional value in microseconds. * * @since 1.5.0 */ public function setTimeout($seconds, $microseconds = 0) { return $this->socket->setTimeout($seconds, $microseconds); } /** * Set the value of the debugging flag. * * @param boolean $debug New value for the debugging flag. * @param callback $handler Debug handler callback * * @since 1.1.0 */ public function setDebug($debug, $handler = null) { $this->debug = $debug; $this->debug_handler = $handler; } /** * Write the given debug text to the current debug output handler. * * @param string $message Debug mesage text. * * @since 1.3.3 */ protected function debug($message) { if ($this->debug) { if ($this->debug_handler) { call_user_func_array( $this->debug_handler, array(&$this, $message) ); } else { echo "DEBUG: $message\n"; } } } /** * Send the given string of data to the server. * * @param string $data The string of data to send. * * @return mixed The number of bytes that were actually written, * or a PEAR_Error object on failure. * * @since 1.1.0 */ protected function send($data) { $this->debug("Send: $data"); $result = $this->socket->write($data); if (!$result || PEAR::isError($result)) { $msg = $result ? $result->getMessage() : "unknown error"; return PEAR::raiseError("Failed to write to socket: $msg"); } return $result; } /** * Send a command to the server with an optional string of * arguments. A carriage return / linefeed (CRLF) sequence will * be appended to each command string before it is sent to the * SMTP server - an error will be thrown if the command string * already contains any newline characters. Use send() for * commands that must contain newlines. * * @param string $command The SMTP command to send to the server. * @param string $args A string of optional arguments to append * to the command. * * @return mixed The result of the send() call. * * @since 1.1.0 */ protected function put($command, $args = '') { if (!empty($args)) { $command .= ' ' . $args; } if (strcspn($command, "\r\n") !== strlen($command)) { return PEAR::raiseError('Commands cannot contain newlines'); } return $this->send($command . "\r\n"); } /** * Read a reply from the SMTP server. The reply consists of a response * code and a response message. * * @param mixed $valid The set of valid response codes. These * may be specified as an array of integer * values or as a single integer value. * @param bool $later Do not parse the response now, but wait * until the last command in the pipelined * command group * * @return mixed True if the server returned a valid response code or * a PEAR_Error object is an error condition is reached. * * @since 1.1.0 * * @see getResponse */ protected function parseResponse($valid, $later = false) { $this->code = -1; $this->arguments = array(); if ($later) { $this->pipelined_commands++; return true; } for ($i = 0; $i <= $this->pipelined_commands; $i++) { while ($line = $this->socket->readLine()) { $this->debug("Recv: $line"); /* If we receive an empty line, the connection was closed. */ if (empty($line)) { $this->disconnect(); return PEAR::raiseError('Connection was closed'); } /* Read the code and store the rest in the arguments array. */ $code = substr($line, 0, 3); $this->arguments[] = trim(substr($line, 4)); /* Check the syntax of the response code. */ if (is_numeric($code)) { $this->code = (int)$code; } else { $this->code = -1; break; } /* If this is not a multiline response, we're done. */ if (substr($line, 3, 1) != '-') { break; } } } $this->pipelined_commands = 0; /* Compare the server's response code with the valid code/codes. */ if (is_int($valid) && ($this->code === $valid)) { return true; } elseif (is_array($valid) && in_array($this->code, $valid, true)) { return true; } return PEAR::raiseError('Invalid response code received from server', $this->code); } /** * Issue an SMTP command and verify its response. * * @param string $command The SMTP command string or data. * @param mixed $valid The set of valid response codes. These * may be specified as an array of integer * values or as a single integer value. * * @return mixed True on success or a PEAR_Error object on failure. * * @since 1.6.0 */ public function command($command, $valid) { if (PEAR::isError($error = $this->put($command))) { return $error; } if (PEAR::isError($error = $this->parseResponse($valid))) { return $error; } return true; } /** * Return a 2-tuple containing the last response from the SMTP server. * * @return array A two-element array: the first element contains the * response code as an integer and the second element * contains the response's arguments as a string. * * @since 1.1.0 */ public function getResponse() { return array($this->code, join("\n", $this->arguments)); } /** * Return the SMTP server's greeting string. * * @return string A string containing the greeting string, or null if * a greeting has not been received. * * @since 1.3.3 */ public function getGreeting() { return $this->greeting; } /** * Attempt to connect to the SMTP server. * * @param int $timeout The timeout value (in seconds) for the * socket connection attempt. * @param bool $persistent Should a persistent socket connection * be used? * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function connect($timeout = null, $persistent = false) { $this->greeting = null; $result = $this->socket->connect( $this->host, $this->port, $persistent, $timeout, $this->socket_options ); if (PEAR::isError($result)) { return PEAR::raiseError( 'Failed to connect socket: ' . $result->getMessage() ); } /* * Now that we're connected, reset the socket's timeout value for * future I/O operations. This allows us to have different socket * timeout values for the initial connection (our $timeout parameter) * and all other socket operations. */ if ($this->timeout > 0) { if (PEAR::isError($error = $this->setTimeout($this->timeout))) { return $error; } } if (PEAR::isError($error = $this->parseResponse(220))) { return $error; } /* Extract and store a copy of the server's greeting string. */ list(, $this->greeting) = $this->getResponse(); if (PEAR::isError($error = $this->negotiate())) { return $error; } return true; } /** * Attempt to disconnect from the SMTP server. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function disconnect() { if (PEAR::isError($error = $this->put('QUIT'))) { return $error; } if (PEAR::isError($error = $this->parseResponse(221))) { return $error; } if (PEAR::isError($error = $this->socket->disconnect())) { return PEAR::raiseError( 'Failed to disconnect socket: ' . $error->getMessage() ); } return true; } /** * Attempt to send the EHLO command and obtain a list of ESMTP * extensions available, and failing that just send HELO. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * * @since 1.1.0 */ protected function negotiate() { if (PEAR::isError($error = $this->put('EHLO', $this->localhost))) { return $error; } if (PEAR::isError($this->parseResponse(250))) { /* If the EHLO failed, try the simpler HELO command. */ if (PEAR::isError($error = $this->put('HELO', $this->localhost))) { return $error; } if (PEAR::isError($this->parseResponse(250))) { return PEAR::raiseError('HELO was not accepted', $this->code); } return true; } foreach ($this->arguments as $argument) { $verb = strtok($argument, ' '); $len = strlen($verb); $arguments = substr($argument, $len + 1, strlen($argument) - $len - 1); $this->esmtp[$verb] = $arguments; } if (!isset($this->esmtp['PIPELINING'])) { $this->pipelining = false; } return true; } /** * Returns the name of the best authentication method that the server * has advertised. * * @return mixed Returns a string containing the name of the best * supported authentication method or a PEAR_Error object * if a failure condition is encountered. * @since 1.1.0 */ protected function getBestAuthMethod() { $available_methods = explode(' ', $this->esmtp['AUTH']); foreach ($this->auth_methods as $method => $callback) { if (in_array($method, $available_methods)) { return $method; } } return PEAR::raiseError('No supported authentication methods'); } /** * Establish STARTTLS Connection. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, true on success, or false if SSL/TLS * isn't available. * @since 1.10.0 */ public function starttls() { /* We can only attempt a TLS connection if one has been requested, * we're running PHP 5.1.0 or later, have access to the OpenSSL * extension, are connected to an SMTP server which supports the * STARTTLS extension, and aren't already connected over a secure * (SSL) socket connection. */ if (version_compare(PHP_VERSION, '5.1.0', '>=') && extension_loaded('openssl') && isset($this->esmtp['STARTTLS']) && strncasecmp($this->host, 'ssl://', 6) !== 0 ) { /* Start the TLS connection attempt. */ if (PEAR::isError($result = $this->put('STARTTLS'))) { return $result; } if (PEAR::isError($result = $this->parseResponse(220))) { return $result; } if (isset($this->socket_options['ssl']['crypto_method'])) { $crypto_method = $this->socket_options['ssl']['crypto_method']; } else { /* STREAM_CRYPTO_METHOD_TLS_ANY_CLIENT constant does not exist * and STREAM_CRYPTO_METHOD_SSLv23_CLIENT constant is * inconsistent across PHP versions. */ $crypto_method = STREAM_CRYPTO_METHOD_TLS_CLIENT | @STREAM_CRYPTO_METHOD_TLSv1_1_CLIENT | @STREAM_CRYPTO_METHOD_TLSv1_2_CLIENT; } if (PEAR::isError($result = $this->socket->enableCrypto(true, $crypto_method))) { return $result; } elseif ($result !== true) { return PEAR::raiseError('STARTTLS failed'); } /* Send EHLO again to recieve the AUTH string from the * SMTP server. */ $this->negotiate(); } else { return false; } return true; } /** * Attempt to do SMTP authentication. * * @param string $uid The userid to authenticate as. * @param string $pwd The password to authenticate with. * @param string $method The requested authentication method. If none is * specified, the best supported method will be used. * @param bool $tls Flag indicating whether or not TLS should be attempted. * @param string $authz An optional authorization identifier. If specified, this * identifier will be used as the authorization proxy. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function auth($uid, $pwd , $method = '', $tls = true, $authz = '') { /* We can only attempt a TLS connection if one has been requested, * we're running PHP 5.1.0 or later, have access to the OpenSSL * extension, are connected to an SMTP server which supports the * STARTTLS extension, and aren't already connected over a secure * (SSL) socket connection. */ if ($tls) { /* Start the TLS connection attempt. */ if (PEAR::isError($starttls = $this->starttls())) { return $starttls; } } if (empty($this->esmtp['AUTH'])) { return PEAR::raiseError('SMTP server does not support authentication'); } /* If no method has been specified, get the name of the best * supported method advertised by the SMTP server. */ if (empty($method)) { if (PEAR::isError($method = $this->getBestAuthMethod())) { /* Return the PEAR_Error object from _getBestAuthMethod(). */ return $method; } } else { $method = strtoupper($method); if (!array_key_exists($method, $this->auth_methods)) { return PEAR::raiseError("$method is not a supported authentication method"); } } if (!isset($this->auth_methods[$method])) { return PEAR::raiseError("$method is not a supported authentication method"); } if (!is_callable($this->auth_methods[$method], false)) { return PEAR::raiseError("$method authentication method cannot be called"); } if (is_array($this->auth_methods[$method])) { list($object, $method) = $this->auth_methods[$method]; $result = $object->{$method}($uid, $pwd, $authz, $this); } else { $func = $this->auth_methods[$method]; $result = $func($uid, $pwd, $authz, $this); } /* If an error was encountered, return the PEAR_Error object. */ if (PEAR::isError($result)) { return $result; } return true; } /** * Add a new authentication method. * * @param string $name The authentication method name (e.g. 'PLAIN') * @param mixed $callback The authentication callback (given as the name of a * function or as an (object, method name) array). * @param bool $prepend Should the new method be prepended to the list of * available methods? This is the default behavior, * giving the new method the highest priority. * * @return mixed True on success or a PEAR_Error object on failure. * * @since 1.6.0 */ public function setAuthMethod($name, $callback, $prepend = true) { if (!is_string($name)) { return PEAR::raiseError('Method name is not a string'); } if (!is_string($callback) && !is_array($callback)) { return PEAR::raiseError('Method callback must be string or array'); } if (is_array($callback)) { if (!is_object($callback[0]) || !is_string($callback[1])) { return PEAR::raiseError('Bad mMethod callback array'); } } if ($prepend) { $this->auth_methods = array_merge( array($name => $callback), $this->auth_methods ); } else { $this->auth_methods[$name] = $callback; } return true; } /** * Authenticates the user using the DIGEST-MD5 method. * * @param string $uid The userid to authenticate as. * @param string $pwd The password to authenticate with. * @param string $authz The optional authorization proxy identifier. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.1.0 */ protected function authDigestMD5($uid, $pwd, $authz = '') { if (PEAR::isError($error = $this->put('AUTH', 'DIGEST-MD5'))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { /* 503: Error: already authenticated */ if ($this->code === 503) { return true; } return $error; } $auth_sasl = new Auth_SASL; $digest = $auth_sasl->factory('digest-md5'); $challenge = base64_decode($this->arguments[0]); $auth_str = base64_encode( $digest->getResponse($uid, $pwd, $challenge, $this->host, "smtp", $authz) ); if (PEAR::isError($error = $this->put($auth_str))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { return $error; } /* We don't use the protocol's third step because SMTP doesn't * allow subsequent authentication, so we just silently ignore * it. */ if (PEAR::isError($error = $this->put(''))) { return $error; } /* 235: Authentication successful */ if (PEAR::isError($error = $this->parseResponse(235))) { return $error; } } /** * Authenticates the user using the CRAM-MD5 method. * * @param string $uid The userid to authenticate as. * @param string $pwd The password to authenticate with. * @param string $authz The optional authorization proxy identifier. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.1.0 */ protected function authCRAMMD5($uid, $pwd, $authz = '') { if (PEAR::isError($error = $this->put('AUTH', 'CRAM-MD5'))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { /* 503: Error: already authenticated */ if ($this->code === 503) { return true; } return $error; } $auth_sasl = new Auth_SASL; $challenge = base64_decode($this->arguments[0]); $cram = $auth_sasl->factory('cram-md5'); $auth_str = base64_encode($cram->getResponse($uid, $pwd, $challenge)); if (PEAR::isError($error = $this->put($auth_str))) { return $error; } /* 235: Authentication successful */ if (PEAR::isError($error = $this->parseResponse(235))) { return $error; } } /** * Authenticates the user using the LOGIN method. * * @param string $uid The userid to authenticate as. * @param string $pwd The password to authenticate with. * @param string $authz The optional authorization proxy identifier. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.1.0 */ protected function authLogin($uid, $pwd, $authz = '') { if (PEAR::isError($error = $this->put('AUTH', 'LOGIN'))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { /* 503: Error: already authenticated */ if ($this->code === 503) { return true; } return $error; } if (PEAR::isError($error = $this->put(base64_encode($uid)))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { return $error; } if (PEAR::isError($error = $this->put(base64_encode($pwd)))) { return $error; } /* 235: Authentication successful */ if (PEAR::isError($error = $this->parseResponse(235))) { return $error; } return true; } /** * Authenticates the user using the PLAIN method. * * @param string $uid The userid to authenticate as. * @param string $pwd The password to authenticate with. * @param string $authz The optional authorization proxy identifier. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.1.0 */ protected function authPlain($uid, $pwd, $authz = '') { if (PEAR::isError($error = $this->put('AUTH', 'PLAIN'))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { /* 503: Error: already authenticated */ if ($this->code === 503) { return true; } return $error; } $auth_str = base64_encode($authz . chr(0) . $uid . chr(0) . $pwd); if (PEAR::isError($error = $this->put($auth_str))) { return $error; } /* 235: Authentication successful */ if (PEAR::isError($error = $this->parseResponse(235))) { return $error; } return true; } /** * Authenticates the user using the GSSAPI method. * * PHP krb5 extension is required, * service principal and credentials cache must be set. * * @param string $uid The userid to authenticate as. * @param string $pwd The password to authenticate with. * @param string $authz The optional authorization proxy identifier. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. */ protected function authGSSAPI($uid, $pwd, $authz = '') { if (PEAR::isError($error = $this->put('AUTH', 'GSSAPI'))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { /* 503: Error: already authenticated */ if ($this->code === 503) { return true; } return $error; } if (!$this->gssapi_principal) { return PEAR::raiseError('No Kerberos service principal set', 2); } if (!empty($this->gssapi_cname)) { putenv('KRB5CCNAME=' . $this->gssapi_cname); } try { $ccache = new KRB5CCache(); if (!empty($this->gssapi_cname)) { $ccache->open($this->gssapi_cname); } $gssapicontext = new GSSAPIContext(); $gssapicontext->acquireCredentials($ccache); $token = ''; $success = $gssapicontext->initSecContext($this->gssapi_principal, null, null, null, $token); $token = base64_encode($token); } catch (Exception $e) { return PEAR::raiseError('GSSAPI authentication failed: ' . $e->getMessage()); } if (PEAR::isError($error = $this->put($token))) { return $error; } /* 334: Continue authentication request */ if (PEAR::isError($error = $this->parseResponse(334))) { return $error; } $response = $this->arguments[0]; try { $challenge = base64_decode($response); $gssapicontext->unwrap($challenge, $challenge); $gssapicontext->wrap($challenge, $challenge, true); } catch (Exception $e) { return PEAR::raiseError('GSSAPI authentication failed: ' . $e->getMessage()); } if (PEAR::isError($error = $this->put(base64_encode($challenge)))) { return $error; } /* 235: Authentication successful */ if (PEAR::isError($error = $this->parseResponse(235))) { return $error; } return true; } /** * Authenticates the user using the XOAUTH2 method. * * @param string $uid The userid to authenticate as. * @param string $token The access token to authenticate with. * @param string $authz The optional authorization proxy identifier. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.9.0 */ public function authXOAuth2($uid, $token, $authz, $conn) { $auth = base64_encode("user=$uid\1auth=$token\1\1"); if (PEAR::isError($error = $this->put('AUTH', 'XOAUTH2 ' . $auth))) { return $error; } /* 235: Authentication successful or 334: Continue authentication */ if (PEAR::isError($error = $this->parseResponse([235, 334]))) { return $error; } /* 334: Continue authentication request */ if ($this->code === 334) { /* Send an empty line as response to 334 */ if (PEAR::isError($error = $this->put(''))) { return $error; } /* Expect 235: Authentication successful */ if (PEAR::isError($error = $this->parseResponse(235))) { return $error; } } return true; } /** * Send the HELO command. * * @param string $domain The domain name to say we are. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function helo($domain) { if (PEAR::isError($error = $this->put('HELO', $domain))) { return $error; } if (PEAR::isError($error = $this->parseResponse(250))) { return $error; } return true; } /** * Return the list of SMTP service extensions advertised by the server. * * @return array The list of SMTP service extensions. * @since 1.3 */ public function getServiceExtensions() { return $this->esmtp; } /** * Send the MAIL FROM: command. * * @param string $sender The sender (reverse path) to set. * @param string $params String containing additional MAIL parameters, * such as the NOTIFY flags defined by RFC 1891 * or the VERP protocol. * * If $params is an array, only the 'verp' option * is supported. If 'verp' is true, the XVERP * parameter is appended to the MAIL command. * If the 'verp' value is a string, the full * XVERP=value parameter is appended. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function mailFrom($sender, $params = null) { $args = "FROM:<$sender>"; /* Support the deprecated array form of $params. */ if (is_array($params) && isset($params['verp'])) { if ($params['verp'] === true) { $args .= ' XVERP'; } elseif (trim($params['verp'])) { $args .= ' XVERP=' . $params['verp']; } } elseif (is_string($params) && !empty($params)) { $args .= ' ' . $params; } if (PEAR::isError($error = $this->put('MAIL', $args))) { return $error; } if (PEAR::isError($error = $this->parseResponse(250, $this->pipelining))) { return $error; } return true; } /** * Send the RCPT TO: command. * * @param string $recipient The recipient (forward path) to add. * @param string $params String containing additional RCPT parameters, * such as the NOTIFY flags defined by RFC 1891. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * * @since 1.0 */ public function rcptTo($recipient, $params = null) { $args = "TO:<$recipient>"; if (is_string($params)) { $args .= ' ' . $params; } if (PEAR::isError($error = $this->put('RCPT', $args))) { return $error; } if (PEAR::isError($error = $this->parseResponse(array(250, 251), $this->pipelining))) { return $error; } return true; } /** * Quote the data so that it meets SMTP standards. * * This is provided as a separate public function to facilitate * easier overloading for the cases where it is desirable to * customize the quoting behavior. * * @param string &$data The message text to quote. The string must be passed * by reference, and the text will be modified in place. * * @since 1.2 */ public function quotedata(&$data) { /* Because a single leading period (.) signifies an end to the * data, legitimate leading periods need to be "doubled" ('..'). */ $data = preg_replace('/^\./m', '..', $data); /* Change Unix (\n) and Mac (\r) linefeeds into CRLF's (\r\n). */ $data = preg_replace('/(?:\r\n|\n|\r(?!\n))/', "\r\n", $data); } /** * Send the DATA command. * * @param mixed $data The message data, either as a string or an open * file resource. * @param string $headers The message headers. If $headers is provided, * $data is assumed to contain only body data. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function data($data, $headers = null) { /* Verify that $data is a supported type. */ if (!is_string($data) && !is_resource($data)) { return PEAR::raiseError('Expected a string or file resource'); } /* Start by considering the size of the optional headers string. We * also account for the addition 4 character "\r\n\r\n" separator * sequence. */ $size = $headers_size = (is_null($headers)) ? 0 : strlen($headers) + 4; if (is_resource($data)) { $stat = fstat($data); if ($stat === false) { return PEAR::raiseError('Failed to get file size'); } $size += $stat['size']; } else { $size += strlen($data); } /* RFC 1870, section 3, subsection 3 states "a value of zero indicates * that no fixed maximum message size is in force". Furthermore, it * says that if "the parameter is omitted no information is conveyed * about the server's fixed maximum message size". */ $limit = (isset($this->esmtp['SIZE'])) ? $this->esmtp['SIZE'] : 0; if ($limit > 0 && $size >= $limit) { return PEAR::raiseError('Message size exceeds server limit'); } /* Initiate the DATA command. */ if (PEAR::isError($error = $this->put('DATA'))) { return $error; } if (PEAR::isError($error = $this->parseResponse(354))) { return $error; } /* If we have a separate headers string, send it first. */ if (!is_null($headers)) { $this->quotedata($headers); if (PEAR::isError($result = $this->send($headers . "\r\n\r\n"))) { return $result; } /* Subtract the headers size now that they've been sent. */ $size -= $headers_size; } /* Now we can send the message body data. */ if (is_resource($data)) { /* Stream the contents of the file resource out over our socket * connection, line by line. Each line must be run through the * quoting routine. */ while (strlen($line = fread($data, 8192)) > 0) { /* If the last character is an newline, we need to grab the * next character to check to see if it is a period. */ while (!feof($data)) { $char = fread($data, 1); $line .= $char; if ($char != "\n") { break; } } $this->quotedata($line); if (PEAR::isError($result = $this->send($line))) { return $result; } } $last = $line; } else { /* * Break up the data by sending one chunk (up to 512k) at a time. * This approach reduces our peak memory usage. */ for ($offset = 0; $offset < $size;) { $end = $offset + 512000; /* * Ensure we don't read beyond our data size or span multiple * lines. quotedata() can't properly handle character data * that's split across two line break boundaries. */ if ($end >= $size) { $end = $size; } else { for (; $end < $size; $end++) { if ($data[$end] != "\n") { break; } } } /* Extract our chunk and run it through the quoting routine. */ $chunk = substr($data, $offset, $end - $offset); $this->quotedata($chunk); /* If we run into a problem along the way, abort. */ if (PEAR::isError($result = $this->send($chunk))) { return $result; } /* Advance the offset to the end of this chunk. */ $offset = $end; } $last = $chunk; } /* Don't add another CRLF sequence if it's already in the data */ $terminator = (substr($last, -2) == "\r\n" ? '' : "\r\n") . ".\r\n"; /* Finally, send the DATA terminator sequence. */ if (PEAR::isError($result = $this->send($terminator))) { return $result; } /* Verify that the data was successfully received by the server. */ if (PEAR::isError($error = $this->parseResponse(250, $this->pipelining))) { return $error; } return true; } /** * Send the SEND FROM: command. * * @param string $path The reverse path to send. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.2.6 */ public function sendFrom($path) { if (PEAR::isError($error = $this->put('SEND', "FROM:<$path>"))) { return $error; } if (PEAR::isError($error = $this->parseResponse(250, $this->pipelining))) { return $error; } return true; } /** * Send the SOML FROM: command. * * @param string $path The reverse path to send. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.2.6 */ public function somlFrom($path) { if (PEAR::isError($error = $this->put('SOML', "FROM:<$path>"))) { return $error; } if (PEAR::isError($error = $this->parseResponse(250, $this->pipelining))) { return $error; } return true; } /** * Send the SAML FROM: command. * * @param string $path The reverse path to send. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.2.6 */ public function samlFrom($path) { if (PEAR::isError($error = $this->put('SAML', "FROM:<$path>"))) { return $error; } if (PEAR::isError($error = $this->parseResponse(250, $this->pipelining))) { return $error; } return true; } /** * Send the RSET command. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function rset() { if (PEAR::isError($error = $this->put('RSET'))) { return $error; } if (PEAR::isError($error = $this->parseResponse(250, $this->pipelining))) { return $error; } return true; } /** * Send the VRFY command. * * @param string $string The string to verify * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function vrfy($string) { /* Note: 251 is also a valid response code */ if (PEAR::isError($error = $this->put('VRFY', $string))) { return $error; } if (PEAR::isError($error = $this->parseResponse(array(250, 252)))) { return $error; } return true; } /** * Send the NOOP command. * * @return mixed Returns a PEAR_Error with an error message on any * kind of failure, or true on success. * @since 1.0 */ public function noop() { if (PEAR::isError($error = $this->put('NOOP'))) { return $error; } if (PEAR::isError($error = $this->parseResponse(250))) { return $error; } return true; } /** * Backwards-compatibility method. identifySender()'s functionality is * now handled internally. * * @return boolean This method always return true. * * @since 1.0 */ public function identifySender() { return true; } } IDNA2.php000064400000313255152345735560006102 0ustar00 * @author Matthias Sommerfeld * @author Stefan Neufeind * @version $Id$ */ class Net_IDNA2 { // {{{ npdata /** * These Unicode codepoints are * mapped to nothing, See RFC3454 for details * * @static * @var array * @access private */ private static $_np_map_nothing = array( 0xAD, 0x34F, 0x1806, 0x180B, 0x180C, 0x180D, 0x200B, 0x200C, 0x200D, 0x2060, 0xFE00, 0xFE01, 0xFE02, 0xFE03, 0xFE04, 0xFE05, 0xFE06, 0xFE07, 0xFE08, 0xFE09, 0xFE0A, 0xFE0B, 0xFE0C, 0xFE0D, 0xFE0E, 0xFE0F, 0xFEFF ); /** * Prohibited codepints * * @static * @var array * @access private */ private static $_general_prohibited = array( 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 0xA, 0xB, 0xC, 0xD, 0xE, 0xF, 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x1B, 0x1C, 0x1D, 0x1E, 0x1F, 0x20, 0x21, 0x22, 0x23, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x2B, 0x2C, 0x2F, 0x3B, 0x3C, 0x3D, 0x3E, 0x3F, 0x40, 0x5B, 0x5C, 0x5D, 0x5E, 0x5F, 0x60, 0x7B, 0x7C, 0x7D, 0x7E, 0x7F, 0x3002 ); /** * Codepints prohibited by Nameprep * @static * @var array * @access private */ private static $_np_prohibit = array( 0xA0, 0x1680, 0x2000, 0x2001, 0x2002, 0x2003, 0x2004, 0x2005, 0x2006, 0x2007, 0x2008, 0x2009, 0x200A, 0x200B, 0x202F, 0x205F, 0x3000, 0x6DD, 0x70F, 0x180E, 0x200C, 0x200D, 0x2028, 0x2029, 0xFEFF, 0xFFF9, 0xFFFA, 0xFFFB, 0xFFFC, 0xFFFE, 0xFFFF, 0x1FFFE, 0x1FFFF, 0x2FFFE, 0x2FFFF, 0x3FFFE, 0x3FFFF, 0x4FFFE, 0x4FFFF, 0x5FFFE, 0x5FFFF, 0x6FFFE, 0x6FFFF, 0x7FFFE, 0x7FFFF, 0x8FFFE, 0x8FFFF, 0x9FFFE, 0x9FFFF, 0xAFFFE, 0xAFFFF, 0xBFFFE, 0xBFFFF, 0xCFFFE, 0xCFFFF, 0xDFFFE, 0xDFFFF, 0xEFFFE, 0xEFFFF, 0xFFFFE, 0xFFFFF, 0x10FFFE, 0x10FFFF, 0xFFF9, 0xFFFA, 0xFFFB, 0xFFFC, 0xFFFD, 0x340, 0x341, 0x200E, 0x200F, 0x202A, 0x202B, 0x202C, 0x202D, 0x202E, 0x206A, 0x206B, 0x206C, 0x206D, 0x206E, 0x206F, 0xE0001 ); /** * Codepoint ranges prohibited by nameprep * * @static * @var array * @access private */ private static $_np_prohibit_ranges = array( array(0x80, 0x9F ), array(0x2060, 0x206F ), array(0x1D173, 0x1D17A ), array(0xE000, 0xF8FF ), array(0xF0000, 0xFFFFD ), array(0x100000, 0x10FFFD), array(0xFDD0, 0xFDEF ), array(0xD800, 0xDFFF ), array(0x2FF0, 0x2FFB ), array(0xE0020, 0xE007F ) ); /** * Replacement mappings (casemapping, replacement sequences, ...) * * @static * @var array * @access private */ private static $_np_replacemaps = array( 0x41 => array(0x61), 0x42 => array(0x62), 0x43 => array(0x63), 0x44 => array(0x64), 0x45 => array(0x65), 0x46 => array(0x66), 0x47 => array(0x67), 0x48 => array(0x68), 0x49 => array(0x69), 0x4A => array(0x6A), 0x4B => array(0x6B), 0x4C => array(0x6C), 0x4D => array(0x6D), 0x4E => array(0x6E), 0x4F => array(0x6F), 0x50 => array(0x70), 0x51 => array(0x71), 0x52 => array(0x72), 0x53 => array(0x73), 0x54 => array(0x74), 0x55 => array(0x75), 0x56 => array(0x76), 0x57 => array(0x77), 0x58 => array(0x78), 0x59 => array(0x79), 0x5A => array(0x7A), 0xB5 => array(0x3BC), 0xC0 => array(0xE0), 0xC1 => array(0xE1), 0xC2 => array(0xE2), 0xC3 => array(0xE3), 0xC4 => array(0xE4), 0xC5 => array(0xE5), 0xC6 => array(0xE6), 0xC7 => array(0xE7), 0xC8 => array(0xE8), 0xC9 => array(0xE9), 0xCA => array(0xEA), 0xCB => array(0xEB), 0xCC => array(0xEC), 0xCD => array(0xED), 0xCE => array(0xEE), 0xCF => array(0xEF), 0xD0 => array(0xF0), 0xD1 => array(0xF1), 0xD2 => array(0xF2), 0xD3 => array(0xF3), 0xD4 => array(0xF4), 0xD5 => array(0xF5), 0xD6 => array(0xF6), 0xD8 => array(0xF8), 0xD9 => array(0xF9), 0xDA => array(0xFA), 0xDB => array(0xFB), 0xDC => array(0xFC), 0xDD => array(0xFD), 0xDE => array(0xFE), 0xDF => array(0x73, 0x73), 0x100 => array(0x101), 0x102 => array(0x103), 0x104 => array(0x105), 0x106 => array(0x107), 0x108 => array(0x109), 0x10A => array(0x10B), 0x10C => array(0x10D), 0x10E => array(0x10F), 0x110 => array(0x111), 0x112 => array(0x113), 0x114 => array(0x115), 0x116 => array(0x117), 0x118 => array(0x119), 0x11A => array(0x11B), 0x11C => array(0x11D), 0x11E => array(0x11F), 0x120 => array(0x121), 0x122 => array(0x123), 0x124 => array(0x125), 0x126 => array(0x127), 0x128 => array(0x129), 0x12A => array(0x12B), 0x12C => array(0x12D), 0x12E => array(0x12F), 0x130 => array(0x69, 0x307), 0x132 => array(0x133), 0x134 => array(0x135), 0x136 => array(0x137), 0x139 => array(0x13A), 0x13B => array(0x13C), 0x13D => array(0x13E), 0x13F => array(0x140), 0x141 => array(0x142), 0x143 => array(0x144), 0x145 => array(0x146), 0x147 => array(0x148), 0x149 => array(0x2BC, 0x6E), 0x14A => array(0x14B), 0x14C => array(0x14D), 0x14E => array(0x14F), 0x150 => array(0x151), 0x152 => array(0x153), 0x154 => array(0x155), 0x156 => array(0x157), 0x158 => array(0x159), 0x15A => array(0x15B), 0x15C => array(0x15D), 0x15E => array(0x15F), 0x160 => array(0x161), 0x162 => array(0x163), 0x164 => array(0x165), 0x166 => array(0x167), 0x168 => array(0x169), 0x16A => array(0x16B), 0x16C => array(0x16D), 0x16E => array(0x16F), 0x170 => array(0x171), 0x172 => array(0x173), 0x174 => array(0x175), 0x176 => array(0x177), 0x178 => array(0xFF), 0x179 => array(0x17A), 0x17B => array(0x17C), 0x17D => array(0x17E), 0x17F => array(0x73), 0x181 => array(0x253), 0x182 => array(0x183), 0x184 => array(0x185), 0x186 => array(0x254), 0x187 => array(0x188), 0x189 => array(0x256), 0x18A => array(0x257), 0x18B => array(0x18C), 0x18E => array(0x1DD), 0x18F => array(0x259), 0x190 => array(0x25B), 0x191 => array(0x192), 0x193 => array(0x260), 0x194 => array(0x263), 0x196 => array(0x269), 0x197 => array(0x268), 0x198 => array(0x199), 0x19C => array(0x26F), 0x19D => array(0x272), 0x19F => array(0x275), 0x1A0 => array(0x1A1), 0x1A2 => array(0x1A3), 0x1A4 => array(0x1A5), 0x1A6 => array(0x280), 0x1A7 => array(0x1A8), 0x1A9 => array(0x283), 0x1AC => array(0x1AD), 0x1AE => array(0x288), 0x1AF => array(0x1B0), 0x1B1 => array(0x28A), 0x1B2 => array(0x28B), 0x1B3 => array(0x1B4), 0x1B5 => array(0x1B6), 0x1B7 => array(0x292), 0x1B8 => array(0x1B9), 0x1BC => array(0x1BD), 0x1C4 => array(0x1C6), 0x1C5 => array(0x1C6), 0x1C7 => array(0x1C9), 0x1C8 => array(0x1C9), 0x1CA => array(0x1CC), 0x1CB => array(0x1CC), 0x1CD => array(0x1CE), 0x1CF => array(0x1D0), 0x1D1 => array(0x1D2), 0x1D3 => array(0x1D4), 0x1D5 => array(0x1D6), 0x1D7 => array(0x1D8), 0x1D9 => array(0x1DA), 0x1DB => array(0x1DC), 0x1DE => array(0x1DF), 0x1E0 => array(0x1E1), 0x1E2 => array(0x1E3), 0x1E4 => array(0x1E5), 0x1E6 => array(0x1E7), 0x1E8 => array(0x1E9), 0x1EA => array(0x1EB), 0x1EC => array(0x1ED), 0x1EE => array(0x1EF), 0x1F0 => array(0x6A, 0x30C), 0x1F1 => array(0x1F3), 0x1F2 => array(0x1F3), 0x1F4 => array(0x1F5), 0x1F6 => array(0x195), 0x1F7 => array(0x1BF), 0x1F8 => array(0x1F9), 0x1FA => array(0x1FB), 0x1FC => array(0x1FD), 0x1FE => array(0x1FF), 0x200 => array(0x201), 0x202 => array(0x203), 0x204 => array(0x205), 0x206 => array(0x207), 0x208 => array(0x209), 0x20A => array(0x20B), 0x20C => array(0x20D), 0x20E => array(0x20F), 0x210 => array(0x211), 0x212 => array(0x213), 0x214 => array(0x215), 0x216 => array(0x217), 0x218 => array(0x219), 0x21A => array(0x21B), 0x21C => array(0x21D), 0x21E => array(0x21F), 0x220 => array(0x19E), 0x222 => array(0x223), 0x224 => array(0x225), 0x226 => array(0x227), 0x228 => array(0x229), 0x22A => array(0x22B), 0x22C => array(0x22D), 0x22E => array(0x22F), 0x230 => array(0x231), 0x232 => array(0x233), 0x345 => array(0x3B9), 0x37A => array(0x20, 0x3B9), 0x386 => array(0x3AC), 0x388 => array(0x3AD), 0x389 => array(0x3AE), 0x38A => array(0x3AF), 0x38C => array(0x3CC), 0x38E => array(0x3CD), 0x38F => array(0x3CE), 0x390 => array(0x3B9, 0x308, 0x301), 0x391 => array(0x3B1), 0x392 => array(0x3B2), 0x393 => array(0x3B3), 0x394 => array(0x3B4), 0x395 => array(0x3B5), 0x396 => array(0x3B6), 0x397 => array(0x3B7), 0x398 => array(0x3B8), 0x399 => array(0x3B9), 0x39A => array(0x3BA), 0x39B => array(0x3BB), 0x39C => array(0x3BC), 0x39D => array(0x3BD), 0x39E => array(0x3BE), 0x39F => array(0x3BF), 0x3A0 => array(0x3C0), 0x3A1 => array(0x3C1), 0x3A3 => array(0x3C3), 0x3A4 => array(0x3C4), 0x3A5 => array(0x3C5), 0x3A6 => array(0x3C6), 0x3A7 => array(0x3C7), 0x3A8 => array(0x3C8), 0x3A9 => array(0x3C9), 0x3AA => array(0x3CA), 0x3AB => array(0x3CB), 0x3B0 => array(0x3C5, 0x308, 0x301), 0x3C2 => array(0x3C3), 0x3D0 => array(0x3B2), 0x3D1 => array(0x3B8), 0x3D2 => array(0x3C5), 0x3D3 => array(0x3CD), 0x3D4 => array(0x3CB), 0x3D5 => array(0x3C6), 0x3D6 => array(0x3C0), 0x3D8 => array(0x3D9), 0x3DA => array(0x3DB), 0x3DC => array(0x3DD), 0x3DE => array(0x3DF), 0x3E0 => array(0x3E1), 0x3E2 => array(0x3E3), 0x3E4 => array(0x3E5), 0x3E6 => array(0x3E7), 0x3E8 => array(0x3E9), 0x3EA => array(0x3EB), 0x3EC => array(0x3ED), 0x3EE => array(0x3EF), 0x3F0 => array(0x3BA), 0x3F1 => array(0x3C1), 0x3F2 => array(0x3C3), 0x3F4 => array(0x3B8), 0x3F5 => array(0x3B5), 0x400 => array(0x450), 0x401 => array(0x451), 0x402 => array(0x452), 0x403 => array(0x453), 0x404 => array(0x454), 0x405 => array(0x455), 0x406 => array(0x456), 0x407 => array(0x457), 0x408 => array(0x458), 0x409 => array(0x459), 0x40A => array(0x45A), 0x40B => array(0x45B), 0x40C => array(0x45C), 0x40D => array(0x45D), 0x40E => array(0x45E), 0x40F => array(0x45F), 0x410 => array(0x430), 0x411 => array(0x431), 0x412 => array(0x432), 0x413 => array(0x433), 0x414 => array(0x434), 0x415 => array(0x435), 0x416 => array(0x436), 0x417 => array(0x437), 0x418 => array(0x438), 0x419 => array(0x439), 0x41A => array(0x43A), 0x41B => array(0x43B), 0x41C => array(0x43C), 0x41D => array(0x43D), 0x41E => array(0x43E), 0x41F => array(0x43F), 0x420 => array(0x440), 0x421 => array(0x441), 0x422 => array(0x442), 0x423 => array(0x443), 0x424 => array(0x444), 0x425 => array(0x445), 0x426 => array(0x446), 0x427 => array(0x447), 0x428 => array(0x448), 0x429 => array(0x449), 0x42A => array(0x44A), 0x42B => array(0x44B), 0x42C => array(0x44C), 0x42D => array(0x44D), 0x42E => array(0x44E), 0x42F => array(0x44F), 0x460 => array(0x461), 0x462 => array(0x463), 0x464 => array(0x465), 0x466 => array(0x467), 0x468 => array(0x469), 0x46A => array(0x46B), 0x46C => array(0x46D), 0x46E => array(0x46F), 0x470 => array(0x471), 0x472 => array(0x473), 0x474 => array(0x475), 0x476 => array(0x477), 0x478 => array(0x479), 0x47A => array(0x47B), 0x47C => array(0x47D), 0x47E => array(0x47F), 0x480 => array(0x481), 0x48A => array(0x48B), 0x48C => array(0x48D), 0x48E => array(0x48F), 0x490 => array(0x491), 0x492 => array(0x493), 0x494 => array(0x495), 0x496 => array(0x497), 0x498 => array(0x499), 0x49A => array(0x49B), 0x49C => array(0x49D), 0x49E => array(0x49F), 0x4A0 => array(0x4A1), 0x4A2 => array(0x4A3), 0x4A4 => array(0x4A5), 0x4A6 => array(0x4A7), 0x4A8 => array(0x4A9), 0x4AA => array(0x4AB), 0x4AC => array(0x4AD), 0x4AE => array(0x4AF), 0x4B0 => array(0x4B1), 0x4B2 => array(0x4B3), 0x4B4 => array(0x4B5), 0x4B6 => array(0x4B7), 0x4B8 => array(0x4B9), 0x4BA => array(0x4BB), 0x4BC => array(0x4BD), 0x4BE => array(0x4BF), 0x4C1 => array(0x4C2), 0x4C3 => array(0x4C4), 0x4C5 => array(0x4C6), 0x4C7 => array(0x4C8), 0x4C9 => array(0x4CA), 0x4CB => array(0x4CC), 0x4CD => array(0x4CE), 0x4D0 => array(0x4D1), 0x4D2 => array(0x4D3), 0x4D4 => array(0x4D5), 0x4D6 => array(0x4D7), 0x4D8 => array(0x4D9), 0x4DA => array(0x4DB), 0x4DC => array(0x4DD), 0x4DE => array(0x4DF), 0x4E0 => array(0x4E1), 0x4E2 => array(0x4E3), 0x4E4 => array(0x4E5), 0x4E6 => array(0x4E7), 0x4E8 => array(0x4E9), 0x4EA => array(0x4EB), 0x4EC => array(0x4ED), 0x4EE => array(0x4EF), 0x4F0 => array(0x4F1), 0x4F2 => array(0x4F3), 0x4F4 => array(0x4F5), 0x4F8 => array(0x4F9), 0x500 => array(0x501), 0x502 => array(0x503), 0x504 => array(0x505), 0x506 => array(0x507), 0x508 => array(0x509), 0x50A => array(0x50B), 0x50C => array(0x50D), 0x50E => array(0x50F), 0x531 => array(0x561), 0x532 => array(0x562), 0x533 => array(0x563), 0x534 => array(0x564), 0x535 => array(0x565), 0x536 => array(0x566), 0x537 => array(0x567), 0x538 => array(0x568), 0x539 => array(0x569), 0x53A => array(0x56A), 0x53B => array(0x56B), 0x53C => array(0x56C), 0x53D => array(0x56D), 0x53E => array(0x56E), 0x53F => array(0x56F), 0x540 => array(0x570), 0x541 => array(0x571), 0x542 => array(0x572), 0x543 => array(0x573), 0x544 => array(0x574), 0x545 => array(0x575), 0x546 => array(0x576), 0x547 => array(0x577), 0x548 => array(0x578), 0x549 => array(0x579), 0x54A => array(0x57A), 0x54B => array(0x57B), 0x54C => array(0x57C), 0x54D => array(0x57D), 0x54E => array(0x57E), 0x54F => array(0x57F), 0x550 => array(0x580), 0x551 => array(0x581), 0x552 => array(0x582), 0x553 => array(0x583), 0x554 => array(0x584), 0x555 => array(0x585), 0x556 => array(0x586), 0x587 => array(0x565, 0x582), 0x1E00 => array(0x1E01), 0x1E02 => array(0x1E03), 0x1E04 => array(0x1E05), 0x1E06 => array(0x1E07), 0x1E08 => array(0x1E09), 0x1E0A => array(0x1E0B), 0x1E0C => array(0x1E0D), 0x1E0E => array(0x1E0F), 0x1E10 => array(0x1E11), 0x1E12 => array(0x1E13), 0x1E14 => array(0x1E15), 0x1E16 => array(0x1E17), 0x1E18 => array(0x1E19), 0x1E1A => array(0x1E1B), 0x1E1C => array(0x1E1D), 0x1E1E => array(0x1E1F), 0x1E20 => array(0x1E21), 0x1E22 => array(0x1E23), 0x1E24 => array(0x1E25), 0x1E26 => array(0x1E27), 0x1E28 => array(0x1E29), 0x1E2A => array(0x1E2B), 0x1E2C => array(0x1E2D), 0x1E2E => array(0x1E2F), 0x1E30 => array(0x1E31), 0x1E32 => array(0x1E33), 0x1E34 => array(0x1E35), 0x1E36 => array(0x1E37), 0x1E38 => array(0x1E39), 0x1E3A => array(0x1E3B), 0x1E3C => array(0x1E3D), 0x1E3E => array(0x1E3F), 0x1E40 => array(0x1E41), 0x1E42 => array(0x1E43), 0x1E44 => array(0x1E45), 0x1E46 => array(0x1E47), 0x1E48 => array(0x1E49), 0x1E4A => array(0x1E4B), 0x1E4C => array(0x1E4D), 0x1E4E => array(0x1E4F), 0x1E50 => array(0x1E51), 0x1E52 => array(0x1E53), 0x1E54 => array(0x1E55), 0x1E56 => array(0x1E57), 0x1E58 => array(0x1E59), 0x1E5A => array(0x1E5B), 0x1E5C => array(0x1E5D), 0x1E5E => array(0x1E5F), 0x1E60 => array(0x1E61), 0x1E62 => array(0x1E63), 0x1E64 => array(0x1E65), 0x1E66 => array(0x1E67), 0x1E68 => array(0x1E69), 0x1E6A => array(0x1E6B), 0x1E6C => array(0x1E6D), 0x1E6E => array(0x1E6F), 0x1E70 => array(0x1E71), 0x1E72 => array(0x1E73), 0x1E74 => array(0x1E75), 0x1E76 => array(0x1E77), 0x1E78 => array(0x1E79), 0x1E7A => array(0x1E7B), 0x1E7C => array(0x1E7D), 0x1E7E => array(0x1E7F), 0x1E80 => array(0x1E81), 0x1E82 => array(0x1E83), 0x1E84 => array(0x1E85), 0x1E86 => array(0x1E87), 0x1E88 => array(0x1E89), 0x1E8A => array(0x1E8B), 0x1E8C => array(0x1E8D), 0x1E8E => array(0x1E8F), 0x1E90 => array(0x1E91), 0x1E92 => array(0x1E93), 0x1E94 => array(0x1E95), 0x1E96 => array(0x68, 0x331), 0x1E97 => array(0x74, 0x308), 0x1E98 => array(0x77, 0x30A), 0x1E99 => array(0x79, 0x30A), 0x1E9A => array(0x61, 0x2BE), 0x1E9B => array(0x1E61), 0x1EA0 => array(0x1EA1), 0x1EA2 => array(0x1EA3), 0x1EA4 => array(0x1EA5), 0x1EA6 => array(0x1EA7), 0x1EA8 => array(0x1EA9), 0x1EAA => array(0x1EAB), 0x1EAC => array(0x1EAD), 0x1EAE => array(0x1EAF), 0x1EB0 => array(0x1EB1), 0x1EB2 => array(0x1EB3), 0x1EB4 => array(0x1EB5), 0x1EB6 => array(0x1EB7), 0x1EB8 => array(0x1EB9), 0x1EBA => array(0x1EBB), 0x1EBC => array(0x1EBD), 0x1EBE => array(0x1EBF), 0x1EC0 => array(0x1EC1), 0x1EC2 => array(0x1EC3), 0x1EC4 => array(0x1EC5), 0x1EC6 => array(0x1EC7), 0x1EC8 => array(0x1EC9), 0x1ECA => array(0x1ECB), 0x1ECC => array(0x1ECD), 0x1ECE => array(0x1ECF), 0x1ED0 => array(0x1ED1), 0x1ED2 => array(0x1ED3), 0x1ED4 => array(0x1ED5), 0x1ED6 => array(0x1ED7), 0x1ED8 => array(0x1ED9), 0x1EDA => array(0x1EDB), 0x1EDC => array(0x1EDD), 0x1EDE => array(0x1EDF), 0x1EE0 => array(0x1EE1), 0x1EE2 => array(0x1EE3), 0x1EE4 => array(0x1EE5), 0x1EE6 => array(0x1EE7), 0x1EE8 => array(0x1EE9), 0x1EEA => array(0x1EEB), 0x1EEC => array(0x1EED), 0x1EEE => array(0x1EEF), 0x1EF0 => array(0x1EF1), 0x1EF2 => array(0x1EF3), 0x1EF4 => array(0x1EF5), 0x1EF6 => array(0x1EF7), 0x1EF8 => array(0x1EF9), 0x1F08 => array(0x1F00), 0x1F09 => array(0x1F01), 0x1F0A => array(0x1F02), 0x1F0B => array(0x1F03), 0x1F0C => array(0x1F04), 0x1F0D => array(0x1F05), 0x1F0E => array(0x1F06), 0x1F0F => array(0x1F07), 0x1F18 => array(0x1F10), 0x1F19 => array(0x1F11), 0x1F1A => array(0x1F12), 0x1F1B => array(0x1F13), 0x1F1C => array(0x1F14), 0x1F1D => array(0x1F15), 0x1F28 => array(0x1F20), 0x1F29 => array(0x1F21), 0x1F2A => array(0x1F22), 0x1F2B => array(0x1F23), 0x1F2C => array(0x1F24), 0x1F2D => array(0x1F25), 0x1F2E => array(0x1F26), 0x1F2F => array(0x1F27), 0x1F38 => array(0x1F30), 0x1F39 => array(0x1F31), 0x1F3A => array(0x1F32), 0x1F3B => array(0x1F33), 0x1F3C => array(0x1F34), 0x1F3D => array(0x1F35), 0x1F3E => array(0x1F36), 0x1F3F => array(0x1F37), 0x1F48 => array(0x1F40), 0x1F49 => array(0x1F41), 0x1F4A => array(0x1F42), 0x1F4B => array(0x1F43), 0x1F4C => array(0x1F44), 0x1F4D => array(0x1F45), 0x1F50 => array(0x3C5, 0x313), 0x1F52 => array(0x3C5, 0x313, 0x300), 0x1F54 => array(0x3C5, 0x313, 0x301), 0x1F56 => array(0x3C5, 0x313, 0x342), 0x1F59 => array(0x1F51), 0x1F5B => array(0x1F53), 0x1F5D => array(0x1F55), 0x1F5F => array(0x1F57), 0x1F68 => array(0x1F60), 0x1F69 => array(0x1F61), 0x1F6A => array(0x1F62), 0x1F6B => array(0x1F63), 0x1F6C => array(0x1F64), 0x1F6D => array(0x1F65), 0x1F6E => array(0x1F66), 0x1F6F => array(0x1F67), 0x1F80 => array(0x1F00, 0x3B9), 0x1F81 => array(0x1F01, 0x3B9), 0x1F82 => array(0x1F02, 0x3B9), 0x1F83 => array(0x1F03, 0x3B9), 0x1F84 => array(0x1F04, 0x3B9), 0x1F85 => array(0x1F05, 0x3B9), 0x1F86 => array(0x1F06, 0x3B9), 0x1F87 => array(0x1F07, 0x3B9), 0x1F88 => array(0x1F00, 0x3B9), 0x1F89 => array(0x1F01, 0x3B9), 0x1F8A => array(0x1F02, 0x3B9), 0x1F8B => array(0x1F03, 0x3B9), 0x1F8C => array(0x1F04, 0x3B9), 0x1F8D => array(0x1F05, 0x3B9), 0x1F8E => array(0x1F06, 0x3B9), 0x1F8F => array(0x1F07, 0x3B9), 0x1F90 => array(0x1F20, 0x3B9), 0x1F91 => array(0x1F21, 0x3B9), 0x1F92 => array(0x1F22, 0x3B9), 0x1F93 => array(0x1F23, 0x3B9), 0x1F94 => array(0x1F24, 0x3B9), 0x1F95 => array(0x1F25, 0x3B9), 0x1F96 => array(0x1F26, 0x3B9), 0x1F97 => array(0x1F27, 0x3B9), 0x1F98 => array(0x1F20, 0x3B9), 0x1F99 => array(0x1F21, 0x3B9), 0x1F9A => array(0x1F22, 0x3B9), 0x1F9B => array(0x1F23, 0x3B9), 0x1F9C => array(0x1F24, 0x3B9), 0x1F9D => array(0x1F25, 0x3B9), 0x1F9E => array(0x1F26, 0x3B9), 0x1F9F => array(0x1F27, 0x3B9), 0x1FA0 => array(0x1F60, 0x3B9), 0x1FA1 => array(0x1F61, 0x3B9), 0x1FA2 => array(0x1F62, 0x3B9), 0x1FA3 => array(0x1F63, 0x3B9), 0x1FA4 => array(0x1F64, 0x3B9), 0x1FA5 => array(0x1F65, 0x3B9), 0x1FA6 => array(0x1F66, 0x3B9), 0x1FA7 => array(0x1F67, 0x3B9), 0x1FA8 => array(0x1F60, 0x3B9), 0x1FA9 => array(0x1F61, 0x3B9), 0x1FAA => array(0x1F62, 0x3B9), 0x1FAB => array(0x1F63, 0x3B9), 0x1FAC => array(0x1F64, 0x3B9), 0x1FAD => array(0x1F65, 0x3B9), 0x1FAE => array(0x1F66, 0x3B9), 0x1FAF => array(0x1F67, 0x3B9), 0x1FB2 => array(0x1F70, 0x3B9), 0x1FB3 => array(0x3B1, 0x3B9), 0x1FB4 => array(0x3AC, 0x3B9), 0x1FB6 => array(0x3B1, 0x342), 0x1FB7 => array(0x3B1, 0x342, 0x3B9), 0x1FB8 => array(0x1FB0), 0x1FB9 => array(0x1FB1), 0x1FBA => array(0x1F70), 0x1FBB => array(0x1F71), 0x1FBC => array(0x3B1, 0x3B9), 0x1FBE => array(0x3B9), 0x1FC2 => array(0x1F74, 0x3B9), 0x1FC3 => array(0x3B7, 0x3B9), 0x1FC4 => array(0x3AE, 0x3B9), 0x1FC6 => array(0x3B7, 0x342), 0x1FC7 => array(0x3B7, 0x342, 0x3B9), 0x1FC8 => array(0x1F72), 0x1FC9 => array(0x1F73), 0x1FCA => array(0x1F74), 0x1FCB => array(0x1F75), 0x1FCC => array(0x3B7, 0x3B9), 0x1FD2 => array(0x3B9, 0x308, 0x300), 0x1FD3 => array(0x3B9, 0x308, 0x301), 0x1FD6 => array(0x3B9, 0x342), 0x1FD7 => array(0x3B9, 0x308, 0x342), 0x1FD8 => array(0x1FD0), 0x1FD9 => array(0x1FD1), 0x1FDA => array(0x1F76), 0x1FDB => array(0x1F77), 0x1FE2 => array(0x3C5, 0x308, 0x300), 0x1FE3 => array(0x3C5, 0x308, 0x301), 0x1FE4 => array(0x3C1, 0x313), 0x1FE6 => array(0x3C5, 0x342), 0x1FE7 => array(0x3C5, 0x308, 0x342), 0x1FE8 => array(0x1FE0), 0x1FE9 => array(0x1FE1), 0x1FEA => array(0x1F7A), 0x1FEB => array(0x1F7B), 0x1FEC => array(0x1FE5), 0x1FF2 => array(0x1F7C, 0x3B9), 0x1FF3 => array(0x3C9, 0x3B9), 0x1FF4 => array(0x3CE, 0x3B9), 0x1FF6 => array(0x3C9, 0x342), 0x1FF7 => array(0x3C9, 0x342, 0x3B9), 0x1FF8 => array(0x1F78), 0x1FF9 => array(0x1F79), 0x1FFA => array(0x1F7C), 0x1FFB => array(0x1F7D), 0x1FFC => array(0x3C9, 0x3B9), 0x20A8 => array(0x72, 0x73), 0x2102 => array(0x63), 0x2103 => array(0xB0, 0x63), 0x2107 => array(0x25B), 0x2109 => array(0xB0, 0x66), 0x210B => array(0x68), 0x210C => array(0x68), 0x210D => array(0x68), 0x2110 => array(0x69), 0x2111 => array(0x69), 0x2112 => array(0x6C), 0x2115 => array(0x6E), 0x2116 => array(0x6E, 0x6F), 0x2119 => array(0x70), 0x211A => array(0x71), 0x211B => array(0x72), 0x211C => array(0x72), 0x211D => array(0x72), 0x2120 => array(0x73, 0x6D), 0x2121 => array(0x74, 0x65, 0x6C), 0x2122 => array(0x74, 0x6D), 0x2124 => array(0x7A), 0x2126 => array(0x3C9), 0x2128 => array(0x7A), 0x212A => array(0x6B), 0x212B => array(0xE5), 0x212C => array(0x62), 0x212D => array(0x63), 0x2130 => array(0x65), 0x2131 => array(0x66), 0x2133 => array(0x6D), 0x213E => array(0x3B3), 0x213F => array(0x3C0), 0x2145 => array(0x64), 0x2160 => array(0x2170), 0x2161 => array(0x2171), 0x2162 => array(0x2172), 0x2163 => array(0x2173), 0x2164 => array(0x2174), 0x2165 => array(0x2175), 0x2166 => array(0x2176), 0x2167 => array(0x2177), 0x2168 => array(0x2178), 0x2169 => array(0x2179), 0x216A => array(0x217A), 0x216B => array(0x217B), 0x216C => array(0x217C), 0x216D => array(0x217D), 0x216E => array(0x217E), 0x216F => array(0x217F), 0x24B6 => array(0x24D0), 0x24B7 => array(0x24D1), 0x24B8 => array(0x24D2), 0x24B9 => array(0x24D3), 0x24BA => array(0x24D4), 0x24BB => array(0x24D5), 0x24BC => array(0x24D6), 0x24BD => array(0x24D7), 0x24BE => array(0x24D8), 0x24BF => array(0x24D9), 0x24C0 => array(0x24DA), 0x24C1 => array(0x24DB), 0x24C2 => array(0x24DC), 0x24C3 => array(0x24DD), 0x24C4 => array(0x24DE), 0x24C5 => array(0x24DF), 0x24C6 => array(0x24E0), 0x24C7 => array(0x24E1), 0x24C8 => array(0x24E2), 0x24C9 => array(0x24E3), 0x24CA => array(0x24E4), 0x24CB => array(0x24E5), 0x24CC => array(0x24E6), 0x24CD => array(0x24E7), 0x24CE => array(0x24E8), 0x24CF => array(0x24E9), 0x3371 => array(0x68, 0x70, 0x61), 0x3373 => array(0x61, 0x75), 0x3375 => array(0x6F, 0x76), 0x3380 => array(0x70, 0x61), 0x3381 => array(0x6E, 0x61), 0x3382 => array(0x3BC, 0x61), 0x3383 => array(0x6D, 0x61), 0x3384 => array(0x6B, 0x61), 0x3385 => array(0x6B, 0x62), 0x3386 => array(0x6D, 0x62), 0x3387 => array(0x67, 0x62), 0x338A => array(0x70, 0x66), 0x338B => array(0x6E, 0x66), 0x338C => array(0x3BC, 0x66), 0x3390 => array(0x68, 0x7A), 0x3391 => array(0x6B, 0x68, 0x7A), 0x3392 => array(0x6D, 0x68, 0x7A), 0x3393 => array(0x67, 0x68, 0x7A), 0x3394 => array(0x74, 0x68, 0x7A), 0x33A9 => array(0x70, 0x61), 0x33AA => array(0x6B, 0x70, 0x61), 0x33AB => array(0x6D, 0x70, 0x61), 0x33AC => array(0x67, 0x70, 0x61), 0x33B4 => array(0x70, 0x76), 0x33B5 => array(0x6E, 0x76), 0x33B6 => array(0x3BC, 0x76), 0x33B7 => array(0x6D, 0x76), 0x33B8 => array(0x6B, 0x76), 0x33B9 => array(0x6D, 0x76), 0x33BA => array(0x70, 0x77), 0x33BB => array(0x6E, 0x77), 0x33BC => array(0x3BC, 0x77), 0x33BD => array(0x6D, 0x77), 0x33BE => array(0x6B, 0x77), 0x33BF => array(0x6D, 0x77), 0x33C0 => array(0x6B, 0x3C9), 0x33C1 => array(0x6D, 0x3C9), /* 0x33C2 => array(0x61, 0x2E, 0x6D, 0x2E), */ 0x33C3 => array(0x62, 0x71), 0x33C6 => array(0x63, 0x2215, 0x6B, 0x67), 0x33C7 => array(0x63, 0x6F, 0x2E), 0x33C8 => array(0x64, 0x62), 0x33C9 => array(0x67, 0x79), 0x33CB => array(0x68, 0x70), 0x33CD => array(0x6B, 0x6B), 0x33CE => array(0x6B, 0x6D), 0x33D7 => array(0x70, 0x68), 0x33D9 => array(0x70, 0x70, 0x6D), 0x33DA => array(0x70, 0x72), 0x33DC => array(0x73, 0x76), 0x33DD => array(0x77, 0x62), 0xFB00 => array(0x66, 0x66), 0xFB01 => array(0x66, 0x69), 0xFB02 => array(0x66, 0x6C), 0xFB03 => array(0x66, 0x66, 0x69), 0xFB04 => array(0x66, 0x66, 0x6C), 0xFB05 => array(0x73, 0x74), 0xFB06 => array(0x73, 0x74), 0xFB13 => array(0x574, 0x576), 0xFB14 => array(0x574, 0x565), 0xFB15 => array(0x574, 0x56B), 0xFB16 => array(0x57E, 0x576), 0xFB17 => array(0x574, 0x56D), 0xFF21 => array(0xFF41), 0xFF22 => array(0xFF42), 0xFF23 => array(0xFF43), 0xFF24 => array(0xFF44), 0xFF25 => array(0xFF45), 0xFF26 => array(0xFF46), 0xFF27 => array(0xFF47), 0xFF28 => array(0xFF48), 0xFF29 => array(0xFF49), 0xFF2A => array(0xFF4A), 0xFF2B => array(0xFF4B), 0xFF2C => array(0xFF4C), 0xFF2D => array(0xFF4D), 0xFF2E => array(0xFF4E), 0xFF2F => array(0xFF4F), 0xFF30 => array(0xFF50), 0xFF31 => array(0xFF51), 0xFF32 => array(0xFF52), 0xFF33 => array(0xFF53), 0xFF34 => array(0xFF54), 0xFF35 => array(0xFF55), 0xFF36 => array(0xFF56), 0xFF37 => array(0xFF57), 0xFF38 => array(0xFF58), 0xFF39 => array(0xFF59), 0xFF3A => array(0xFF5A), 0x10400 => array(0x10428), 0x10401 => array(0x10429), 0x10402 => array(0x1042A), 0x10403 => array(0x1042B), 0x10404 => array(0x1042C), 0x10405 => array(0x1042D), 0x10406 => array(0x1042E), 0x10407 => array(0x1042F), 0x10408 => array(0x10430), 0x10409 => array(0x10431), 0x1040A => array(0x10432), 0x1040B => array(0x10433), 0x1040C => array(0x10434), 0x1040D => array(0x10435), 0x1040E => array(0x10436), 0x1040F => array(0x10437), 0x10410 => array(0x10438), 0x10411 => array(0x10439), 0x10412 => array(0x1043A), 0x10413 => array(0x1043B), 0x10414 => array(0x1043C), 0x10415 => array(0x1043D), 0x10416 => array(0x1043E), 0x10417 => array(0x1043F), 0x10418 => array(0x10440), 0x10419 => array(0x10441), 0x1041A => array(0x10442), 0x1041B => array(0x10443), 0x1041C => array(0x10444), 0x1041D => array(0x10445), 0x1041E => array(0x10446), 0x1041F => array(0x10447), 0x10420 => array(0x10448), 0x10421 => array(0x10449), 0x10422 => array(0x1044A), 0x10423 => array(0x1044B), 0x10424 => array(0x1044C), 0x10425 => array(0x1044D), 0x1D400 => array(0x61), 0x1D401 => array(0x62), 0x1D402 => array(0x63), 0x1D403 => array(0x64), 0x1D404 => array(0x65), 0x1D405 => array(0x66), 0x1D406 => array(0x67), 0x1D407 => array(0x68), 0x1D408 => array(0x69), 0x1D409 => array(0x6A), 0x1D40A => array(0x6B), 0x1D40B => array(0x6C), 0x1D40C => array(0x6D), 0x1D40D => array(0x6E), 0x1D40E => array(0x6F), 0x1D40F => array(0x70), 0x1D410 => array(0x71), 0x1D411 => array(0x72), 0x1D412 => array(0x73), 0x1D413 => array(0x74), 0x1D414 => array(0x75), 0x1D415 => array(0x76), 0x1D416 => array(0x77), 0x1D417 => array(0x78), 0x1D418 => array(0x79), 0x1D419 => array(0x7A), 0x1D434 => array(0x61), 0x1D435 => array(0x62), 0x1D436 => array(0x63), 0x1D437 => array(0x64), 0x1D438 => array(0x65), 0x1D439 => array(0x66), 0x1D43A => array(0x67), 0x1D43B => array(0x68), 0x1D43C => array(0x69), 0x1D43D => array(0x6A), 0x1D43E => array(0x6B), 0x1D43F => array(0x6C), 0x1D440 => array(0x6D), 0x1D441 => array(0x6E), 0x1D442 => array(0x6F), 0x1D443 => array(0x70), 0x1D444 => array(0x71), 0x1D445 => array(0x72), 0x1D446 => array(0x73), 0x1D447 => array(0x74), 0x1D448 => array(0x75), 0x1D449 => array(0x76), 0x1D44A => array(0x77), 0x1D44B => array(0x78), 0x1D44C => array(0x79), 0x1D44D => array(0x7A), 0x1D468 => array(0x61), 0x1D469 => array(0x62), 0x1D46A => array(0x63), 0x1D46B => array(0x64), 0x1D46C => array(0x65), 0x1D46D => array(0x66), 0x1D46E => array(0x67), 0x1D46F => array(0x68), 0x1D470 => array(0x69), 0x1D471 => array(0x6A), 0x1D472 => array(0x6B), 0x1D473 => array(0x6C), 0x1D474 => array(0x6D), 0x1D475 => array(0x6E), 0x1D476 => array(0x6F), 0x1D477 => array(0x70), 0x1D478 => array(0x71), 0x1D479 => array(0x72), 0x1D47A => array(0x73), 0x1D47B => array(0x74), 0x1D47C => array(0x75), 0x1D47D => array(0x76), 0x1D47E => array(0x77), 0x1D47F => array(0x78), 0x1D480 => array(0x79), 0x1D481 => array(0x7A), 0x1D49C => array(0x61), 0x1D49E => array(0x63), 0x1D49F => array(0x64), 0x1D4A2 => array(0x67), 0x1D4A5 => array(0x6A), 0x1D4A6 => array(0x6B), 0x1D4A9 => array(0x6E), 0x1D4AA => array(0x6F), 0x1D4AB => array(0x70), 0x1D4AC => array(0x71), 0x1D4AE => array(0x73), 0x1D4AF => array(0x74), 0x1D4B0 => array(0x75), 0x1D4B1 => array(0x76), 0x1D4B2 => array(0x77), 0x1D4B3 => array(0x78), 0x1D4B4 => array(0x79), 0x1D4B5 => array(0x7A), 0x1D4D0 => array(0x61), 0x1D4D1 => array(0x62), 0x1D4D2 => array(0x63), 0x1D4D3 => array(0x64), 0x1D4D4 => array(0x65), 0x1D4D5 => array(0x66), 0x1D4D6 => array(0x67), 0x1D4D7 => array(0x68), 0x1D4D8 => array(0x69), 0x1D4D9 => array(0x6A), 0x1D4DA => array(0x6B), 0x1D4DB => array(0x6C), 0x1D4DC => array(0x6D), 0x1D4DD => array(0x6E), 0x1D4DE => array(0x6F), 0x1D4DF => array(0x70), 0x1D4E0 => array(0x71), 0x1D4E1 => array(0x72), 0x1D4E2 => array(0x73), 0x1D4E3 => array(0x74), 0x1D4E4 => array(0x75), 0x1D4E5 => array(0x76), 0x1D4E6 => array(0x77), 0x1D4E7 => array(0x78), 0x1D4E8 => array(0x79), 0x1D4E9 => array(0x7A), 0x1D504 => array(0x61), 0x1D505 => array(0x62), 0x1D507 => array(0x64), 0x1D508 => array(0x65), 0x1D509 => array(0x66), 0x1D50A => array(0x67), 0x1D50D => array(0x6A), 0x1D50E => array(0x6B), 0x1D50F => array(0x6C), 0x1D510 => array(0x6D), 0x1D511 => array(0x6E), 0x1D512 => array(0x6F), 0x1D513 => array(0x70), 0x1D514 => array(0x71), 0x1D516 => array(0x73), 0x1D517 => array(0x74), 0x1D518 => array(0x75), 0x1D519 => array(0x76), 0x1D51A => array(0x77), 0x1D51B => array(0x78), 0x1D51C => array(0x79), 0x1D538 => array(0x61), 0x1D539 => array(0x62), 0x1D53B => array(0x64), 0x1D53C => array(0x65), 0x1D53D => array(0x66), 0x1D53E => array(0x67), 0x1D540 => array(0x69), 0x1D541 => array(0x6A), 0x1D542 => array(0x6B), 0x1D543 => array(0x6C), 0x1D544 => array(0x6D), 0x1D546 => array(0x6F), 0x1D54A => array(0x73), 0x1D54B => array(0x74), 0x1D54C => array(0x75), 0x1D54D => array(0x76), 0x1D54E => array(0x77), 0x1D54F => array(0x78), 0x1D550 => array(0x79), 0x1D56C => array(0x61), 0x1D56D => array(0x62), 0x1D56E => array(0x63), 0x1D56F => array(0x64), 0x1D570 => array(0x65), 0x1D571 => array(0x66), 0x1D572 => array(0x67), 0x1D573 => array(0x68), 0x1D574 => array(0x69), 0x1D575 => array(0x6A), 0x1D576 => array(0x6B), 0x1D577 => array(0x6C), 0x1D578 => array(0x6D), 0x1D579 => array(0x6E), 0x1D57A => array(0x6F), 0x1D57B => array(0x70), 0x1D57C => array(0x71), 0x1D57D => array(0x72), 0x1D57E => array(0x73), 0x1D57F => array(0x74), 0x1D580 => array(0x75), 0x1D581 => array(0x76), 0x1D582 => array(0x77), 0x1D583 => array(0x78), 0x1D584 => array(0x79), 0x1D585 => array(0x7A), 0x1D5A0 => array(0x61), 0x1D5A1 => array(0x62), 0x1D5A2 => array(0x63), 0x1D5A3 => array(0x64), 0x1D5A4 => array(0x65), 0x1D5A5 => array(0x66), 0x1D5A6 => array(0x67), 0x1D5A7 => array(0x68), 0x1D5A8 => array(0x69), 0x1D5A9 => array(0x6A), 0x1D5AA => array(0x6B), 0x1D5AB => array(0x6C), 0x1D5AC => array(0x6D), 0x1D5AD => array(0x6E), 0x1D5AE => array(0x6F), 0x1D5AF => array(0x70), 0x1D5B0 => array(0x71), 0x1D5B1 => array(0x72), 0x1D5B2 => array(0x73), 0x1D5B3 => array(0x74), 0x1D5B4 => array(0x75), 0x1D5B5 => array(0x76), 0x1D5B6 => array(0x77), 0x1D5B7 => array(0x78), 0x1D5B8 => array(0x79), 0x1D5B9 => array(0x7A), 0x1D5D4 => array(0x61), 0x1D5D5 => array(0x62), 0x1D5D6 => array(0x63), 0x1D5D7 => array(0x64), 0x1D5D8 => array(0x65), 0x1D5D9 => array(0x66), 0x1D5DA => array(0x67), 0x1D5DB => array(0x68), 0x1D5DC => array(0x69), 0x1D5DD => array(0x6A), 0x1D5DE => array(0x6B), 0x1D5DF => array(0x6C), 0x1D5E0 => array(0x6D), 0x1D5E1 => array(0x6E), 0x1D5E2 => array(0x6F), 0x1D5E3 => array(0x70), 0x1D5E4 => array(0x71), 0x1D5E5 => array(0x72), 0x1D5E6 => array(0x73), 0x1D5E7 => array(0x74), 0x1D5E8 => array(0x75), 0x1D5E9 => array(0x76), 0x1D5EA => array(0x77), 0x1D5EB => array(0x78), 0x1D5EC => array(0x79), 0x1D5ED => array(0x7A), 0x1D608 => array(0x61), 0x1D609 => array(0x62), 0x1D60A => array(0x63), 0x1D60B => array(0x64), 0x1D60C => array(0x65), 0x1D60D => array(0x66), 0x1D60E => array(0x67), 0x1D60F => array(0x68), 0x1D610 => array(0x69), 0x1D611 => array(0x6A), 0x1D612 => array(0x6B), 0x1D613 => array(0x6C), 0x1D614 => array(0x6D), 0x1D615 => array(0x6E), 0x1D616 => array(0x6F), 0x1D617 => array(0x70), 0x1D618 => array(0x71), 0x1D619 => array(0x72), 0x1D61A => array(0x73), 0x1D61B => array(0x74), 0x1D61C => array(0x75), 0x1D61D => array(0x76), 0x1D61E => array(0x77), 0x1D61F => array(0x78), 0x1D620 => array(0x79), 0x1D621 => array(0x7A), 0x1D63C => array(0x61), 0x1D63D => array(0x62), 0x1D63E => array(0x63), 0x1D63F => array(0x64), 0x1D640 => array(0x65), 0x1D641 => array(0x66), 0x1D642 => array(0x67), 0x1D643 => array(0x68), 0x1D644 => array(0x69), 0x1D645 => array(0x6A), 0x1D646 => array(0x6B), 0x1D647 => array(0x6C), 0x1D648 => array(0x6D), 0x1D649 => array(0x6E), 0x1D64A => array(0x6F), 0x1D64B => array(0x70), 0x1D64C => array(0x71), 0x1D64D => array(0x72), 0x1D64E => array(0x73), 0x1D64F => array(0x74), 0x1D650 => array(0x75), 0x1D651 => array(0x76), 0x1D652 => array(0x77), 0x1D653 => array(0x78), 0x1D654 => array(0x79), 0x1D655 => array(0x7A), 0x1D670 => array(0x61), 0x1D671 => array(0x62), 0x1D672 => array(0x63), 0x1D673 => array(0x64), 0x1D674 => array(0x65), 0x1D675 => array(0x66), 0x1D676 => array(0x67), 0x1D677 => array(0x68), 0x1D678 => array(0x69), 0x1D679 => array(0x6A), 0x1D67A => array(0x6B), 0x1D67B => array(0x6C), 0x1D67C => array(0x6D), 0x1D67D => array(0x6E), 0x1D67E => array(0x6F), 0x1D67F => array(0x70), 0x1D680 => array(0x71), 0x1D681 => array(0x72), 0x1D682 => array(0x73), 0x1D683 => array(0x74), 0x1D684 => array(0x75), 0x1D685 => array(0x76), 0x1D686 => array(0x77), 0x1D687 => array(0x78), 0x1D688 => array(0x79), 0x1D689 => array(0x7A), 0x1D6A8 => array(0x3B1), 0x1D6A9 => array(0x3B2), 0x1D6AA => array(0x3B3), 0x1D6AB => array(0x3B4), 0x1D6AC => array(0x3B5), 0x1D6AD => array(0x3B6), 0x1D6AE => array(0x3B7), 0x1D6AF => array(0x3B8), 0x1D6B0 => array(0x3B9), 0x1D6B1 => array(0x3BA), 0x1D6B2 => array(0x3BB), 0x1D6B3 => array(0x3BC), 0x1D6B4 => array(0x3BD), 0x1D6B5 => array(0x3BE), 0x1D6B6 => array(0x3BF), 0x1D6B7 => array(0x3C0), 0x1D6B8 => array(0x3C1), 0x1D6B9 => array(0x3B8), 0x1D6BA => array(0x3C3), 0x1D6BB => array(0x3C4), 0x1D6BC => array(0x3C5), 0x1D6BD => array(0x3C6), 0x1D6BE => array(0x3C7), 0x1D6BF => array(0x3C8), 0x1D6C0 => array(0x3C9), 0x1D6D3 => array(0x3C3), 0x1D6E2 => array(0x3B1), 0x1D6E3 => array(0x3B2), 0x1D6E4 => array(0x3B3), 0x1D6E5 => array(0x3B4), 0x1D6E6 => array(0x3B5), 0x1D6E7 => array(0x3B6), 0x1D6E8 => array(0x3B7), 0x1D6E9 => array(0x3B8), 0x1D6EA => array(0x3B9), 0x1D6EB => array(0x3BA), 0x1D6EC => array(0x3BB), 0x1D6ED => array(0x3BC), 0x1D6EE => array(0x3BD), 0x1D6EF => array(0x3BE), 0x1D6F0 => array(0x3BF), 0x1D6F1 => array(0x3C0), 0x1D6F2 => array(0x3C1), 0x1D6F3 => array(0x3B8), 0x1D6F4 => array(0x3C3), 0x1D6F5 => array(0x3C4), 0x1D6F6 => array(0x3C5), 0x1D6F7 => array(0x3C6), 0x1D6F8 => array(0x3C7), 0x1D6F9 => array(0x3C8), 0x1D6FA => array(0x3C9), 0x1D70D => array(0x3C3), 0x1D71C => array(0x3B1), 0x1D71D => array(0x3B2), 0x1D71E => array(0x3B3), 0x1D71F => array(0x3B4), 0x1D720 => array(0x3B5), 0x1D721 => array(0x3B6), 0x1D722 => array(0x3B7), 0x1D723 => array(0x3B8), 0x1D724 => array(0x3B9), 0x1D725 => array(0x3BA), 0x1D726 => array(0x3BB), 0x1D727 => array(0x3BC), 0x1D728 => array(0x3BD), 0x1D729 => array(0x3BE), 0x1D72A => array(0x3BF), 0x1D72B => array(0x3C0), 0x1D72C => array(0x3C1), 0x1D72D => array(0x3B8), 0x1D72E => array(0x3C3), 0x1D72F => array(0x3C4), 0x1D730 => array(0x3C5), 0x1D731 => array(0x3C6), 0x1D732 => array(0x3C7), 0x1D733 => array(0x3C8), 0x1D734 => array(0x3C9), 0x1D747 => array(0x3C3), 0x1D756 => array(0x3B1), 0x1D757 => array(0x3B2), 0x1D758 => array(0x3B3), 0x1D759 => array(0x3B4), 0x1D75A => array(0x3B5), 0x1D75B => array(0x3B6), 0x1D75C => array(0x3B7), 0x1D75D => array(0x3B8), 0x1D75E => array(0x3B9), 0x1D75F => array(0x3BA), 0x1D760 => array(0x3BB), 0x1D761 => array(0x3BC), 0x1D762 => array(0x3BD), 0x1D763 => array(0x3BE), 0x1D764 => array(0x3BF), 0x1D765 => array(0x3C0), 0x1D766 => array(0x3C1), 0x1D767 => array(0x3B8), 0x1D768 => array(0x3C3), 0x1D769 => array(0x3C4), 0x1D76A => array(0x3C5), 0x1D76B => array(0x3C6), 0x1D76C => array(0x3C7), 0x1D76D => array(0x3C8), 0x1D76E => array(0x3C9), 0x1D781 => array(0x3C3), 0x1D790 => array(0x3B1), 0x1D791 => array(0x3B2), 0x1D792 => array(0x3B3), 0x1D793 => array(0x3B4), 0x1D794 => array(0x3B5), 0x1D795 => array(0x3B6), 0x1D796 => array(0x3B7), 0x1D797 => array(0x3B8), 0x1D798 => array(0x3B9), 0x1D799 => array(0x3BA), 0x1D79A => array(0x3BB), 0x1D79B => array(0x3BC), 0x1D79C => array(0x3BD), 0x1D79D => array(0x3BE), 0x1D79E => array(0x3BF), 0x1D79F => array(0x3C0), 0x1D7A0 => array(0x3C1), 0x1D7A1 => array(0x3B8), 0x1D7A2 => array(0x3C3), 0x1D7A3 => array(0x3C4), 0x1D7A4 => array(0x3C5), 0x1D7A5 => array(0x3C6), 0x1D7A6 => array(0x3C7), 0x1D7A7 => array(0x3C8), 0x1D7A8 => array(0x3C9), 0x1D7BB => array(0x3C3), 0x3F9 => array(0x3C3), 0x1D2C => array(0x61), 0x1D2D => array(0xE6), 0x1D2E => array(0x62), 0x1D30 => array(0x64), 0x1D31 => array(0x65), 0x1D32 => array(0x1DD), 0x1D33 => array(0x67), 0x1D34 => array(0x68), 0x1D35 => array(0x69), 0x1D36 => array(0x6A), 0x1D37 => array(0x6B), 0x1D38 => array(0x6C), 0x1D39 => array(0x6D), 0x1D3A => array(0x6E), 0x1D3C => array(0x6F), 0x1D3D => array(0x223), 0x1D3E => array(0x70), 0x1D3F => array(0x72), 0x1D40 => array(0x74), 0x1D41 => array(0x75), 0x1D42 => array(0x77), 0x213B => array(0x66, 0x61, 0x78), 0x3250 => array(0x70, 0x74, 0x65), 0x32CC => array(0x68, 0x67), 0x32CE => array(0x65, 0x76), 0x32CF => array(0x6C, 0x74, 0x64), 0x337A => array(0x69, 0x75), 0x33DE => array(0x76, 0x2215, 0x6D), 0x33DF => array(0x61, 0x2215, 0x6D) ); /** * Normalization Combining Classes; Code Points not listed * got Combining Class 0. * * @static * @var array * @access private */ private static $_np_norm_combcls = array( 0x334 => 1, 0x335 => 1, 0x336 => 1, 0x337 => 1, 0x338 => 1, 0x93C => 7, 0x9BC => 7, 0xA3C => 7, 0xABC => 7, 0xB3C => 7, 0xCBC => 7, 0x1037 => 7, 0x3099 => 8, 0x309A => 8, 0x94D => 9, 0x9CD => 9, 0xA4D => 9, 0xACD => 9, 0xB4D => 9, 0xBCD => 9, 0xC4D => 9, 0xCCD => 9, 0xD4D => 9, 0xDCA => 9, 0xE3A => 9, 0xF84 => 9, 0x1039 => 9, 0x1714 => 9, 0x1734 => 9, 0x17D2 => 9, 0x5B0 => 10, 0x5B1 => 11, 0x5B2 => 12, 0x5B3 => 13, 0x5B4 => 14, 0x5B5 => 15, 0x5B6 => 16, 0x5B7 => 17, 0x5B8 => 18, 0x5B9 => 19, 0x5BB => 20, 0x5Bc => 21, 0x5BD => 22, 0x5BF => 23, 0x5C1 => 24, 0x5C2 => 25, 0xFB1E => 26, 0x64B => 27, 0x64C => 28, 0x64D => 29, 0x64E => 30, 0x64F => 31, 0x650 => 32, 0x651 => 33, 0x652 => 34, 0x670 => 35, 0x711 => 36, 0xC55 => 84, 0xC56 => 91, 0xE38 => 103, 0xE39 => 103, 0xE48 => 107, 0xE49 => 107, 0xE4A => 107, 0xE4B => 107, 0xEB8 => 118, 0xEB9 => 118, 0xEC8 => 122, 0xEC9 => 122, 0xECA => 122, 0xECB => 122, 0xF71 => 129, 0xF72 => 130, 0xF7A => 130, 0xF7B => 130, 0xF7C => 130, 0xF7D => 130, 0xF80 => 130, 0xF74 => 132, 0x321 => 202, 0x322 => 202, 0x327 => 202, 0x328 => 202, 0x31B => 216, 0xF39 => 216, 0x1D165 => 216, 0x1D166 => 216, 0x1D16E => 216, 0x1D16F => 216, 0x1D170 => 216, 0x1D171 => 216, 0x1D172 => 216, 0x302A => 218, 0x316 => 220, 0x317 => 220, 0x318 => 220, 0x319 => 220, 0x31C => 220, 0x31D => 220, 0x31E => 220, 0x31F => 220, 0x320 => 220, 0x323 => 220, 0x324 => 220, 0x325 => 220, 0x326 => 220, 0x329 => 220, 0x32A => 220, 0x32B => 220, 0x32C => 220, 0x32D => 220, 0x32E => 220, 0x32F => 220, 0x330 => 220, 0x331 => 220, 0x332 => 220, 0x333 => 220, 0x339 => 220, 0x33A => 220, 0x33B => 220, 0x33C => 220, 0x347 => 220, 0x348 => 220, 0x349 => 220, 0x34D => 220, 0x34E => 220, 0x353 => 220, 0x354 => 220, 0x355 => 220, 0x356 => 220, 0x591 => 220, 0x596 => 220, 0x59B => 220, 0x5A3 => 220, 0x5A4 => 220, 0x5A5 => 220, 0x5A6 => 220, 0x5A7 => 220, 0x5AA => 220, 0x655 => 220, 0x656 => 220, 0x6E3 => 220, 0x6EA => 220, 0x6ED => 220, 0x731 => 220, 0x734 => 220, 0x737 => 220, 0x738 => 220, 0x739 => 220, 0x73B => 220, 0x73C => 220, 0x73E => 220, 0x742 => 220, 0x744 => 220, 0x746 => 220, 0x748 => 220, 0x952 => 220, 0xF18 => 220, 0xF19 => 220, 0xF35 => 220, 0xF37 => 220, 0xFC6 => 220, 0x193B => 220, 0x20E8 => 220, 0x1D17B => 220, 0x1D17C => 220, 0x1D17D => 220, 0x1D17E => 220, 0x1D17F => 220, 0x1D180 => 220, 0x1D181 => 220, 0x1D182 => 220, 0x1D18A => 220, 0x1D18B => 220, 0x59A => 222, 0x5AD => 222, 0x1929 => 222, 0x302D => 222, 0x302E => 224, 0x302F => 224, 0x1D16D => 226, 0x5AE => 228, 0x18A9 => 228, 0x302B => 228, 0x300 => 230, 0x301 => 230, 0x302 => 230, 0x303 => 230, 0x304 => 230, 0x305 => 230, 0x306 => 230, 0x307 => 230, 0x308 => 230, 0x309 => 230, 0x30A => 230, 0x30B => 230, 0x30C => 230, 0x30D => 230, 0x30E => 230, 0x30F => 230, 0x310 => 230, 0x311 => 230, 0x312 => 230, 0x313 => 230, 0x314 => 230, 0x33D => 230, 0x33E => 230, 0x33F => 230, 0x340 => 230, 0x341 => 230, 0x342 => 230, 0x343 => 230, 0x344 => 230, 0x346 => 230, 0x34A => 230, 0x34B => 230, 0x34C => 230, 0x350 => 230, 0x351 => 230, 0x352 => 230, 0x357 => 230, 0x363 => 230, 0x364 => 230, 0x365 => 230, 0x366 => 230, 0x367 => 230, 0x368 => 230, 0x369 => 230, 0x36A => 230, 0x36B => 230, 0x36C => 230, 0x36D => 230, 0x36E => 230, 0x36F => 230, 0x483 => 230, 0x484 => 230, 0x485 => 230, 0x486 => 230, 0x592 => 230, 0x593 => 230, 0x594 => 230, 0x595 => 230, 0x597 => 230, 0x598 => 230, 0x599 => 230, 0x59C => 230, 0x59D => 230, 0x59E => 230, 0x59F => 230, 0x5A0 => 230, 0x5A1 => 230, 0x5A8 => 230, 0x5A9 => 230, 0x5AB => 230, 0x5AC => 230, 0x5AF => 230, 0x5C4 => 230, 0x610 => 230, 0x611 => 230, 0x612 => 230, 0x613 => 230, 0x614 => 230, 0x615 => 230, 0x653 => 230, 0x654 => 230, 0x657 => 230, 0x658 => 230, 0x6D6 => 230, 0x6D7 => 230, 0x6D8 => 230, 0x6D9 => 230, 0x6DA => 230, 0x6DB => 230, 0x6DC => 230, 0x6DF => 230, 0x6E0 => 230, 0x6E1 => 230, 0x6E2 => 230, 0x6E4 => 230, 0x6E7 => 230, 0x6E8 => 230, 0x6EB => 230, 0x6EC => 230, 0x730 => 230, 0x732 => 230, 0x733 => 230, 0x735 => 230, 0x736 => 230, 0x73A => 230, 0x73D => 230, 0x73F => 230, 0x740 => 230, 0x741 => 230, 0x743 => 230, 0x745 => 230, 0x747 => 230, 0x749 => 230, 0x74A => 230, 0x951 => 230, 0x953 => 230, 0x954 => 230, 0xF82 => 230, 0xF83 => 230, 0xF86 => 230, 0xF87 => 230, 0x170D => 230, 0x193A => 230, 0x20D0 => 230, 0x20D1 => 230, 0x20D4 => 230, 0x20D5 => 230, 0x20D6 => 230, 0x20D7 => 230, 0x20DB => 230, 0x20DC => 230, 0x20E1 => 230, 0x20E7 => 230, 0x20E9 => 230, 0xFE20 => 230, 0xFE21 => 230, 0xFE22 => 230, 0xFE23 => 230, 0x1D185 => 230, 0x1D186 => 230, 0x1D187 => 230, 0x1D189 => 230, 0x1D188 => 230, 0x1D1AA => 230, 0x1D1AB => 230, 0x1D1AC => 230, 0x1D1AD => 230, 0x315 => 232, 0x31A => 232, 0x302C => 232, 0x35F => 233, 0x362 => 233, 0x35D => 234, 0x35E => 234, 0x360 => 234, 0x361 => 234, 0x345 => 240 ); // }}} // {{{ properties /** * @var string * @access private */ private $_punycode_prefix = 'xn--'; /** * @access private */ private $_invalid_ucs = 0x80000000; /** * @access private */ private $_max_ucs = 0x10FFFF; /** * @var int * @access private */ private $_base = 36; /** * @var int * @access private */ private $_tmin = 1; /** * @var int * @access private */ private $_tmax = 26; /** * @var int * @access private */ private $_skew = 38; /** * @var int * @access private */ private $_damp = 700; /** * @var int * @access private */ private $_initial_bias = 72; /** * @var int * @access private */ private $_initial_n = 0x80; /** * @var int * @access private */ private $_slast; /** * @access private */ private $_sbase = 0xAC00; /** * @access private */ private $_lbase = 0x1100; /** * @access private */ private $_vbase = 0x1161; /** * @access private */ private $_tbase = 0x11a7; /** * @var int * @access private */ private $_lcount = 19; /** * @var int * @access private */ private $_vcount = 21; /** * @var int * @access private */ private $_tcount = 28; /** * vcount * tcount * * @var int * @access private */ private $_ncount = 588; /** * lcount * tcount * vcount * * @var int * @access private */ private $_scount = 11172; /** * Default encoding for encode()'s input and decode()'s output is UTF-8; * Other possible encodings are ucs4_string and ucs4_array * See {@link setParams()} for how to select these * * @var bool * @access private */ private $_api_encoding = 'utf8'; /** * Overlong UTF-8 encodings are forbidden * * @var bool * @access private */ private $_allow_overlong = false; /** * Behave strict or not * * @var bool * @access private */ private $_strict_mode = false; /** * IDNA-version to use * * Values are "2003" and "2008". * Defaults to "2003", since that was the original version and for * compatibility with previous versions of this library. * If you need to encode "new" characters like the German "Eszett", * please switch to 2008 first before encoding. * * @var bool * @access private */ private $_version = '2003'; /** * Cached value indicating whether or not mbstring function overloading is * on for strlen * * This is cached for optimal performance. * * @var boolean * @see Net_IDNA2::_byteLength() */ private static $_mb_string_overload = null; // }}} // {{{ constructor /** * Constructor * * @param array $options Options to initialise the object with * * @access public * @see setParams() */ public function __construct($options = null) { $this->_slast = $this->_sbase + $this->_lcount * $this->_vcount * $this->_tcount; if (is_array($options)) { $this->setParams($options); } // populate mbstring overloading cache if not set if (self::$_mb_string_overload === null) { self::$_mb_string_overload = (extension_loaded('mbstring') && (ini_get('mbstring.func_overload') & 0x02) === 0x02); } } // }}} /** * Sets a new option value. Available options and values: * * [utf8 - Use either UTF-8 or ISO-8859-1 as input (true for UTF-8, false * otherwise); The output is always UTF-8] * [overlong - Unicode does not allow unnecessarily long encodings of chars, * to allow this, set this parameter to true, else to false; * default is false.] * [strict - true: strict mode, good for registration purposes - Causes errors * on failures; false: loose mode, ideal for "wildlife" applications * by silently ignoring errors and returning the original input instead] * * @param mixed $option Parameter to set (string: single parameter; array of Parameter => Value pairs) * @param string $value Value to use (if parameter 1 is a string) * * @return boolean true on success, false otherwise * @access public */ public function setParams($option, $value = false) { if (!is_array($option)) { $option = array($option => $value); } foreach ($option as $k => $v) { switch ($k) { case 'encoding': switch ($v) { case 'utf8': case 'ucs4_string': case 'ucs4_array': $this->_api_encoding = $v; break; default: throw new InvalidArgumentException('Set Parameter: Unknown parameter '.$v.' for option '.$k); } break; case 'overlong': $this->_allow_overlong = ($v) ? true : false; break; case 'strict': $this->_strict_mode = ($v) ? true : false; break; case 'version': if (in_array($v, array('2003', '2008'))) { $this->_version = $v; } else { throw new InvalidArgumentException('Set Parameter: Invalid parameter '.$v.' for option '.$k); } break; default: return false; } } return true; } /** * Encode a given UTF-8 domain name. * * @param string $decoded Domain name (UTF-8 or UCS-4) * @param string $one_time_encoding Desired input encoding, see {@link set_parameter} * If not given will use default-encoding * * @return string Encoded Domain name (ACE string) * @return mixed processed string * @throws Exception * @access public */ public function encode($decoded, $one_time_encoding = false) { // Forcing conversion of input to UCS4 array // If one time encoding is given, use this, else the objects property switch (($one_time_encoding) ? $one_time_encoding : $this->_api_encoding) { case 'utf8': $decoded = $this->_utf8_to_ucs4($decoded); break; case 'ucs4_string': $decoded = $this->_ucs4_string_to_ucs4($decoded); case 'ucs4_array': // No break; before this line. Catch case, but do nothing break; default: throw new InvalidArgumentException('Unsupported input format'); } // No input, no output, what else did you expect? if (empty($decoded)) return ''; // Anchors for iteration $last_begin = 0; // Output string $output = ''; foreach ($decoded as $k => $v) { // Make sure to use just the plain dot switch($v) { case 0x3002: case 0xFF0E: case 0xFF61: $decoded[$k] = 0x2E; // It's right, no break here // The codepoints above have to be converted to dots anyway // Stumbling across an anchoring character case 0x2E: case 0x2F: case 0x3A: case 0x3F: case 0x40: // Neither email addresses nor URLs allowed in strict mode if ($this->_strict_mode) { throw new InvalidArgumentException('Neither email addresses nor URLs are allowed in strict mode.'); } // Skip first char if ($k) { $encoded = ''; $encoded = $this->_encode(array_slice($decoded, $last_begin, (($k)-$last_begin))); if ($encoded) { $output .= $encoded; } else { $output .= $this->_ucs4_to_utf8(array_slice($decoded, $last_begin, (($k)-$last_begin))); } $output .= chr($decoded[$k]); } $last_begin = $k + 1; } } // Catch the rest of the string if ($last_begin) { $inp_len = sizeof($decoded); $encoded = ''; $encoded = $this->_encode(array_slice($decoded, $last_begin, (($inp_len)-$last_begin))); if ($encoded) { $output .= $encoded; } else { $output .= $this->_ucs4_to_utf8(array_slice($decoded, $last_begin, (($inp_len)-$last_begin))); } return $output; } if ($output = $this->_encode($decoded)) { return $output; } return $this->_ucs4_to_utf8($decoded); } /** * Decode a given ACE domain name. * * @param string $input Domain name (ACE string) * @param string $one_time_encoding Desired output encoding, see {@link set_parameter} * * @return string Decoded Domain name (UTF-8 or UCS-4) * @throws Exception * @access public */ public function decode($input, $one_time_encoding = false) { // Optionally set if ($one_time_encoding) { switch ($one_time_encoding) { case 'utf8': case 'ucs4_string': case 'ucs4_array': break; default: throw new InvalidArgumentException('Unknown encoding '.$one_time_encoding); } } // Make sure to drop any newline characters around $input = trim($input); // Negotiate input and try to determine, whether it is a plain string, // an email address or something like a complete URL if (strpos($input, '@')) { // Maybe it is an email address // No no in strict mode if ($this->_strict_mode) { throw new InvalidArgumentException('Only simple domain name parts can be handled in strict mode'); } list($email_pref, $input) = explode('@', $input, 2); $arr = explode('.', $input); foreach ($arr as $k => $v) { $conv = $this->_decode($v); if ($conv) $arr[$k] = $conv; } $return = $email_pref . '@' . join('.', $arr); } elseif (preg_match('![:\./]!', $input)) { // Or a complete domain name (with or without paths / parameters) // No no in strict mode if ($this->_strict_mode) { throw new InvalidArgumentException('Only simple domain name parts can be handled in strict mode'); } $parsed = parse_url($input); if (isset($parsed['host'])) { $arr = explode('.', $parsed['host']); foreach ($arr as $k => $v) { $conv = $this->_decode($v); if ($conv) $arr[$k] = $conv; } $parsed['host'] = join('.', $arr); if (isset($parsed['scheme'])) { $parsed['scheme'] .= (strtolower($parsed['scheme']) == 'mailto') ? ':' : '://'; } $return = $this->_unparse_url($parsed); } else { // parse_url seems to have failed, try without it $arr = explode('.', $input); foreach ($arr as $k => $v) { $conv = $this->_decode($v); if ($conv) $arr[$k] = $conv; } $return = join('.', $arr); } } else { // Otherwise we consider it being a pure domain name string $return = $this->_decode($input); } // The output is UTF-8 by default, other output formats need conversion here // If one time encoding is given, use this, else the objects property switch (($one_time_encoding) ? $one_time_encoding : $this->_api_encoding) { case 'utf8': return $return; break; case 'ucs4_string': return $this->_ucs4_to_ucs4_string($this->_utf8_to_ucs4($return)); break; case 'ucs4_array': return $this->_utf8_to_ucs4($return); break; default: throw new InvalidArgumentException('Unsupported output format'); } } // {{{ private /** * Opposite function to parse_url() * * Inspired by code from comments of php.net-documentation for parse_url() * * @param array $parts_arr parts (strings) as returned by parse_url() * * @return string * @access private */ private function _unparse_url($parts_arr) { if (!empty($parts_arr['scheme'])) { $ret_url = $parts_arr['scheme']; } if (!empty($parts_arr['user'])) { $ret_url .= $parts_arr['user']; if (!empty($parts_arr['pass'])) { $ret_url .= ':' . $parts_arr['pass']; } $ret_url .= '@'; } $ret_url .= $parts_arr['host']; if (!empty($parts_arr['port'])) { $ret_url .= ':' . $parts_arr['port']; } $ret_url .= $parts_arr['path']; if (!empty($parts_arr['query'])) { $ret_url .= '?' . $parts_arr['query']; } if (!empty($parts_arr['fragment'])) { $ret_url .= '#' . $parts_arr['fragment']; } return $ret_url; } /** * The actual encoding algorithm. * * @param string $decoded Decoded string which should be encoded * * @return string Encoded string * @throws Exception * @access private */ private function _encode($decoded) { // We cannot encode a domain name containing the Punycode prefix $extract = self::_byteLength($this->_punycode_prefix); $check_pref = $this->_utf8_to_ucs4($this->_punycode_prefix); $check_deco = array_slice($decoded, 0, $extract); if ($check_pref == $check_deco) { throw new InvalidArgumentException('This is already a punycode string'); } // We will not try to encode strings consisting of basic code points only $encodable = false; foreach ($decoded as $k => $v) { if ($v > 0x7a) { $encodable = true; break; } } if (!$encodable) { if ($this->_strict_mode) { throw new InvalidArgumentException('The given string does not contain encodable chars'); } return false; } // Do NAMEPREP $decoded = $this->_nameprep($decoded); $deco_len = count($decoded); // Empty array if (!$deco_len) { return false; } // How many chars have been consumed $codecount = 0; // Start with the prefix; copy it to output $encoded = $this->_punycode_prefix; $encoded = ''; // Copy all basic code points to output for ($i = 0; $i < $deco_len; ++$i) { $test = $decoded[$i]; // Will match [0-9a-zA-Z-] if ((0x2F < $test && $test < 0x40) || (0x40 < $test && $test < 0x5B) || (0x60 < $test && $test <= 0x7B) || (0x2D == $test) ) { $encoded .= chr($decoded[$i]); $codecount++; } } // All codepoints were basic ones if ($codecount == $deco_len) { return $encoded; } // Start with the prefix; copy it to output $encoded = $this->_punycode_prefix . $encoded; // If we have basic code points in output, add an hyphen to the end if ($codecount) { $encoded .= '-'; } // Now find and encode all non-basic code points $is_first = true; $cur_code = $this->_initial_n; $bias = $this->_initial_bias; $delta = 0; while ($codecount < $deco_len) { // Find the smallest code point >= the current code point and // remember the last ouccrence of it in the input for ($i = 0, $next_code = $this->_max_ucs; $i < $deco_len; $i++) { if ($decoded[$i] >= $cur_code && $decoded[$i] <= $next_code) { $next_code = $decoded[$i]; } } $delta += ($next_code - $cur_code) * ($codecount + 1); $cur_code = $next_code; // Scan input again and encode all characters whose code point is $cur_code for ($i = 0; $i < $deco_len; $i++) { if ($decoded[$i] < $cur_code) { $delta++; } else if ($decoded[$i] == $cur_code) { for ($q = $delta, $k = $this->_base; 1; $k += $this->_base) { $t = ($k <= $bias)? $this->_tmin : (($k >= $bias + $this->_tmax)? $this->_tmax : $k - $bias); if ($q < $t) { break; } $encoded .= $this->_encodeDigit(ceil($t + (($q - $t) % ($this->_base - $t)))); $q = ($q - $t) / ($this->_base - $t); } $encoded .= $this->_encodeDigit($q); $bias = $this->_adapt($delta, $codecount + 1, $is_first); $codecount++; $delta = 0; $is_first = false; } } $delta++; $cur_code++; } return $encoded; } /** * The actual decoding algorithm. * * @param string $encoded Encoded string which should be decoded * * @return string Decoded string * @throws Exception * @access private */ private function _decode($encoded) { // We do need to find the Punycode prefix if (!preg_match('!^' . preg_quote($this->_punycode_prefix, '!') . '!', $encoded)) { return false; } $encode_test = preg_replace('!^' . preg_quote($this->_punycode_prefix, '!') . '!', '', $encoded); // If nothing left after removing the prefix, it is hopeless if (!$encode_test) { return false; } // Find last occurrence of the delimiter $delim_pos = strrpos($encoded, '-'); if ($delim_pos > self::_byteLength($this->_punycode_prefix)) { for ($k = self::_byteLength($this->_punycode_prefix); $k < $delim_pos; ++$k) { $decoded[] = ord($encoded{$k}); } } else { $decoded = array(); } $deco_len = count($decoded); $enco_len = self::_byteLength($encoded); // Wandering through the strings; init $is_first = true; $bias = $this->_initial_bias; $idx = 0; $char = $this->_initial_n; for ($enco_idx = ($delim_pos)? ($delim_pos + 1) : 0; $enco_idx < $enco_len; ++$deco_len) { for ($old_idx = $idx, $w = 1, $k = $this->_base; 1 ; $k += $this->_base) { $digit = $this->_decodeDigit($encoded{$enco_idx++}); $idx += $digit * $w; $t = ($k <= $bias) ? $this->_tmin : (($k >= $bias + $this->_tmax)? $this->_tmax : ($k - $bias)); if ($digit < $t) { break; } $w = (int)($w * ($this->_base - $t)); } $bias = $this->_adapt($idx - $old_idx, $deco_len + 1, $is_first); $is_first = false; $char += (int) ($idx / ($deco_len + 1)); $idx %= ($deco_len + 1); if ($deco_len > 0) { // Make room for the decoded char for ($i = $deco_len; $i > $idx; $i--) { $decoded[$i] = $decoded[($i - 1)]; } } $decoded[$idx++] = $char; } return $this->_ucs4_to_utf8($decoded); } /** * Adapt the bias according to the current code point and position. * * @param int $delta ... * @param int $npoints ... * @param boolean $is_first ... * * @return int * @access private */ private function _adapt($delta, $npoints, $is_first) { $delta = (int) ($is_first ? ($delta / $this->_damp) : ($delta / 2)); $delta += (int) ($delta / $npoints); for ($k = 0; $delta > (($this->_base - $this->_tmin) * $this->_tmax) / 2; $k += $this->_base) { $delta = (int) ($delta / ($this->_base - $this->_tmin)); } return (int) ($k + ($this->_base - $this->_tmin + 1) * $delta / ($delta + $this->_skew)); } /** * Encoding a certain digit. * * @param int $d One digit to encode * * @return char Encoded digit * @access private */ private function _encodeDigit($d) { return chr($d + 22 + 75 * ($d < 26)); } /** * Decode a certain digit. * * @param char $cp One digit (character) to decode * * @return int Decoded digit * @access private */ private function _decodeDigit($cp) { $cp = ord($cp); return ($cp - 48 < 10)? $cp - 22 : (($cp - 65 < 26)? $cp - 65 : (($cp - 97 < 26)? $cp - 97 : $this->_base)); } /** * Do Nameprep according to RFC3491 and RFC3454. * * @param array $input Unicode Characters * * @return string Unicode Characters, Nameprep'd * @throws Exception * @access private */ private function _nameprep($input) { $output = array(); // Walking through the input array, performing the required steps on each of // the input chars and putting the result into the output array // While mapping required chars we apply the canonical ordering foreach ($input as $v) { // Map to nothing == skip that code point if (in_array($v, self::$_np_map_nothing)) { continue; } // Try to find prohibited input if (in_array($v, self::$_np_prohibit) || in_array($v, self::$_general_prohibited)) { throw new Net_IDNA2_Exception_Nameprep('Prohibited input U+' . sprintf('%08X', $v)); } foreach (self::$_np_prohibit_ranges as $range) { if ($range[0] <= $v && $v <= $range[1]) { throw new Net_IDNA2_Exception_Nameprep('Prohibited input U+' . sprintf('%08X', $v)); } } // Hangul syllable decomposition if (0xAC00 <= $v && $v <= 0xD7AF) { foreach ($this->_hangulDecompose($v) as $out) { $output[] = $out; } } else if (($this->_version == '2003') && isset(self::$_np_replacemaps[$v])) { // There's a decomposition mapping for that code point // Decompositions only in version 2003 (original) of IDNA foreach ($this->_applyCannonicalOrdering(self::$_np_replacemaps[$v]) as $out) { $output[] = $out; } } else { $output[] = $v; } } // Combine code points $last_class = 0; $last_starter = 0; $out_len = count($output); for ($i = 0; $i < $out_len; ++$i) { $class = $this->_getCombiningClass($output[$i]); if ((!$last_class || $last_class != $class) && $class) { // Try to match $seq_len = $i - $last_starter; $out = $this->_combine(array_slice($output, $last_starter, $seq_len)); // On match: Replace the last starter with the composed character and remove // the now redundant non-starter(s) if ($out) { $output[$last_starter] = $out; if (count($out) != $seq_len) { for ($j = $i + 1; $j < $out_len; ++$j) { $output[$j - 1] = $output[$j]; } unset($output[$out_len]); } // Rewind the for loop by one, since there can be more possible compositions $i--; $out_len--; $last_class = ($i == $last_starter)? 0 : $this->_getCombiningClass($output[$i - 1]); continue; } } // The current class is 0 if (!$class) { $last_starter = $i; } $last_class = $class; } return $output; } /** * Decomposes a Hangul syllable * (see http://www.unicode.org/unicode/reports/tr15/#Hangul). * * @param integer $char 32bit UCS4 code point * * @return array Either Hangul Syllable decomposed or original 32bit * value as one value array * @access private */ private function _hangulDecompose($char) { $sindex = $char - $this->_sbase; if ($sindex < 0 || $sindex >= $this->_scount) { return array($char); } $result = array(); $T = $this->_tbase + $sindex % $this->_tcount; $result[] = (int)($this->_lbase + $sindex / $this->_ncount); $result[] = (int)($this->_vbase + ($sindex % $this->_ncount) / $this->_tcount); if ($T != $this->_tbase) { $result[] = $T; } return $result; } /** * Ccomposes a Hangul syllable * (see http://www.unicode.org/unicode/reports/tr15/#Hangul). * * @param array $input Decomposed UCS4 sequence * * @return array UCS4 sequence with syllables composed * @access private */ private function _hangulCompose($input) { $inp_len = count($input); if (!$inp_len) { return array(); } $result = array(); $last = $input[0]; $result[] = $last; // copy first char from input to output for ($i = 1; $i < $inp_len; ++$i) { $char = $input[$i]; // Find out, wether two current characters from L and V $lindex = $last - $this->_lbase; if (0 <= $lindex && $lindex < $this->_lcount) { $vindex = $char - $this->_vbase; if (0 <= $vindex && $vindex < $this->_vcount) { // create syllable of form LV $last = ($this->_sbase + ($lindex * $this->_vcount + $vindex) * $this->_tcount); $out_off = count($result) - 1; $result[$out_off] = $last; // reset last // discard char continue; } } // Find out, wether two current characters are LV and T $sindex = $last - $this->_sbase; if (0 <= $sindex && $sindex < $this->_scount && ($sindex % $this->_tcount) == 0) { $tindex = $char - $this->_tbase; if (0 <= $tindex && $tindex <= $this->_tcount) { // create syllable of form LVT $last += $tindex; $out_off = count($result) - 1; $result[$out_off] = $last; // reset last // discard char continue; } } // if neither case was true, just add the character $last = $char; $result[] = $char; } return $result; } /** * Returns the combining class of a certain wide char. * * @param integer $char Wide char to check (32bit integer) * * @return integer Combining class if found, else 0 * @access private */ private function _getCombiningClass($char) { return isset(self::$_np_norm_combcls[$char])? self::$_np_norm_combcls[$char] : 0; } /** * Apllies the canonical ordering of a decomposed UCS4 sequence. * * @param array $input Decomposed UCS4 sequence * * @return array Ordered USC4 sequence * @access private */ private function _applyCannonicalOrdering($input) { $swap = true; $size = count($input); while ($swap) { $swap = false; $last = $this->_getCombiningClass($input[0]); for ($i = 0; $i < $size - 1; ++$i) { $next = $this->_getCombiningClass($input[$i + 1]); if ($next != 0 && $last > $next) { // Move item leftward until it fits for ($j = $i + 1; $j > 0; --$j) { if ($this->_getCombiningClass($input[$j - 1]) <= $next) { break; } $t = $input[$j]; $input[$j] = $input[$j - 1]; $input[$j - 1] = $t; $swap = 1; } // Reentering the loop looking at the old character again $next = $last; } $last = $next; } } return $input; } /** * Do composition of a sequence of starter and non-starter. * * @param array $input UCS4 Decomposed sequence * * @return array Ordered USC4 sequence * @access private */ private function _combine($input) { $inp_len = count($input); // Is it a Hangul syllable? if (1 != $inp_len) { $hangul = $this->_hangulCompose($input); // This place is probably wrong if (count($hangul) != $inp_len) { return $hangul; } } foreach (self::$_np_replacemaps as $np_src => $np_target) { if ($np_target[0] != $input[0]) { continue; } if (count($np_target) != $inp_len) { continue; } $hit = false; foreach ($input as $k2 => $v2) { if ($v2 == $np_target[$k2]) { $hit = true; } else { $hit = false; break; } } if ($hit) { return $np_src; } } return false; } /** * This converts an UTF-8 encoded string to its UCS-4 (array) representation * By talking about UCS-4 we mean arrays of 32bit integers representing * each of the "chars". This is due to PHP not being able to handle strings with * bit depth different from 8. This applies to the reverse method _ucs4_to_utf8(), too. * The following UTF-8 encodings are supported: * * bytes bits representation * 1 7 0xxxxxxx * 2 11 110xxxxx 10xxxxxx * 3 16 1110xxxx 10xxxxxx 10xxxxxx * 4 21 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx * 5 26 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx * 6 31 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx * * Each x represents a bit that can be used to store character data. * * @param string $input utf8-encoded string * * @return array ucs4-encoded array * @throws Exception * @access private */ private function _utf8_to_ucs4($input) { $output = array(); $out_len = 0; $inp_len = self::_byteLength($input, '8bit'); $mode = 'next'; $test = 'none'; for ($k = 0; $k < $inp_len; ++$k) { $v = ord($input{$k}); // Extract byte from input string if ($v < 128) { // We found an ASCII char - put into string as is $output[$out_len] = $v; ++$out_len; if ('add' == $mode) { throw new UnexpectedValueException('Conversion from UTF-8 to UCS-4 failed: malformed input at byte '.$k); } continue; } if ('next' == $mode) { // Try to find the next start byte; determine the width of the Unicode char $start_byte = $v; $mode = 'add'; $test = 'range'; if ($v >> 5 == 6) { // &110xxxxx 10xxxxx $next_byte = 0; // Tells, how many times subsequent bitmasks must rotate 6bits to the left $v = ($v - 192) << 6; } elseif ($v >> 4 == 14) { // &1110xxxx 10xxxxxx 10xxxxxx $next_byte = 1; $v = ($v - 224) << 12; } elseif ($v >> 3 == 30) { // &11110xxx 10xxxxxx 10xxxxxx 10xxxxxx $next_byte = 2; $v = ($v - 240) << 18; } elseif ($v >> 2 == 62) { // &111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx $next_byte = 3; $v = ($v - 248) << 24; } elseif ($v >> 1 == 126) { // &1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx $next_byte = 4; $v = ($v - 252) << 30; } else { throw new UnexpectedValueException('This might be UTF-8, but I don\'t understand it at byte '.$k); } if ('add' == $mode) { $output[$out_len] = (int) $v; ++$out_len; continue; } } if ('add' == $mode) { if (!$this->_allow_overlong && $test == 'range') { $test = 'none'; if (($v < 0xA0 && $start_byte == 0xE0) || ($v < 0x90 && $start_byte == 0xF0) || ($v > 0x8F && $start_byte == 0xF4)) { throw new OutOfRangeException('Bogus UTF-8 character detected (out of legal range) at byte '.$k); } } if ($v >> 6 == 2) { // Bit mask must be 10xxxxxx $v = ($v - 128) << ($next_byte * 6); $output[($out_len - 1)] += $v; --$next_byte; } else { throw new UnexpectedValueException('Conversion from UTF-8 to UCS-4 failed: malformed input at byte '.$k); } if ($next_byte < 0) { $mode = 'next'; } } } // for return $output; } /** * Convert UCS-4 array into UTF-8 string * * @param array $input ucs4-encoded array * * @return string utf8-encoded string * @throws Exception * @access private */ private function _ucs4_to_utf8($input) { $output = ''; foreach ($input as $v) { // $v = ord($v); if ($v < 128) { // 7bit are transferred literally $output .= chr($v); } else if ($v < 1 << 11) { // 2 bytes $output .= chr(192 + ($v >> 6)) . chr(128 + ($v & 63)); } else if ($v < 1 << 16) { // 3 bytes $output .= chr(224 + ($v >> 12)) . chr(128 + (($v >> 6) & 63)) . chr(128 + ($v & 63)); } else if ($v < 1 << 21) { // 4 bytes $output .= chr(240 + ($v >> 18)) . chr(128 + (($v >> 12) & 63)) . chr(128 + (($v >> 6) & 63)) . chr(128 + ($v & 63)); } else if ($v < 1 << 26) { // 5 bytes $output .= chr(248 + ($v >> 24)) . chr(128 + (($v >> 18) & 63)) . chr(128 + (($v >> 12) & 63)) . chr(128 + (($v >> 6) & 63)) . chr(128 + ($v & 63)); } else if ($v < 1 << 31) { // 6 bytes $output .= chr(252 + ($v >> 30)) . chr(128 + (($v >> 24) & 63)) . chr(128 + (($v >> 18) & 63)) . chr(128 + (($v >> 12) & 63)) . chr(128 + (($v >> 6) & 63)) . chr(128 + ($v & 63)); } else { throw new UnexpectedValueException('Conversion from UCS-4 to UTF-8 failed: malformed input'); } } return $output; } /** * Convert UCS-4 array into UCS-4 string * * @param array $input ucs4-encoded array * * @return string ucs4-encoded string * @throws Exception * @access private */ private function _ucs4_to_ucs4_string($input) { $output = ''; // Take array values and split output to 4 bytes per value // The bit mask is 255, which reads &11111111 foreach ($input as $v) { $output .= ($v & (255 << 24) >> 24) . ($v & (255 << 16) >> 16) . ($v & (255 << 8) >> 8) . ($v & 255); } return $output; } /** * Convert UCS-4 string into UCS-4 array * * @param string $input ucs4-encoded string * * @return array ucs4-encoded array * @throws InvalidArgumentException * @access private */ private function _ucs4_string_to_ucs4($input) { $output = array(); $inp_len = self::_byteLength($input); // Input length must be dividable by 4 if ($inp_len % 4) { throw new InvalidArgumentException('Input UCS4 string is broken'); } // Empty input - return empty output if (!$inp_len) { return $output; } for ($i = 0, $out_len = -1; $i < $inp_len; ++$i) { // Increment output position every 4 input bytes if (!$i % 4) { $out_len++; $output[$out_len] = 0; } $output[$out_len] += ord($input{$i}) << (8 * (3 - ($i % 4) ) ); } return $output; } /** * Echo hex representation of UCS4 sequence. * * @param array $input UCS4 sequence * @param boolean $include_bit Include bitmask in output * * @return void * @static * @access private */ private static function _showHex($input, $include_bit = false) { foreach ($input as $k => $v) { echo '[', $k, '] => ', sprintf('%X', $v); if ($include_bit) { echo ' (', Net_IDNA2::_showBitmask($v), ')'; } echo "\n"; } } /** * Gives you a bit representation of given Byte (8 bits), Word (16 bits) or DWord (32 bits) * Output width is automagically determined * * @param int $octet ... * * @return string Bitmask-representation * @static * @access private */ private static function _showBitmask($octet) { if ($octet >= (1 << 16)) { $w = 31; } else if ($octet >= (1 << 8)) { $w = 15; } else { $w = 7; } $return = ''; for ($i = $w; $i > -1; $i--) { $return .= ($octet & (1 << $i))? '1' : '0'; } return $return; } /** * Gets the length of a string in bytes even if mbstring function * overloading is turned on * * @param string $string the string for which to get the length. * * @return integer the length of the string in bytes. * * @see Net_IDNA2::$_mb_string_overload */ private static function _byteLength($string) { if (self::$_mb_string_overload) { return mb_strlen($string, '8bit'); } return strlen((binary)$string); } // }}}} // {{{ factory /** * Attempts to return a concrete IDNA instance for either php4 or php5. * * @param array $params Set of paramaters * * @return Net_IDNA2 * @access public */ public static function getInstance($params = array()) { return new Net_IDNA2($params); } // }}} // {{{ singleton /** * Attempts to return a concrete IDNA instance for either php4 or php5, * only creating a new instance if no IDNA instance with the same * parameters currently exists. * * @param array $params Set of parameters * * @return object Net_IDNA2 * @access public */ public static function singleton($params = array()) { static $instances; if (!isset($instances)) { $instances = array(); } $signature = serialize($params); if (!isset($instances[$signature])) { $instances[$signature] = Net_IDNA2::getInstance($params); } return $instances[$signature]; } // }}} } ?> Socket.php000064400000052506152345735560006534 0ustar00 * @author Chuck Hagenbuch * @copyright 1997-2017 The PHP Group * @license http://opensource.org/licenses/bsd-license.php BSD-2-Clause * @link http://pear.php.net/packages/Net_Socket */ require_once 'PEAR.php'; define('NET_SOCKET_READ', 1); define('NET_SOCKET_WRITE', 2); define('NET_SOCKET_ERROR', 4); /** * Generalized Socket class. * * @category Net * @package Net_Socket * @author Stig Bakken * @author Chuck Hagenbuch * @copyright 1997-2017 The PHP Group * @license http://opensource.org/licenses/bsd-license.php BSD-2-Clause * @link http://pear.php.net/packages/Net_Socket */ class Net_Socket extends PEAR { /** * Socket file pointer. * @var resource $fp */ public $fp = null; /** * Whether the socket is blocking. Defaults to true. * @var boolean $blocking */ public $blocking = true; /** * Whether the socket is persistent. Defaults to false. * @var boolean $persistent */ public $persistent = false; /** * The IP address to connect to. * @var string $addr */ public $addr = ''; /** * The port number to connect to. * @var integer $port */ public $port = 0; /** * Number of seconds to wait on socket operations before assuming * there's no more data. Defaults to no timeout. * @var integer|float $timeout */ public $timeout = null; /** * Number of bytes to read at a time in readLine() and * readAll(). Defaults to 2048. * @var integer $lineLength */ public $lineLength = 2048; /** * The string to use as a newline terminator. Usually "\r\n" or "\n". * @var string $newline */ public $newline = "\r\n"; /** * Connect to the specified port. If called when the socket is * already connected, it disconnects and connects again. * * @param string $addr IP address or host name (may be with protocol prefix). * @param integer $port TCP port number. * @param boolean $persistent (optional) Whether the connection is * persistent (kept open between requests * by the web server). * @param integer $timeout (optional) Connection socket timeout. * @param array $options See options for stream_context_create. * * @access public * * @return boolean|PEAR_Error True on success or a PEAR_Error on failure. */ public function connect( $addr, $port = 0, $persistent = null, $timeout = null, $options = null ) { if (is_resource($this->fp)) { @fclose($this->fp); $this->fp = null; } if (!$addr) { return $this->raiseError('$addr cannot be empty'); } else { if (strspn($addr, ':.0123456789') === strlen($addr)) { $this->addr = strpos($addr, ':') !== false ? '[' . $addr . ']' : $addr; } else { $this->addr = $addr; } } $this->port = $port % 65536; if ($persistent !== null) { $this->persistent = $persistent; } $openfunc = $this->persistent ? 'pfsockopen' : 'fsockopen'; $errno = 0; $errstr = ''; if (function_exists('error_clear_last')) { error_clear_last(); } else { $old_track_errors = @ini_set('track_errors', 1); } if ($timeout <= 0) { $timeout = @ini_get('default_socket_timeout'); } if ($options && function_exists('stream_context_create')) { $context = stream_context_create($options); // Since PHP 5 fsockopen doesn't allow context specification if (function_exists('stream_socket_client')) { $flags = STREAM_CLIENT_CONNECT; if ($this->persistent) { $flags = STREAM_CLIENT_PERSISTENT; } $addr = $this->addr . ':' . $this->port; $fp = @stream_socket_client($addr, $errno, $errstr, $timeout, $flags, $context); } else { $fp = @$openfunc($this->addr, $this->port, $errno, $errstr, $timeout, $context); } } else { $fp = @$openfunc($this->addr, $this->port, $errno, $errstr, $timeout); } if (!$fp) { if ($errno === 0 && !strlen($errstr)) { $errstr = ''; if (isset($old_track_errors)) { $errstr = $php_errormsg ?: ''; @ini_set('track_errors', $old_track_errors); } else { $lastError = error_get_last(); if (isset($lastError['message'])) { $errstr = $lastError['message']; } } } return $this->raiseError($errstr, $errno); } if (isset($old_track_errors)) { @ini_set('track_errors', $old_track_errors); } $this->fp = $fp; $this->setTimeout(); return $this->setBlocking($this->blocking); } /** * Disconnects from the peer, closes the socket. * * @access public * @return mixed true on success or a PEAR_Error instance otherwise */ public function disconnect() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } @fclose($this->fp); $this->fp = null; return true; } /** * Set the newline character/sequence to use. * * @param string $newline Newline character(s) * @return boolean True */ public function setNewline($newline) { $this->newline = $newline; return true; } /** * Find out if the socket is in blocking mode. * * @access public * @return boolean The current blocking mode. */ public function isBlocking() { return $this->blocking; } /** * Sets whether the socket connection should be blocking or * not. A read call to a non-blocking socket will return immediately * if there is no data available, whereas it will block until there * is data for blocking sockets. * * @param boolean $mode True for blocking sockets, false for nonblocking. * * @access public * @return mixed true on success or a PEAR_Error instance otherwise */ public function setBlocking($mode) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $this->blocking = $mode; stream_set_blocking($this->fp, (int)$this->blocking); return true; } /** * Sets the timeout value on socket descriptor, * expressed in the sum of seconds and microseconds * * @param integer $seconds Seconds. * @param integer $microseconds Microseconds, optional. * * @access public * @return mixed True on success or false on failure or * a PEAR_Error instance when not connected */ public function setTimeout($seconds = null, $microseconds = null) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } if ($seconds === null && $microseconds === null) { $seconds = (int)$this->timeout; $microseconds = (int)(($this->timeout - $seconds) * 1000000); } else { $this->timeout = $seconds + $microseconds / 1000000; } if ($this->timeout > 0) { return stream_set_timeout($this->fp, (int)$seconds, (int)$microseconds); } else { return false; } } /** * Sets the file buffering size on the stream. * See php's stream_set_write_buffer for more information. * * @param integer $size Write buffer size. * * @access public * @return mixed on success or an PEAR_Error object otherwise */ public function setWriteBuffer($size) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $returned = stream_set_write_buffer($this->fp, $size); if ($returned === 0) { return true; } return $this->raiseError('Cannot set write buffer.'); } /** * Returns information about an existing socket resource. * Currently returns four entries in the result array: * *

* timed_out (bool) - The socket timed out waiting for data
* blocked (bool) - The socket was blocked
* eof (bool) - Indicates EOF event
* unread_bytes (int) - Number of bytes left in the socket buffer
*

* * @access public * @return mixed Array containing information about existing socket * resource or a PEAR_Error instance otherwise */ public function getStatus() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } return stream_get_meta_data($this->fp); } /** * Get a specified line of data * * @param int $size Reading ends when size - 1 bytes have been read, * or a newline or an EOF (whichever comes first). * If no size is specified, it will keep reading from * the stream until it reaches the end of the line. * * @access public * @return mixed $size bytes of data from the socket, or a PEAR_Error if * not connected. If an error occurs, FALSE is returned. */ public function gets($size = null) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } if (null === $size) { return @fgets($this->fp); } else { return @fgets($this->fp, $size); } } /** * Read a specified amount of data. This is guaranteed to return, * and has the added benefit of getting everything in one fread() * chunk; if you know the size of the data you're getting * beforehand, this is definitely the way to go. * * @param integer $size The number of bytes to read from the socket. * * @access public * @return string $size bytes of data from the socket, or a PEAR_Error if * not connected. */ public function read($size) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } return @fread($this->fp, $size); } /** * Write a specified amount of data. * * @param string $data Data to write. * @param integer $blocksize Amount of data to write at once. * NULL means all at once. * * @access public * @return mixed If the socket is not connected, returns an instance of * PEAR_Error. * If the write succeeds, returns the number of bytes written. * If the write fails, returns false. * If the socket times out, returns an instance of PEAR_Error. */ public function write($data, $blocksize = null) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } if (null === $blocksize && !OS_WINDOWS) { $written = @fwrite($this->fp, $data); // Check for timeout or lost connection if ($written === false) { $meta_data = $this->getStatus(); if (!is_array($meta_data)) { return $meta_data; // PEAR_Error } if (!empty($meta_data['timed_out'])) { return $this->raiseError('timed out'); } } return $written; } else { if (null === $blocksize) { $blocksize = 1024; } $pos = 0; $size = strlen($data); while ($pos < $size) { $written = @fwrite($this->fp, substr($data, $pos, $blocksize)); // Check for timeout or lost connection if ($written === false) { $meta_data = $this->getStatus(); if (!is_array($meta_data)) { return $meta_data; // PEAR_Error } if (!empty($meta_data['timed_out'])) { return $this->raiseError('timed out'); } return $written; } $pos += $written; } return $pos; } } /** * Write a line of data to the socket, followed by a trailing newline. * * @param string $data Data to write * * @access public * @return mixed fwrite() result, or PEAR_Error when not connected */ public function writeLine($data) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } return fwrite($this->fp, $data . $this->newline); } /** * Tests for end-of-file on a socket descriptor. * * Also returns true if the socket is disconnected. * * @access public * @return bool */ public function eof() { return (!is_resource($this->fp) || feof($this->fp)); } /** * Reads a byte of data * * @access public * @return integer 1 byte of data from the socket, or a PEAR_Error if * not connected. */ public function readByte() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } return ord(@fread($this->fp, 1)); } /** * Reads a word of data * * @access public * @return integer 1 word of data from the socket, or a PEAR_Error if * not connected. */ public function readWord() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $buf = @fread($this->fp, 2); return (ord($buf[0]) + (ord($buf[1]) << 8)); } /** * Reads an int of data * * @access public * @return integer 1 int of data from the socket, or a PEAR_Error if * not connected. */ public function readInt() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $buf = @fread($this->fp, 4); return (ord($buf[0]) + (ord($buf[1]) << 8) + (ord($buf[2]) << 16) + (ord($buf[3]) << 24)); } /** * Reads a zero-terminated string of data * * @access public * @return string, or a PEAR_Error if * not connected. */ public function readString() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $string = ''; while (($char = @fread($this->fp, 1)) !== "\x00") { $string .= $char; } return $string; } /** * Reads an IP Address and returns it in a dot formatted string * * @access public * @return string Dot formatted string, or a PEAR_Error if * not connected. */ public function readIPAddress() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $buf = @fread($this->fp, 4); return sprintf('%d.%d.%d.%d', ord($buf[0]), ord($buf[1]), ord($buf[2]), ord($buf[3])); } /** * Read until either the end of the socket or a newline, whichever * comes first. Strips the trailing newline from the returned data. * * @access public * @return string All available data up to a newline, without that * newline, or until the end of the socket, or a PEAR_Error if * not connected. */ public function readLine() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $line = ''; $timeout = time() + $this->timeout; while (!feof($this->fp) && (!$this->timeout || time() < $timeout)) { $line .= @fgets($this->fp, $this->lineLength); if (substr($line, -1) == "\n") { return rtrim($line, $this->newline); } } return $line; } /** * Read until the socket closes, or until there is no more data in * the inner PHP buffer. If the inner buffer is empty, in blocking * mode we wait for at least 1 byte of data. Therefore, in * blocking mode, if there is no data at all to be read, this * function will never exit (unless the socket is closed on the * remote end). * * @access public * * @return string All data until the socket closes, or a PEAR_Error if * not connected. */ public function readAll() { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $data = ''; $timeout = time() + $this->timeout; while (!feof($this->fp) && (!$this->timeout || time() < $timeout)) { $data .= @fread($this->fp, $this->lineLength); } return $data; } /** * Runs the equivalent of the select() system call on the socket * with a timeout specified by tv_sec and tv_usec. * * @param integer $state Which of read/write/error to check for. * @param integer $tv_sec Number of seconds for timeout. * @param integer $tv_usec Number of microseconds for timeout. * * @access public * @return False if select fails, integer describing which of read/write/error * are ready, or PEAR_Error if not connected. */ public function select($state, $tv_sec, $tv_usec = 0) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } $read = null; $write = null; $except = null; if ($state & NET_SOCKET_READ) { $read[] = $this->fp; } if ($state & NET_SOCKET_WRITE) { $write[] = $this->fp; } if ($state & NET_SOCKET_ERROR) { $except[] = $this->fp; } if (false === ($sr = stream_select($read, $write, $except, $tv_sec, $tv_usec)) ) { return false; } $result = 0; if (count($read)) { $result |= NET_SOCKET_READ; } if (count($write)) { $result |= NET_SOCKET_WRITE; } if (count($except)) { $result |= NET_SOCKET_ERROR; } return $result; } /** * Turns encryption on/off on a connected socket. * * @param bool $enabled Set this parameter to true to enable encryption * and false to disable encryption. * @param integer $type Type of encryption. See stream_socket_enable_crypto() * for values. * * @see http://se.php.net/manual/en/function.stream-socket-enable-crypto.php * @access public * @return false on error, true on success and 0 if there isn't enough data * and the user should try again (non-blocking sockets only). * A PEAR_Error object is returned if the socket is not * connected */ public function enableCrypto($enabled, $type) { if (version_compare(phpversion(), '5.1.0', '>=')) { if (!is_resource($this->fp)) { return $this->raiseError('not connected'); } return @stream_socket_enable_crypto($this->fp, $enabled, $type); } else { $msg = 'Net_Socket::enableCrypto() requires php version >= 5.1.0'; return $this->raiseError($msg); } } } Sieve.php000064400000133532152345735560006356 0ustar00 * @author Damian Fernandez Sosa * @author Anish Mistry * @author Jan Schneider * @copyright 2002-2003 Richard Heyes * @copyright 2006-2008 Anish Mistry * @license http://www.opensource.org/licenses/bsd-license.php BSD * @link http://pear.php.net/package/Net_Sieve */ require_once 'PEAR.php'; require_once 'Net/Socket.php'; /** * Disconnected state * * @const NET_SIEVE_STATE_DISCONNECTED */ define('NET_SIEVE_STATE_DISCONNECTED', 1); /** * Authorisation state * * @const NET_SIEVE_STATE_AUTHORISATION */ define('NET_SIEVE_STATE_AUTHORISATION', 2); /** * Transaction state * * @const NET_SIEVE_STATE_TRANSACTION */ define('NET_SIEVE_STATE_TRANSACTION', 3); /** * A class for talking to the timsieved server which comes with Cyrus IMAP. * * @category Networking * @package Net_Sieve * @author Richard Heyes * @author Damian Fernandez Sosa * @author Anish Mistry * @author Jan Schneider * @author Neil Munday * @copyright 2002-2003 Richard Heyes * @copyright 2006-2008 Anish Mistry * @license http://www.opensource.org/licenses/bsd-license.php BSD * @version Release: 1.4.5 * @link http://pear.php.net/package/Net_Sieve * @link http://tools.ietf.org/html/rfc5228 RFC 5228 (Sieve: An Email * Filtering Language) * @link http://tools.ietf.org/html/rfc5804 RFC 5804 A Protocol for * Remotely Managing Sieve Scripts */ class Net_Sieve { /** * The authentication methods this class supports. * * Can be overwritten if having problems with certain methods. * * @var array */ var $supportedAuthMethods = array( 'DIGEST-MD5', 'CRAM-MD5', 'EXTERNAL', 'PLAIN' , 'LOGIN', 'GSSAPI', 'XOAUTH2' ); /** * SASL authentication methods that require Auth_SASL. * * @var array */ var $supportedSASLAuthMethods = array('DIGEST-MD5', 'CRAM-MD5'); /** * The socket handle. * * @var resource */ var $_sock; /** * Parameters and connection information. * * @var array */ var $_data; /** * Current state of the connection. * * One of the NET_SIEVE_STATE_* constants. * * @var integer */ var $_state; /** * PEAR object to avoid strict warnings. * * @var PEAR_Error */ var $_pear; /** * Constructor error. * * @var PEAR_Error */ var $_error; /** * Whether to enable debugging. * * @var boolean */ var $_debug = false; /** * Debug output handler. * * This has to be a valid callback. * * @var string|array */ var $_debug_handler = null; /** * Whether to pick up an already established connection. * * @var boolean */ var $_bypassAuth = false; /** * Whether to use TLS if available. * * @var boolean */ var $_useTLS = true; /** * Additional options for stream_context_create(). * * @var array */ var $_options = null; /** * Maximum number of referral loops * * @var array */ var $_maxReferralCount = 15; /** * Kerberos service principal to use for GSSAPI authentication. * * @var string */ var $_gssapiPrincipal = null; /** * Kerberos service cname to use for GSSAPI authentication. * * @var string */ var $_gssapiCN = null; /** * Constructor. * * Sets up the object, connects to the server and logs in. Stores any * generated error in $this->_error, which can be retrieved using the * getError() method. * * @param string $user Login username. * @param string $pass Login password. * @param string $host Hostname of server. * @param string $port Port of server. * @param string $logintype Type of login to perform (see * $supportedAuthMethods). * @param string $euser Effective user. If authenticating as an * administrator, login as this user. * @param boolean $debug Whether to enable debugging (@see setDebug()). * @param string $bypassAuth Skip the authentication phase. Useful if the * socket is already open. * @param boolean $useTLS Use TLS if available. * @param array $options Additional options for * stream_context_create(). * @param mixed $handler A callback handler for the debug output. * @param string $principal Kerberos service principal to use * with GSSAPI authentication. * @param string $cname Kerberos service cname to use * with GSSAPI authentication. */ function __construct($user = null, $pass = null, $host = 'localhost', $port = 2000, $logintype = '', $euser = '', $debug = false, $bypassAuth = false, $useTLS = true, $options = null, $handler = null, $principal = null, $cname = null ) { $this->_pear = new PEAR(); $this->_state = NET_SIEVE_STATE_DISCONNECTED; $this->_data['user'] = $user; $this->_data['pass'] = $pass; $this->_data['host'] = $host; $this->_data['port'] = $port; $this->_data['logintype'] = $logintype; $this->_data['euser'] = $euser; $this->_sock = new Net_Socket(); $this->_bypassAuth = $bypassAuth; $this->_useTLS = $useTLS; $this->_options = (array) $options; $this->_gssapiPrincipal = $principal; $this->_gssapiCN = $cname; $this->setDebug($debug, $handler); /* Try to include the Auth_SASL package. If the package is not * available, we disable the authentication methods that depend upon * it. */ if ((@include_once 'Auth/SASL.php') === false) { $this->_debug('Auth_SASL not present'); $this->supportedAuthMethods = array_diff( $this->supportedAuthMethods, $this->supportedSASLAuthMethods ); } if (strlen($user) && strlen($pass)) { $this->_error = $this->_handleConnectAndLogin(); } } /** * Returns any error that may have been generated in the constructor. * * @return boolean|PEAR_Error False if no error, PEAR_Error otherwise. */ function getError() { return is_a($this->_error, 'PEAR_Error') ? $this->_error : false; } /** * Sets the debug state and handler function. * * @param boolean $debug Whether to enable debugging. * @param string $handler A custom debug handler. Must be a valid callback. * * @return void */ function setDebug($debug = true, $handler = null) { $this->_debug = $debug; $this->_debug_handler = $handler; } /** * Sets the Kerberos service principal for use with GSSAPI * authentication. * * @param string $principal The Kerberos service principal * * @return void */ function setServicePrincipal($principal) { $this->_gssapiPrincipal = $principal; } /** * Sets the Kerberos service CName for use with GSSAPI * authentication. * * @param string $cname The Kerberos service principal * * @return void */ function setServiceCN($cname) { $this->_gssapiCN = $cname; } /** * Connects to the server and logs in. * * @return boolean True on success, PEAR_Error on failure. */ function _handleConnectAndLogin() { $res = $this->connect($this->_data['host'], $this->_data['port'], $this->_options, $this->_useTLS); if (is_a($res, 'PEAR_Error')) { return $res; } if ($this->_bypassAuth === false) { $res = $this->login($this->_data['user'], $this->_data['pass'], $this->_data['logintype'], $this->_data['euser'], $this->_bypassAuth); if (is_a($res, 'PEAR_Error')) { return $res; } } return true; } /** * Handles connecting to the server and checks the response validity. * * @param string $host Hostname of server. * @param string $port Port of server. * @param array $options List of options to pass to * stream_context_create(). * @param boolean $useTLS Use TLS if available. * * @return boolean True on success, PEAR_Error otherwise. */ function connect($host, $port, $options = null, $useTLS = true) { $this->_data['host'] = $host; $this->_data['port'] = $port; $this->_useTLS = $useTLS; if (is_array($options)) { $this->_options = array_merge($this->_options, $options); } if (NET_SIEVE_STATE_DISCONNECTED != $this->_state) { return $this->_pear->raiseError('Not currently in DISCONNECTED state', 1); } $res = $this->_sock->connect($host, $port, false, 5, $options); if (is_a($res, 'PEAR_Error')) { return $res; } if ($this->_bypassAuth) { $this->_state = NET_SIEVE_STATE_TRANSACTION; // Reset capabilities $this->_parseCapability(''); } else { $this->_state = NET_SIEVE_STATE_AUTHORISATION; $res = $this->_doCmd(); if (is_a($res, 'PEAR_Error')) { return $res; } // Reset capabilities (use unattended capabilities) $this->_parseCapability($res); } // Explicitly ask for the capabilities if needed if (empty($this->_capability['implementation'])) { $res = $this->_cmdCapability(); if (is_a($res, 'PEAR_Error')) { return $this->_pear->raiseError( 'Failed to connect, server said: ' . $res->getMessage(), 2 ); } } // Check if we can enable TLS via STARTTLS. if ($useTLS && !empty($this->_capability['starttls']) && function_exists('stream_socket_enable_crypto') ) { $res = $this->_startTLS(); if (is_a($res, 'PEAR_Error')) { return $res; } } return true; } /** * Disconnect from the Sieve server. * * @param boolean $sendLogoutCMD Whether to send LOGOUT command before * disconnecting. * * @return boolean True on success, PEAR_Error otherwise. */ function disconnect($sendLogoutCMD = true) { return $this->_cmdLogout($sendLogoutCMD); } /** * Logs into server. * * @param string $user Login username. * @param string $pass Login password. * @param string $logintype Type of login method to use. * @param string $euser Effective UID (perform on behalf of $euser). * @param boolean $bypassAuth Do not perform authentication. * * @return boolean True on success, PEAR_Error otherwise. */ function login($user, $pass, $logintype = null, $euser = '', $bypassAuth = false) { $this->_data['user'] = $user; $this->_data['pass'] = $pass; $this->_data['logintype'] = $logintype; $this->_data['euser'] = $euser; $this->_bypassAuth = $bypassAuth; if (NET_SIEVE_STATE_AUTHORISATION != $this->_state) { return $this->_pear->raiseError('Not currently in AUTHORISATION state', 1); } if (!$bypassAuth ) { $res = $this->_cmdAuthenticate($user, $pass, $logintype, $euser); if (is_a($res, 'PEAR_Error')) { return $res; } } $this->_state = NET_SIEVE_STATE_TRANSACTION; return true; } /** * Returns an indexed array of scripts currently on the server. * * @param string $active Will be set to the name of the active script * * @return array Indexed array of scriptnames, PEAR_Error on failure */ function listScripts(&$active = null) { if (is_array($scripts = $this->_cmdListScripts())) { if (isset($scripts[1])) { $active = $scripts[1]; } return $scripts[0]; } return $scripts; } /** * Returns the active script. * * @return string The active scriptname. */ function getActive() { if (is_array($scripts = $this->_cmdListScripts())) { return $scripts[1]; } } /** * Sets the active script. * * @param string $scriptname The name of the script to be set as active. * * @return boolean True on success, PEAR_Error on failure. */ function setActive($scriptname) { return $this->_cmdSetActive($scriptname); } /** * Retrieves a script. * * @param string $scriptname The name of the script to be retrieved. * * @return string The script on success, PEAR_Error on failure. */ function getScript($scriptname) { return $this->_cmdGetScript($scriptname); } /** * Adds a script to the server. * * @param string $scriptname Name of the script. * @param string $script The script content. * @param boolean $makeactive Whether to make this the active script. * * @return boolean True on success, PEAR_Error on failure. */ function installScript($scriptname, $script, $makeactive = false) { $res = $this->_cmdPutScript($scriptname, $script); if (is_a($res, 'PEAR_Error')) { return $res; } if ($makeactive) { return $this->_cmdSetActive($scriptname); } return true; } /** * Removes a script from the server. * * @param string $scriptname Name of the script. * * @return boolean True on success, PEAR_Error on failure. */ function removeScript($scriptname) { return $this->_cmdDeleteScript($scriptname); } /** * Checks if the server has space to store the script by the server. * * @param string $scriptname The name of the script to mark as active. * @param integer $size The size of the script. * * @return boolean|PEAR_Error True if there is space, PEAR_Error otherwise. * * @todo Rename to hasSpace() */ function haveSpace($scriptname, $size) { if (NET_SIEVE_STATE_TRANSACTION != $this->_state) { return $this->_pear->raiseError('Not currently in TRANSACTION state', 1); } $res = $this->_doCmd(sprintf('HAVESPACE %s %d', $this->_escape($scriptname), $size)); if (is_a($res, 'PEAR_Error')) { return $res; } return true; } /** * Returns the list of extensions the server supports. * * @return array List of extensions or PEAR_Error on failure. */ function getExtensions() { if (NET_SIEVE_STATE_DISCONNECTED == $this->_state) { return $this->_pear->raiseError('Not currently connected', 7); } return $this->_capability['extensions']; } /** * Returns whether the server supports an extension. * * @param string $extension The extension to check. * * @return boolean Whether the extension is supported or PEAR_Error on * failure. */ function hasExtension($extension) { if (NET_SIEVE_STATE_DISCONNECTED == $this->_state) { return $this->_pear->raiseError('Not currently connected', 7); } $extension = trim($this->_toUpper($extension)); if (is_array($this->_capability['extensions'])) { foreach ($this->_capability['extensions'] as $ext) { if ($ext == $extension) { return true; } } } return false; } /** * Returns the list of authentication methods the server supports. * * @return array List of authentication methods or PEAR_Error on failure. */ function getAuthMechs() { if (NET_SIEVE_STATE_DISCONNECTED == $this->_state) { return $this->_pear->raiseError('Not currently connected', 7); } return $this->_capability['sasl']; } /** * Returns whether the server supports an authentication method. * * @param string $method The method to check. * * @return boolean Whether the method is supported or PEAR_Error on * failure. */ function hasAuthMech($method) { if (NET_SIEVE_STATE_DISCONNECTED == $this->_state) { return $this->_pear->raiseError('Not currently connected', 7); } $method = trim($this->_toUpper($method)); if (is_array($this->_capability['sasl'])) { foreach ($this->_capability['sasl'] as $sasl) { if ($sasl == $method) { return true; } } } return false; } /** * Handles the authentication using any known method. * * @param string $uid The userid to authenticate as. * @param string $pwd The password to authenticate with. * @param string $userMethod The method to use. If empty, the class chooses * the best (strongest) available method. * @param string $euser The effective uid to authenticate as. * * @return void */ function _cmdAuthenticate($uid, $pwd, $userMethod = null, $euser = '') { $method = $this->_getBestAuthMethod($userMethod); if (is_a($method, 'PEAR_Error')) { return $method; } switch ($method) { case 'DIGEST-MD5': return $this->_authDigestMD5($uid, $pwd, $euser); case 'CRAM-MD5': $result = $this->_authCRAMMD5($uid, $pwd, $euser); break; case 'LOGIN': $result = $this->_authLOGIN($uid, $pwd, $euser); break; case 'PLAIN': $result = $this->_authPLAIN($uid, $pwd, $euser); break; case 'EXTERNAL': $result = $this->_authEXTERNAL($uid, $pwd, $euser); break; case 'GSSAPI': $result = $this->_authGSSAPI($pwd); break; case 'XOAUTH2': $result = $this->_authXOAUTH2($uid, $pwd, $euser); break; default : $result = $this->_pear->raiseError( $method . ' is not a supported authentication method' ); break; } $res = $this->_doCmd(); if (is_a($res, 'PEAR_Error')) { return $res; } if ($this->_pear->isError($res = $this->_cmdCapability())) { return $this->_pear->raiseError( 'Failed to connect, server said: ' . $res->getMessage(), 2 ); } return $result; } /** * Authenticates the user using the PLAIN method. * * @param string $user The userid to authenticate as. * @param string $pass The password to authenticate with. * @param string $euser The effective uid to authenticate as. * * @return void */ function _authPLAIN($user, $pass, $euser) { return $this->_sendCmd( sprintf( 'AUTHENTICATE "PLAIN" "%s"', base64_encode($euser . chr(0) . $user . chr(0) . $pass) ) ); } /** * Authenticates the user using the GSSAPI method. * * @note the PHP krb5 extension is required and the service principal and cname * must have been set. * @see setServicePrincipal() * * @return void */ function _authGSSAPI() { if (!extension_loaded('krb5')) { return $this->_pear->raiseError('The krb5 extension is required for GSSAPI authentication', 2); } if (!$this->_gssapiPrincipal) { return $this->_pear->raiseError('No Kerberos service principal set', 2); } if (!$this->_gssapiCN) { return $this->_pear->raiseError('No Kerberos service CName set', 2); } putenv('KRB5CCNAME=' . $this->_gssapiCN); try { $ccache = new KRB5CCache(); $ccache->open($this->_gssapiCN); $gssapicontext = new GSSAPIContext(); $gssapicontext->acquireCredentials($ccache); $token = ''; $success = $gssapicontext->initSecContext($this->_gssapiPrincipal, null, null, null, $token); $token = base64_encode($token); } catch (Exception $e) { return $this->_pear->raiseError('GSSAPI authentication failed: ' . $e->getMessage()); } $this->_sendCmd("AUTHENTICATE \"GSSAPI\" {" . strlen($token) . "+}"); $response = $this->_doCmd($token, true); try { $challenge = base64_decode(substr($response, 1, -1)); $gssapicontext->unwrap($challenge, $challenge); $gssapicontext->wrap($challenge, $challenge, true); } catch (Exception $e) { return $this->_pear->raiseError('GSSAPI authentication failed: ' . $e->getMessage()); } $response = base64_encode($challenge); $this->_sendCmd("{" . strlen($response) . "+}"); return $this->_sendCmd($response); } /** * Authenticates the user using the LOGIN method. * * @param string $user The userid to authenticate as. * @param string $pass The password to authenticate with. * @param string $euser The effective uid to authenticate as. Not used. * * @return void */ function _authLOGIN($user, $pass, $euser) { $result = $this->_sendCmd('AUTHENTICATE "LOGIN"'); if (is_a($result, 'PEAR_Error')) { return $result; } $result = $this->_doCmd('"' . base64_encode($user) . '"', true); if (is_a($result, 'PEAR_Error')) { return $result; } return $this->_doCmd('"' . base64_encode($pass) . '"', true); } /** * Authenticates the user using the CRAM-MD5 method. * * @param string $user The userid to authenticate as. * @param string $pass The password to authenticate with. * @param string $euser The effective uid to authenticate as. Not used. * * @return void */ function _authCRAMMD5($user, $pass, $euser) { $challenge = $this->_doCmd('AUTHENTICATE "CRAM-MD5"', true); if (is_a($challenge, 'PEAR_Error')) { return $challenge; } $auth_sasl = new Auth_SASL; $cram = $auth_sasl->factory('crammd5'); $challenge = base64_decode(trim($challenge)); $response = $cram->getResponse($user, $pass, $challenge); if (is_a($response, 'PEAR_Error')) { return $response; } return $this->_sendStringResponse(base64_encode($response)); } /** * Authenticates the user using the DIGEST-MD5 method. * * @param string $user The userid to authenticate as. * @param string $pass The password to authenticate with. * @param string $euser The effective uid to authenticate as. * * @return void */ function _authDigestMD5($user, $pass, $euser) { $challenge = $this->_doCmd('AUTHENTICATE "DIGEST-MD5"', true); if (is_a($challenge, 'PEAR_Error')) { return $challenge; } $auth_sasl = new Auth_SASL; $digest = $auth_sasl->factory('digestmd5'); $challenge = base64_decode(trim($challenge)); // @todo Really 'localhost'? $response = $digest->getResponse($user, $pass, $challenge, 'localhost', 'sieve', $euser); if (is_a($response, 'PEAR_Error')) { return $response; } $result = $this->_sendStringResponse(base64_encode($response)); if (is_a($result, 'PEAR_Error')) { return $result; } $result = $this->_doCmd('', true); if (is_a($result, 'PEAR_Error')) { return $result; } if ($this->_toUpper(substr($result, 0, 2)) == 'OK') { return; } /* We don't use the protocol's third step because SIEVE doesn't allow * subsequent authentication, so we just silently ignore it. */ $result = $this->_sendStringResponse(''); if (is_a($result, 'PEAR_Error')) { return $result; } return $this->_doCmd(); } /** * Authenticates the user using the EXTERNAL method. * * @param string $user The userid to authenticate as. * @param string $pass The password to authenticate with. * @param string $euser The effective uid to authenticate as. * * @return void * * @since 1.1.7 */ function _authEXTERNAL($user, $pass, $euser) { $cmd = sprintf( 'AUTHENTICATE "EXTERNAL" "%s"', base64_encode(strlen($euser) ? $euser : $user) ); return $this->_sendCmd($cmd); } /** * Authenticates the user using the XOAUTH2 method. * * @param string $user The userid to authenticate as. * @param string $token The token to authenticate with. * @param string $euser The effective uid to authenticate as. * * @return void */ function _authXOAUTH2($user, $token, $euser) { // default to $user if $euser is not set if (! $euser) { $euser = $user; } $auth = base64_encode("user=$euser\001auth=$token\001\001"); return $this->_sendCmd("AUTHENTICATE \"XOAUTH2\" \"$auth\""); } /** * Removes a script from the server. * * @param string $scriptname Name of the script to delete. * * @return boolean True on success, PEAR_Error otherwise. */ function _cmdDeleteScript($scriptname) { if (NET_SIEVE_STATE_TRANSACTION != $this->_state) { return $this->_pear->raiseError('Not currently in AUTHORISATION state', 1); } $res = $this->_doCmd(sprintf('DELETESCRIPT %s', $this->_escape($scriptname))); if (is_a($res, 'PEAR_Error')) { return $res; } return true; } /** * Retrieves the contents of the named script. * * @param string $scriptname Name of the script to retrieve. * * @return string The script if successful, PEAR_Error otherwise. */ function _cmdGetScript($scriptname) { if (NET_SIEVE_STATE_TRANSACTION != $this->_state) { return $this->_pear->raiseError('Not currently in AUTHORISATION state', 1); } $res = $this->_doCmd(sprintf('GETSCRIPT %s', $this->_escape($scriptname))); if (is_a($res, 'PEAR_Error')) { return $res; } return preg_replace('/^{[0-9]+}\r\n/', '', $res); } /** * Sets the active script, i.e. the one that gets run on new mail by the * server. * * @param string $scriptname The name of the script to mark as active. * * @return boolean True on success, PEAR_Error otherwise. */ function _cmdSetActive($scriptname) { if (NET_SIEVE_STATE_TRANSACTION != $this->_state) { return $this->_pear->raiseError('Not currently in AUTHORISATION state', 1); } $res = $this->_doCmd(sprintf('SETACTIVE %s', $this->_escape($scriptname))); if (is_a($res, 'PEAR_Error')) { return $res; } return true; } /** * Returns the list of scripts on the server. * * @return array An array with the list of scripts in the first element * and the active script in the second element on success, * PEAR_Error otherwise. */ function _cmdListScripts() { if (NET_SIEVE_STATE_TRANSACTION != $this->_state) { return $this->_pear->raiseError('Not currently in AUTHORISATION state', 1); } $res = $this->_doCmd('LISTSCRIPTS'); if (is_a($res, 'PEAR_Error')) { return $res; } $scripts = array(); $activescript = null; $res = explode("\r\n", $res); foreach ($res as $value) { if (preg_match('/^"(.*)"( ACTIVE)?$/i', $value, $matches)) { $script_name = stripslashes($matches[1]); $scripts[] = $script_name; if (!empty($matches[2])) { $activescript = $script_name; } } } return array($scripts, $activescript); } /** * Adds a script to the server. * * @param string $scriptname Name of the new script. * @param string $scriptdata The new script. * * @return boolean True on success, PEAR_Error otherwise. */ function _cmdPutScript($scriptname, $scriptdata) { if (NET_SIEVE_STATE_TRANSACTION != $this->_state) { return $this->_pear->raiseError('Not currently in AUTHORISATION state', 1); } $stringLength = $this->_getLineLength($scriptdata); $command = sprintf( "PUTSCRIPT %s {%d+}\r\n%s", $this->_escape($scriptname), $stringLength, $scriptdata ); $res = $this->_doCmd($command); if (is_a($res, 'PEAR_Error')) { return $res; } return true; } /** * Logs out of the server and terminates the connection. * * @param boolean $sendLogoutCMD Whether to send LOGOUT command before * disconnecting. * * @return boolean True on success, PEAR_Error otherwise. */ function _cmdLogout($sendLogoutCMD = true) { if (NET_SIEVE_STATE_DISCONNECTED == $this->_state) { return $this->_pear->raiseError('Not currently connected', 1); } if ($sendLogoutCMD) { $res = $this->_doCmd('LOGOUT'); if (is_a($res, 'PEAR_Error')) { return $res; } } $this->_sock->disconnect(); $this->_state = NET_SIEVE_STATE_DISCONNECTED; return true; } /** * Sends the CAPABILITY command * * @return boolean True on success, PEAR_Error otherwise. */ function _cmdCapability() { if (NET_SIEVE_STATE_DISCONNECTED == $this->_state) { return $this->_pear->raiseError('Not currently connected', 1); } $res = $this->_doCmd('CAPABILITY'); if (is_a($res, 'PEAR_Error')) { return $res; } $this->_parseCapability($res); return true; } /** * Parses the response from the CAPABILITY command and stores the result * in $_capability. * * @param string $data The response from the capability command. * * @return void */ function _parseCapability($data) { // Clear the cached capabilities. $this->_capability = array('sasl' => array(), 'extensions' => array()); $data = preg_split('/\r?\n/', $this->_toUpper($data), -1, PREG_SPLIT_NO_EMPTY); for ($i = 0; $i < count($data); $i++) { if (!preg_match('/^"([A-Z]+)"( "(.*)")?$/', $data[$i], $matches)) { continue; } switch ($matches[1]) { case 'IMPLEMENTATION': $this->_capability['implementation'] = $matches[3]; break; case 'SASL': if (!empty($matches[3])) { $this->_capability['sasl'] = preg_split('/\s+/', $matches[3]); } break; case 'SIEVE': if (!empty($matches[3])) { $this->_capability['extensions'] = preg_split('/\s+/', $matches[3]); } break; case 'STARTTLS': $this->_capability['starttls'] = true; break; } } } /** * Sends a command to the server * * @param string $cmd The command to send. * * @return void */ function _sendCmd($cmd) { $status = $this->_sock->getStatus(); if (is_a($status, 'PEAR_Error') || $status['eof']) { return $this->_pear->raiseError('Failed to write to socket: connection lost'); } $error = $this->_sock->write($cmd . "\r\n"); if (is_a($error, 'PEAR_Error')) { return $this->_pear->raiseError( 'Failed to write to socket: ' . $error->getMessage() ); } $this->_debug("C: $cmd"); } /** * Sends a string response to the server. * * @param string $str The string to send. * * @return void */ function _sendStringResponse($str) { return $this->_sendCmd('{' . $this->_getLineLength($str) . "+}\r\n" . $str); } /** * Receives a single line from the server. * * @return string The server response line. */ function _recvLn() { $lastline = $this->_sock->gets(8192); if (is_a($lastline, 'PEAR_Error')) { return $this->_pear->raiseError( 'Failed to read from socket: ' . $lastline->getMessage() ); } $lastline = rtrim($lastline); $this->_debug("S: $lastline"); if ($lastline === '') { return $this->_pear->raiseError('Failed to read from socket'); } return $lastline; } /** * Receives a number of bytes from the server. * * @param integer $length Number of bytes to read. * * @return string The server response. */ function _recvBytes($length) { $response = ''; $response_length = 0; while ($response_length < $length) { $response .= $this->_sock->read($length - $response_length); $response_length = $this->_getLineLength($response); } $this->_debug('S: ' . rtrim($response)); return $response; } /** * Send a command and retrieves a response from the server. * * @param string $cmd The command to send. * @param boolean $auth Whether this is an authentication command. * * @return string|PEAR_Error Reponse string if an OK response, PEAR_Error * if a NO response. */ function _doCmd($cmd = '', $auth = false) { $referralCount = 0; while ($referralCount < $this->_maxReferralCount) { if (strlen($cmd)) { $error = $this->_sendCmd($cmd); if (is_a($error, 'PEAR_Error')) { return $error; } } $response = ''; while (true) { $line = $this->_recvLn(); if (is_a($line, 'PEAR_Error')) { return $line; } if (preg_match('/^(OK|NO)/i', $line, $tag)) { // Check for string literal message. if (preg_match('/{([0-9]+)}$/', $line, $matches)) { $line = substr($line, 0, -(strlen($matches[1]) + 2)) . str_replace( "\r\n", ' ', $this->_recvBytes($matches[1] + 2) ); } if ('OK' == $this->_toUpper($tag[1])) { $response .= $line; return rtrim($response); } return $this->_pear->raiseError(trim($response . substr($line, 2)), 3); } if (preg_match('/^BYE/i', $line)) { $error = $this->disconnect(false); if (is_a($error, 'PEAR_Error')) { return $this->_pear->raiseError( 'Cannot handle BYE, the error was: ' . $error->getMessage(), 4 ); } // Check for referral, then follow it. Otherwise, carp an // error. if (preg_match('/^bye \(referral "(sieve:\/\/)?([^"]+)/i', $line, $matches)) { // Replace the old host with the referral host // preserving any protocol prefix. $this->_data['host'] = preg_replace( '/\w+(?!(\w|\:\/\/)).*/', $matches[2], $this->_data['host'] ); $error = $this->_handleConnectAndLogin(); if (is_a($error, 'PEAR_Error')) { return $this->_pear->raiseError( 'Cannot follow referral to ' . $this->_data['host'] . ', the error was: ' . $error->getMessage(), 5 ); } break; } return $this->_pear->raiseError(trim($response . $line), 6); } if (preg_match('/^{([0-9]+)}/', $line, $matches)) { // Matches literal string responses. $line = $this->_recvBytes($matches[1] + 2); if (!$auth) { // Receive the pending OK only if we aren't // authenticating since string responses during // authentication don't need an OK. $this->_recvLn(); } return $line; } if ($auth) { // String responses during authentication don't need an // OK. $response .= $line; return rtrim($response); } $response .= $line . "\r\n"; $referralCount++; } } return $this->_pear->raiseError('Max referral count (' . $referralCount . ') reached. Cyrus murder loop error?', 7); } /** * Returns the name of the best authentication method that the server * has advertised. * * @param string $userMethod Only consider this method as available. * * @return string The name of the best supported authentication method or * a PEAR_Error object on failure. */ function _getBestAuthMethod($userMethod = null) { if (!isset($this->_capability['sasl'])) { return $this->_pear->raiseError('This server doesn\'t support any authentication methods. SASL problem?'); } if (!$this->_capability['sasl']) { return $this->_pear->raiseError('This server doesn\'t support any authentication methods.'); } if ($userMethod) { if (in_array($userMethod, $this->_capability['sasl'])) { return $userMethod; } $msg = 'No supported authentication method found. The server supports these methods: %s, but we want to use: %s'; return $this->_pear->raiseError( sprintf($msg, implode(', ', $this->_capability['sasl']), $userMethod) ); } foreach ($this->supportedAuthMethods as $method) { if (in_array($method, $this->_capability['sasl'])) { return $method; } } $msg = 'No supported authentication method found. The server supports these methods: %s, but we only support: %s'; return $this->_pear->raiseError( sprintf($msg, implode(', ', $this->_capability['sasl']), implode(', ', $this->supportedAuthMethods)) ); } /** * Starts a TLS connection. * * @return boolean True on success, PEAR_Error on failure. */ function _startTLS() { $res = $this->_doCmd('STARTTLS'); if (is_a($res, 'PEAR_Error')) { return $res; } if (isset($this->_options['ssl']['crypto_method'])) { $crypto_method = $this->_options['ssl']['crypto_method']; } else { // There is no flag to enable all TLS methods. Net_SMTP // handles enabling TLS similarly. $crypto_method = STREAM_CRYPTO_METHOD_TLS_CLIENT | @STREAM_CRYPTO_METHOD_TLSv1_1_CLIENT | @STREAM_CRYPTO_METHOD_TLSv1_2_CLIENT; } if (!stream_socket_enable_crypto($this->_sock->fp, true, $crypto_method)) { return $this->_pear->raiseError('Failed to establish TLS connection', 2); } $this->_debug('STARTTLS negotiation successful'); // The server should be sending a CAPABILITY response after // negotiating TLS. Read it, and ignore if it doesn't. // Unfortunately old Cyrus versions are broken and don't send a // CAPABILITY response, thus we would wait here forever. Parse the // Cyrus version and work around this broken behavior. if (!preg_match('/^CYRUS TIMSIEVED V([0-9.]+)/', $this->_capability['implementation'], $matches) || version_compare($matches[1], '2.3.10', '>=') ) { $res = $this->_doCmd(); } // Reset capabilities (use unattended capabilities) $this->_parseCapability(is_string($res) ? $res : ''); // Query the server capabilities again now that we are under encryption. if (empty($this->_capability['implementation'])) { $res = $this->_cmdCapability(); if (is_a($res, 'PEAR_Error')) { return $this->_pear->raiseError( 'Failed to connect, server said: ' . $res->getMessage(), 2 ); } } return true; } /** * Returns the length of a string. * * @param string $string A string. * * @return integer The length of the string. */ function _getLineLength($string) { if (extension_loaded('mbstring')) { return mb_strlen($string, '8bit'); } else { return strlen($string); } } /** * Locale independant strtoupper() implementation. * * @param string $string The string to convert to lowercase. * * @return string The lowercased string, based on ASCII encoding. */ function _toUpper($string) { $language = setlocale(LC_CTYPE, 0); setlocale(LC_CTYPE, 'C'); $string = strtoupper($string); setlocale(LC_CTYPE, $language); return $string; } /** * Converts strings into RFC's quoted-string or literal-c2s form. * * @param string $string The string to convert. * * @return string Result string. */ function _escape($string) { // Some implementations don't allow UTF-8 characters in quoted-string, // use literal-c2s. if (preg_match('/[^\x01-\x09\x0B-\x0C\x0E-\x7F]/', $string)) { return sprintf("{%d+}\r\n%s", $this->_getLineLength($string), $string); } return '"' . addcslashes($string, '\\"') . '"'; } /** * Write debug text to the current debug output handler. * * @param string $message Debug message text. * * @return void */ function _debug($message) { if ($this->_debug) { if ($this->_debug_handler) { call_user_func_array($this->_debug_handler, array(&$this, $message)); } else { echo "$message\n"; } } } } Time.pm000064400000007367152346665430006033 0ustar00# Net::Time.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. # Copyright (C) 2014 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::Time; use 5.008001; use strict; use warnings; use Carp; use Exporter; use IO::Select; use IO::Socket; use Net::Config; our @ISA = qw(Exporter); our @EXPORT_OK = qw(inet_time inet_daytime); our $VERSION = "3.11"; our $TIMEOUT = 120; sub _socket { my ($pname, $pnum, $host, $proto, $timeout) = @_; $proto ||= 'udp'; my $port = (getservbyname($pname, $proto))[2] || $pnum; my $hosts = defined $host ? [$host] : $NetConfig{$pname . '_hosts'}; my $me; foreach my $addr (@$hosts) { $me = IO::Socket::INET->new( PeerAddr => $addr, PeerPort => $port, Proto => $proto ) and last; } return unless $me; $me->send("\n") if $proto eq 'udp'; $timeout = $TIMEOUT unless defined $timeout; IO::Select->new($me)->can_read($timeout) ? $me : undef; } sub inet_time { my $s = _socket('time', 37, @_) || return; my $buf = ''; my $offset = 0 | 0; return unless defined $s->recv($buf, length(pack("N", 0))); # unpack, we | 0 to ensure we have an unsigned my $time = (unpack("N", $buf))[0] | 0; # the time protocol return time in seconds since 1900, convert # it to a the required format if ($^O eq "MacOS") { # MacOS return seconds since 1904, 1900 was not a leap year. $offset = (4 * 31536000) | 0; } else { # otherwise return seconds since 1972, there were 17 leap years between # 1900 and 1972 $offset = (70 * 31536000 + 17 * 86400) | 0; } $time - $offset; } sub inet_daytime { my $s = _socket('daytime', 13, @_) || return; my $buf = ''; defined($s->recv($buf, 1024)) ? $buf : undef; } 1; __END__ =head1 NAME Net::Time - time and daytime network client interface =head1 SYNOPSIS use Net::Time qw(inet_time inet_daytime); print inet_time(); # use default host from Net::Config print inet_time('localhost'); print inet_time('localhost', 'tcp'); print inet_daytime(); # use default host from Net::Config print inet_daytime('localhost'); print inet_daytime('localhost', 'tcp'); =head1 DESCRIPTION C provides subroutines that obtain the time on a remote machine. =over 4 =item inet_time ( [HOST [, PROTOCOL [, TIMEOUT]]]) Obtain the time on C, or some default host if C is not given or not defined, using the protocol as defined in RFC868. The optional argument C should define the protocol to use, either C or C. The result will be a time value in the same units as returned by time() or I upon failure. =item inet_daytime ( [HOST [, PROTOCOL [, TIMEOUT]]]) Obtain the time on C, or some default host if C is not given or not defined, using the protocol as defined in RFC867. The optional argument C should define the protocol to use, either C or C. The result will be an ASCII string or I upon failure. =back =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. Copyright (C) 2014 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut Cmd.pm000064400000050165152346665430005632 0ustar00# Net::Cmd.pm # # Copyright (C) 1995-2006 Graham Barr. All rights reserved. # Copyright (C) 2013-2016 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::Cmd; use 5.008001; use strict; use warnings; use Carp; use Exporter; use Symbol 'gensym'; use Errno 'EINTR'; BEGIN { if ($^O eq 'os390') { require Convert::EBCDIC; # Convert::EBCDIC->import; } } our $VERSION = "3.11"; our @ISA = qw(Exporter); our @EXPORT = qw(CMD_INFO CMD_OK CMD_MORE CMD_REJECT CMD_ERROR CMD_PENDING); use constant CMD_INFO => 1; use constant CMD_OK => 2; use constant CMD_MORE => 3; use constant CMD_REJECT => 4; use constant CMD_ERROR => 5; use constant CMD_PENDING => 0; use constant DEF_REPLY_CODE => 421; my %debug = (); my $tr = $^O eq 'os390' ? Convert::EBCDIC->new() : undef; sub toebcdic { my $cmd = shift; unless (exists ${*$cmd}{'net_cmd_asciipeer'}) { my $string = $_[0]; my $ebcdicstr = $tr->toebcdic($string); ${*$cmd}{'net_cmd_asciipeer'} = $string !~ /^\d+/ && $ebcdicstr =~ /^\d+/; } ${*$cmd}{'net_cmd_asciipeer'} ? $tr->toebcdic($_[0]) : $_[0]; } sub toascii { my $cmd = shift; ${*$cmd}{'net_cmd_asciipeer'} ? $tr->toascii($_[0]) : $_[0]; } sub _print_isa { no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict) my $pkg = shift; my $cmd = $pkg; $debug{$pkg} ||= 0; my %done = (); my @do = ($pkg); my %spc = ($pkg, ""); while ($pkg = shift @do) { next if defined $done{$pkg}; $done{$pkg} = 1; my $v = defined ${"${pkg}::VERSION"} ? "(" . ${"${pkg}::VERSION"} . ")" : ""; my $spc = $spc{$pkg}; $cmd->debug_print(1, "${spc}${pkg}${v}\n"); if (@{"${pkg}::ISA"}) { @spc{@{"${pkg}::ISA"}} = (" " . $spc{$pkg}) x @{"${pkg}::ISA"}; unshift(@do, @{"${pkg}::ISA"}); } } } sub debug { @_ == 1 or @_ == 2 or croak 'usage: $obj->debug([LEVEL])'; my ($cmd, $level) = @_; my $pkg = ref($cmd) || $cmd; my $oldval = 0; if (ref($cmd)) { $oldval = ${*$cmd}{'net_cmd_debug'} || 0; } else { $oldval = $debug{$pkg} || 0; } return $oldval unless @_ == 2; $level = $debug{$pkg} || 0 unless defined $level; _print_isa($pkg) if ($level && !exists $debug{$pkg}); if (ref($cmd)) { ${*$cmd}{'net_cmd_debug'} = $level; } else { $debug{$pkg} = $level; } $oldval; } sub message { @_ == 1 or croak 'usage: $obj->message()'; my $cmd = shift; wantarray ? @{${*$cmd}{'net_cmd_resp'}} : join("", @{${*$cmd}{'net_cmd_resp'}}); } sub debug_text { $_[2] } sub debug_print { my ($cmd, $out, $text) = @_; print STDERR $cmd, ($out ? '>>> ' : '<<< '), $cmd->debug_text($out, $text); } sub code { @_ == 1 or croak 'usage: $obj->code()'; my $cmd = shift; ${*$cmd}{'net_cmd_code'} = $cmd->DEF_REPLY_CODE unless exists ${*$cmd}{'net_cmd_code'}; ${*$cmd}{'net_cmd_code'}; } sub status { @_ == 1 or croak 'usage: $obj->status()'; my $cmd = shift; substr(${*$cmd}{'net_cmd_code'}, 0, 1); } sub set_status { @_ == 3 or croak 'usage: $obj->set_status(CODE, MESSAGE)'; my $cmd = shift; my ($code, $resp) = @_; $resp = defined $resp ? [$resp] : [] unless ref($resp); (${*$cmd}{'net_cmd_code'}, ${*$cmd}{'net_cmd_resp'}) = ($code, $resp); 1; } sub _syswrite_with_timeout { my $cmd = shift; my $line = shift; my $len = length($line); my $offset = 0; my $win = ""; vec($win, fileno($cmd), 1) = 1; my $timeout = $cmd->timeout || undef; my $initial = time; my $pending = $timeout; local $SIG{PIPE} = 'IGNORE' unless $^O eq 'MacOS'; while ($len) { my $wout; my $nfound = select(undef, $wout = $win, undef, $pending); if ((defined $nfound and $nfound > 0) or -f $cmd) # -f for testing on win32 { my $w = syswrite($cmd, $line, $len, $offset); if (! defined($w) ) { my $err = $!; $cmd->close; $cmd->_set_status_closed($err); return; } $len -= $w; $offset += $w; } elsif ($nfound == -1) { if ( $! == EINTR ) { if ( defined($timeout) ) { redo if ($pending = $timeout - ( time - $initial ) ) > 0; $cmd->_set_status_timeout; return; } redo; } my $err = $!; $cmd->close; $cmd->_set_status_closed($err); return; } else { $cmd->_set_status_timeout; return; } } return 1; } sub _set_status_timeout { my $cmd = shift; my $pkg = ref($cmd) || $cmd; $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Timeout"); carp(ref($cmd) . ": " . (caller(1))[3] . "(): timeout") if $cmd->debug; } sub _set_status_closed { my $cmd = shift; my $err = shift; my $pkg = ref($cmd) || $cmd; $cmd->set_status($cmd->DEF_REPLY_CODE, "[$pkg] Connection closed"); carp(ref($cmd) . ": " . (caller(1))[3] . "(): unexpected EOF on command channel: $err") if $cmd->debug; } sub _is_closed { my $cmd = shift; if (!defined fileno($cmd)) { $cmd->_set_status_closed($!); return 1; } return 0; } sub command { my $cmd = shift; return $cmd if $cmd->_is_closed; $cmd->dataend() if (exists ${*$cmd}{'net_cmd_last_ch'}); if (scalar(@_)) { my $str = join( " ", map { /\n/ ? do { my $n = $_; $n =~ tr/\n/ /; $n } : $_; } @_ ); $str = $cmd->toascii($str) if $tr; $str .= "\015\012"; $cmd->debug_print(1, $str) if ($cmd->debug); # though documented to return undef on failure, the legacy behavior # was to return $cmd even on failure, so this odd construct does that $cmd->_syswrite_with_timeout($str) or return $cmd; } $cmd; } sub ok { @_ == 1 or croak 'usage: $obj->ok()'; my $code = $_[0]->code; 0 < $code && $code < 400; } sub unsupported { my $cmd = shift; $cmd->set_status(580, 'Unsupported command'); 0; } sub getline { my $cmd = shift; ${*$cmd}{'net_cmd_lines'} ||= []; return shift @{${*$cmd}{'net_cmd_lines'}} if scalar(@{${*$cmd}{'net_cmd_lines'}}); my $partial = defined(${*$cmd}{'net_cmd_partial'}) ? ${*$cmd}{'net_cmd_partial'} : ""; return if $cmd->_is_closed; my $fd = fileno($cmd); my $rin = ""; vec($rin, $fd, 1) = 1; my $buf; until (scalar(@{${*$cmd}{'net_cmd_lines'}})) { my $timeout = $cmd->timeout || undef; my $rout; my $select_ret = select($rout = $rin, undef, undef, $timeout); if ($select_ret > 0) { unless (sysread($cmd, $buf = "", 1024)) { my $err = $!; $cmd->close; $cmd->_set_status_closed($err); return; } substr($buf, 0, 0) = $partial; ## prepend from last sysread my @buf = split(/\015?\012/, $buf, -1); ## break into lines $partial = pop @buf; push(@{${*$cmd}{'net_cmd_lines'}}, map {"$_\n"} @buf); } else { $cmd->_set_status_timeout; return; } } ${*$cmd}{'net_cmd_partial'} = $partial; if ($tr) { foreach my $ln (@{${*$cmd}{'net_cmd_lines'}}) { $ln = $cmd->toebcdic($ln); } } shift @{${*$cmd}{'net_cmd_lines'}}; } sub ungetline { my ($cmd, $str) = @_; ${*$cmd}{'net_cmd_lines'} ||= []; unshift(@{${*$cmd}{'net_cmd_lines'}}, $str); } sub parse_response { return () unless $_[1] =~ s/^(\d\d\d)(.?)//o; ($1, $2 eq "-"); } sub response { my $cmd = shift; my ($code, $more) = (undef) x 2; $cmd->set_status($cmd->DEF_REPLY_CODE, undef); # initialize the response while (1) { my $str = $cmd->getline(); return CMD_ERROR unless defined($str); $cmd->debug_print(0, $str) if ($cmd->debug); ($code, $more) = $cmd->parse_response($str); unless (defined $code) { carp("$cmd: response(): parse error in '$str'") if ($cmd->debug); $cmd->ungetline($str); $@ = $str; # $@ used as tunneling hack return CMD_ERROR; } ${*$cmd}{'net_cmd_code'} = $code; push(@{${*$cmd}{'net_cmd_resp'}}, $str); last unless ($more); } return unless defined $code; substr($code, 0, 1); } sub read_until_dot { my $cmd = shift; my $fh = shift; my $arr = []; while (1) { my $str = $cmd->getline() or return; $cmd->debug_print(0, $str) if ($cmd->debug & 4); last if ($str =~ /^\.\r?\n/o); $str =~ s/^\.\././o; if (defined $fh) { print $fh $str; } else { push(@$arr, $str); } } $arr; } sub datasend { my $cmd = shift; my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; my $line = join("", @$arr); # Perls < 5.10.1 (with the exception of 5.8.9) have a performance problem with # the substitutions below when dealing with strings stored internally in # UTF-8, so downgrade them (if possible). # Data passed to datasend() should be encoded to octets upstream already so # shouldn't even have the UTF-8 flag on to start with, but if it so happens # that the octets are stored in an upgraded string (as can sometimes occur) # then they would still downgrade without fail anyway. # Only Unicode codepoints > 0xFF stored in an upgraded string will fail to # downgrade. We fail silently in that case, and a "Wide character in print" # warning will be emitted later by syswrite(). utf8::downgrade($line, 1) if $] < 5.010001 && $] != 5.008009; return 0 if $cmd->_is_closed; my $last_ch = ${*$cmd}{'net_cmd_last_ch'}; # We have not send anything yet, so last_ch = "\012" means we are at the start of a line $last_ch = ${*$cmd}{'net_cmd_last_ch'} = "\012" unless defined $last_ch; return 1 unless length $line; if ($cmd->debug) { foreach my $b (split(/\n/, $line)) { $cmd->debug_print(1, "$b\n"); } } $line =~ tr/\r\n/\015\012/ unless "\r" eq "\015"; my $first_ch = ''; if ($last_ch eq "\015") { # Remove \012 so it does not get prefixed with another \015 below # and escape the . if there is one following it because the fixup # below will not find it $first_ch = "\012" if $line =~ s/^\012(\.?)/$1$1/; } elsif ($last_ch eq "\012") { # Fixup below will not find the . as the first character of the buffer $first_ch = "." if $line =~ /^\./; } $line =~ s/\015?\012(\.?)/\015\012$1$1/sg; substr($line, 0, 0) = $first_ch; ${*$cmd}{'net_cmd_last_ch'} = substr($line, -1, 1); $cmd->_syswrite_with_timeout($line) or return; 1; } sub rawdatasend { my $cmd = shift; my $arr = @_ == 1 && ref($_[0]) ? $_[0] : \@_; my $line = join("", @$arr); return 0 if $cmd->_is_closed; return 1 unless length($line); if ($cmd->debug) { my $b = "$cmd>>> "; print STDERR $b, join("\n$b", split(/\n/, $line)), "\n"; } $cmd->_syswrite_with_timeout($line) or return; 1; } sub dataend { my $cmd = shift; return 0 if $cmd->_is_closed; my $ch = ${*$cmd}{'net_cmd_last_ch'}; my $tosend; if (!defined $ch) { return 1; } elsif ($ch ne "\012") { $tosend = "\015\012"; } $tosend .= ".\015\012"; $cmd->debug_print(1, ".\n") if ($cmd->debug); $cmd->_syswrite_with_timeout($tosend) or return 0; delete ${*$cmd}{'net_cmd_last_ch'}; $cmd->response() == CMD_OK; } # read and write to tied filehandle sub tied_fh { my $cmd = shift; ${*$cmd}{'net_cmd_readbuf'} = ''; my $fh = gensym(); tie *$fh, ref($cmd), $cmd; return $fh; } # tie to myself sub TIEHANDLE { my $class = shift; my $cmd = shift; return $cmd; } # Tied filehandle read. Reads requested data length, returning # end-of-file when the dot is encountered. sub READ { my $cmd = shift; my ($len, $offset) = @_[1, 2]; return unless exists ${*$cmd}{'net_cmd_readbuf'}; my $done = 0; while (!$done and length(${*$cmd}{'net_cmd_readbuf'}) < $len) { ${*$cmd}{'net_cmd_readbuf'} .= $cmd->getline() or return; $done++ if ${*$cmd}{'net_cmd_readbuf'} =~ s/^\.\r?\n\Z//m; } $_[0] = ''; substr($_[0], $offset + 0) = substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len); substr(${*$cmd}{'net_cmd_readbuf'}, 0, $len) = ''; delete ${*$cmd}{'net_cmd_readbuf'} if $done; return length $_[0]; } sub READLINE { my $cmd = shift; # in this context, we use the presence of readbuf to # indicate that we have not yet reached the eof return unless exists ${*$cmd}{'net_cmd_readbuf'}; my $line = $cmd->getline; return if $line =~ /^\.\r?\n/; $line; } sub PRINT { my $cmd = shift; my ($buf, $len, $offset) = @_; $len ||= length($buf); $offset += 0; return unless $cmd->datasend(substr($buf, $offset, $len)); ${*$cmd}{'net_cmd_sending'}++; # flag that we should call dataend() return $len; } sub CLOSE { my $cmd = shift; my $r = exists(${*$cmd}{'net_cmd_sending'}) ? $cmd->dataend : 1; delete ${*$cmd}{'net_cmd_readbuf'}; delete ${*$cmd}{'net_cmd_sending'}; $r; } 1; __END__ =head1 NAME Net::Cmd - Network Command class (as used by FTP, SMTP etc) =head1 SYNOPSIS use Net::Cmd; @ISA = qw(Net::Cmd); =head1 DESCRIPTION C is a collection of methods that can be inherited by a sub-class of C. These methods implement the functionality required for a command based protocol, for example FTP and SMTP. If your sub-class does not also derive from C or similar (e.g. C, C or C) then you must provide the following methods by other means yourself: C and C. =head1 USER METHODS These methods provide a user interface to the C object. =over 4 =item debug ( VALUE ) Set the level of debug information for this object. If C is not given then the current state is returned. Otherwise the state is changed to C and the previous state returned. Different packages may implement different levels of debug but a non-zero value results in copies of all commands and responses also being sent to STDERR. If C is C then the debug level will be set to the default debug level for the class. This method can also be called as a I method to set/get the default debug level for a given class. =item message () Returns the text message returned from the last command. In a scalar context it returns a single string, in a list context it will return each line as a separate element. (See L below.) =item code () Returns the 3-digit code from the last command. If a command is pending then the value 0 is returned. (See L below.) =item ok () Returns non-zero if the last code value was greater than zero and less than 400. This holds true for most command servers. Servers where this does not hold may override this method. =item status () Returns the most significant digit of the current status code. If a command is pending then C is returned. =item datasend ( DATA ) Send data to the remote server, converting LF to CRLF. Any line starting with a '.' will be prefixed with another '.'. C may be an array or a reference to an array. The C passed in must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. =item dataend () End the sending of data to the remote server. This is done by ensuring that the data already sent ends with CRLF then sending '.CRLF' to end the transmission. Once this data has been sent C calls C and returns true if C returns CMD_OK. =back =head1 CLASS METHODS These methods are not intended to be called by the user, but used or over-ridden by a sub-class of C =over 4 =item debug_print ( DIR, TEXT ) Print debugging information. C denotes the direction I being data being sent to the server. Calls C before printing to STDERR. =item debug_text ( DIR, TEXT ) This method is called to print debugging information. TEXT is the text being sent. The method should return the text to be printed. This is primarily meant for the use of modules such as FTP where passwords are sent, but we do not want to display them in the debugging information. =item command ( CMD [, ARGS, ... ]) Send a command to the command server. All arguments are first joined with a space character and CRLF is appended, this string is then sent to the command server. Returns undef upon failure. =item unsupported () Sets the status code to 580 and the response text to 'Unsupported command'. Returns zero. =item response () Obtain a response from the server. Upon success the most significant digit of the status code is returned. Upon failure, timeout etc., I is returned. =item parse_response ( TEXT ) This method is called by C as a method with one argument. It should return an array of 2 values, the 3-digit status code and a flag which is true when this is part of a multi-line response and this line is not the last. =item getline () Retrieve one line, delimited by CRLF, from the remote server. Returns I upon failure. B: If you do use this method for any reason, please remember to add some C calls into your method. =item ungetline ( TEXT ) Unget a line of text from the server. =item rawdatasend ( DATA ) Send data to the remote server without performing any conversions. C is a scalar. As with C, the C passed in must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. =item read_until_dot () Read data from the remote server until a line consisting of a single '.'. Any lines starting with '..' will have one of the '.'s removed. Returns a reference to a list containing the lines, or I upon failure. =item tied_fh () Returns a filehandle tied to the Net::Cmd object. After issuing a command, you may read from this filehandle using read() or <>. The filehandle will return EOF when the final dot is encountered. Similarly, you may write to the filehandle in order to send data to the server after issuing a command that expects data to be written. See the Net::POP3 and Net::SMTP modules for examples of this. =back =head1 PSEUDO RESPONSES Normally the values returned by C and C are obtained from the remote server, but in a few circumstances, as detailed below, C will return values that it sets. You can alter this behavior by overriding DEF_REPLY_CODE() to specify a different default reply code, or overriding one of the specific error handling methods below. =over 4 =item Initial value Before any command has executed or if an unexpected error occurs C will return "421" (temporary connection failure) and C will return undef. =item Connection closed If the underlying C is closed, or if there are any read or write failures, the file handle will be forced closed, and C will return "421" (temporary connection failure) and C will return "[$pkg] Connection closed" (where $pkg is the name of the class that subclassed C). The _set_status_closed() method can be overridden to set a different message (by calling set_status()) or otherwise trap this error. =item Timeout If there is a read or write timeout C will return "421" (temporary connection failure) and C will return "[$pkg] Timeout" (where $pkg is the name of the class that subclassed C). The _set_status_timeout() method can be overridden to set a different message (by calling set_status()) or otherwise trap this error. =back =head1 EXPORTS C exports six subroutines, five of these, C, C, C, C and C, correspond to possible results of C and C. The sixth is C. =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2006 Graham Barr. All rights reserved. Copyright (C) 2013-2016 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut HTTPS.pm000064400000006737152346665430006037 0ustar00package Net::HTTPS; $Net::HTTPS::VERSION = '6.17'; use strict; use warnings; # Figure out which SSL implementation to use use vars qw($SSL_SOCKET_CLASS); if ($SSL_SOCKET_CLASS) { # somebody already set it } elsif ($SSL_SOCKET_CLASS = $ENV{PERL_NET_HTTPS_SSL_SOCKET_CLASS}) { unless ($SSL_SOCKET_CLASS =~ /^(IO::Socket::SSL|Net::SSL)\z/) { die "Bad socket class [$SSL_SOCKET_CLASS]"; } eval "require $SSL_SOCKET_CLASS"; die $@ if $@; } elsif ($IO::Socket::SSL::VERSION) { $SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded } elsif ($Net::SSL::VERSION) { $SSL_SOCKET_CLASS = "Net::SSL"; } else { eval { require IO::Socket::SSL; }; if ($@) { my $old_errsv = $@; eval { require Net::SSL; # from Crypt-SSLeay }; if ($@) { $old_errsv =~ s/\s\(\@INC contains:.*\)/)/g; die $old_errsv . $@; } $SSL_SOCKET_CLASS = "Net::SSL"; } else { $SSL_SOCKET_CLASS = "IO::Socket::SSL"; } } require Net::HTTP::Methods; our @ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods'); sub configure { my($self, $cnf) = @_; $self->http_configure($cnf); } sub http_connect { my($self, $cnf) = @_; if ($self->isa("Net::SSL")) { if ($cnf->{SSL_verify_mode}) { if (my $f = $cnf->{SSL_ca_file}) { $ENV{HTTPS_CA_FILE} = $f; } if (my $f = $cnf->{SSL_ca_path}) { $ENV{HTTPS_CA_DIR} = $f; } } if ($cnf->{SSL_verifycn_scheme}) { $@ = "Net::SSL from Crypt-SSLeay can't verify hostnames; either install IO::Socket::SSL or turn off verification by setting the PERL_LWP_SSL_VERIFY_HOSTNAME environment variable to 0"; return undef; } } $self->SUPER::configure($cnf); } sub http_default_port { 443; } if ($SSL_SOCKET_CLASS eq "Net::SSL") { # The underlying SSLeay classes fails to work if the socket is # placed in non-blocking mode. This override of the blocking # method makes sure it stays the way it was created. *blocking = sub { }; } 1; =pod =encoding UTF-8 =head1 NAME Net::HTTPS - Low-level HTTP over SSL/TLS connection (client) =head1 VERSION version 6.17 =head1 DESCRIPTION The C is a low-level HTTP over SSL/TLS client. The interface is the same as the interface for C, but the constructor takes additional parameters as accepted by L. The C object is an C too, which makes it inherit additional methods from that base class. For historical reasons this module also supports using C (from the Crypt-SSLeay distribution) as its SSL driver and base class. This base is automatically selected if available and C isn't. You might also force which implementation to use by setting $Net::HTTPS::SSL_SOCKET_CLASS before loading this module. If not set this variable is initialized from the C environment variable. =head1 ENVIRONMENT You might set the C environment variable to the name of the base SSL implementation (and Net::HTTPS base class) to use. The default is C. Currently the only other supported value is C. =head1 SEE ALSO L, L =head1 AUTHOR Gisle Aas =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2001-2017 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: Low-level HTTP over SSL/TLS connection (client) libnetFAQ.pod000064400000000362152346665430007074 0ustar00=encoding utf-8 The L. You can access the original document on L. HTTP.pm000064400000023645152346665430005711 0ustar00package Net::HTTP; $Net::HTTP::VERSION = '6.17'; use strict; use warnings; use vars qw($SOCKET_CLASS); unless ($SOCKET_CLASS) { # Try several, in order of capability and preference if (eval { require IO::Socket::IP }) { $SOCKET_CLASS = "IO::Socket::IP"; # IPv4+IPv6 } elsif (eval { require IO::Socket::INET6 }) { $SOCKET_CLASS = "IO::Socket::INET6"; # IPv4+IPv6 } elsif (eval { require IO::Socket::INET }) { $SOCKET_CLASS = "IO::Socket::INET"; # IPv4 only } else { require IO::Socket; $SOCKET_CLASS = "IO::Socket::INET"; } } require Net::HTTP::Methods; require Carp; our @ISA = ($SOCKET_CLASS, 'Net::HTTP::Methods'); sub new { my $class = shift; Carp::croak("No Host option provided") unless @_; $class->SUPER::new(@_); } sub configure { my($self, $cnf) = @_; $self->http_configure($cnf); } sub http_connect { my($self, $cnf) = @_; $self->SUPER::configure($cnf); } 1; =pod =encoding UTF-8 =head1 NAME Net::HTTP - Low-level HTTP connection (client) =head1 VERSION version 6.17 =head1 SYNOPSIS use Net::HTTP; my $s = Net::HTTP->new(Host => "www.perl.com") || die $@; $s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0"); my($code, $mess, %h) = $s->read_response_headers; while (1) { my $buf; my $n = $s->read_entity_body($buf, 1024); die "read failed: $!" unless defined $n; last unless $n; print $buf; } =head1 DESCRIPTION The C class is a low-level HTTP client. An instance of the C class represents a connection to an HTTP server. The HTTP protocol is described in RFC 2616. The C class supports C and C. C is a sub-class of one of C (IPv6+IPv4), C (IPv6+IPv4), or C (IPv4 only). You can mix the methods described below with reading and writing from the socket directly. This is not necessary a good idea, unless you know what you are doing. The following methods are provided (in addition to those of C): =over =item $s = Net::HTTP->new( %options ) The C constructor method takes the same options as C's as well as these: Host: Initial host attribute value KeepAlive: Initial keep_alive attribute value SendTE: Initial send_te attribute_value HTTPVersion: Initial http_version attribute value PeerHTTPVersion: Initial peer_http_version attribute value MaxLineLength: Initial max_line_length attribute value MaxHeaderLines: Initial max_header_lines attribute value The C option is also the default for C's C. The C defaults to 80 if not provided. The C specification can also be embedded in the C by preceding it with a ":", and closing the IPv6 address on brackets "[]" if necessary: "192.0.2.1:80","[2001:db8::1]:80","any.example.com:80". The C option provided by C's constructor method is not allowed. If unable to connect to the given HTTP server then the constructor returns C and $@ contains the reason. After a successful connect, a C object is returned. =item $s->host Get/set the default value of the C header to send. The $host must not be set to an empty string (or C) for HTTP/1.1. =item $s->keep_alive Get/set the I value. If this value is TRUE then the request will be sent with headers indicating that the server should try to keep the connection open so that multiple requests can be sent. The actual headers set will depend on the value of the C and C attributes. =item $s->send_te Get/set the a value indicating if the request will be sent with a "TE" header to indicate the transfer encodings that the server can choose to use. The list of encodings announced as accepted by this client depends on availability of the following modules: C for I, and C for I. =item $s->http_version Get/set the HTTP version number that this client should announce. This value can only be set to "1.0" or "1.1". The default is "1.1". =item $s->peer_http_version Get/set the protocol version number of our peer. This value will initially be "1.0", but will be updated by a successful read_response_headers() method call. =item $s->max_line_length Get/set a limit on the length of response line and response header lines. The default is 8192. A value of 0 means no limit. =item $s->max_header_length Get/set a limit on the number of header lines that a response can have. The default is 128. A value of 0 means no limit. =item $s->format_request($method, $uri, %headers, [$content]) Format a request message and return it as a string. If the headers do not include a C header, then a header is inserted with the value of the C attribute. Headers like C and C might also be added depending on the status of the C attribute. If $content is given (and it is non-empty), then a C header is automatically added unless it was already present. =item $s->write_request($method, $uri, %headers, [$content]) Format and send a request message. Arguments are the same as for format_request(). Returns true if successful. =item $s->format_chunk( $data ) Returns the string to be written for the given chunk of data. =item $s->write_chunk($data) Will write a new chunk of request entity body data. This method should only be used if the C header with a value of C was sent in the request. Note, writing zero-length data is a no-op. Use the write_chunk_eof() method to signal end of entity body data. Returns true if successful. =item $s->format_chunk_eof( %trailers ) Returns the string to be written for signaling EOF when a C of C is used. =item $s->write_chunk_eof( %trailers ) Will write eof marker for chunked data and optional trailers. Note that trailers should not really be used unless is was signaled with a C header. Returns true if successful. =item ($code, $mess, %headers) = $s->read_response_headers( %opts ) Read response headers from server and return it. The $code is the 3 digit HTTP status code (see L) and $mess is the textual message that came with it. Headers are then returned as key/value pairs. Since key letter casing is not normalized and the same key can even occur multiple times, assigning these values directly to a hash is not wise. Only the $code is returned if this method is called in scalar context. As a side effect this method updates the 'peer_http_version' attribute. Options might be passed in as key/value pairs. There are currently only two options supported; C and C. The C option will make read_response_headers() more forgiving towards servers that have not learned how to speak HTTP properly. The C option is a boolean flag, and is enabled by passing in a TRUE value. The C option can be used to capture bad header lines when C is enabled. The value should be an array reference. Bad header lines will be pushed onto the array. The C option must be specified in order to communicate with pre-HTTP/1.0 servers that don't describe the response outcome or the data they send back with a header block. For these servers peer_http_version is set to "0.9" and this method returns (200, "Assumed OK"). The method will raise an exception (die) if the server does not speak proper HTTP or if the C or C limits are reached. If the C option is turned on and C and C checks are turned off, then no exception will be raised and this method will always return a response code. =item $n = $s->read_entity_body($buf, $size); Reads chunks of the entity body content. Basically the same interface as for read() and sysread(), but the buffer offset argument is not supported yet. This method should only be called after a successful read_response_headers() call. The return value will be C on read errors, 0 on EOF, -1 if no data could be returned this time, otherwise the number of bytes assigned to $buf. The $buf is set to "" when the return value is -1. You normally want to retry this call if this function returns either -1 or C with C<$!> as EINTR or EAGAIN (see L). EINTR can happen if the application catches signals and EAGAIN can happen if you made the socket non-blocking. This method will raise exceptions (die) if the server does not speak proper HTTP. This can only happen when reading chunked data. =item %headers = $s->get_trailers After read_entity_body() has returned 0 to indicate end of the entity body, you might call this method to pick up any trailers. =item $s->_rbuf Get/set the read buffer content. The read_response_headers() and read_entity_body() methods use an internal buffer which they will look for data before they actually sysread more from the socket itself. If they read too much, the remaining data will be left in this buffer. =item $s->_rbuf_length Returns the number of bytes in the read buffer. This should always be the same as: length($s->_rbuf) but might be more efficient. =back =head1 SUBCLASSING The read_response_headers() and read_entity_body() will invoke the sysread() method when they need more data. Subclasses might want to override this method to control how reading takes place. The object itself is a glob. Subclasses should avoid using hash key names prefixed with C and C. =head1 SEE ALSO L, L, L =head1 AUTHOR Gisle Aas =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2001-2017 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ # ABSTRACT: Low-level HTTP connection (client) Domain.pm000064400000020053152346665430006327 0ustar00# Net::Domain.pm # # Copyright (C) 1995-1998 Graham Barr. All rights reserved. # Copyright (C) 2013-2014 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::Domain; use 5.008001; use strict; use warnings; use Carp; use Exporter; use Net::Config; our @ISA = qw(Exporter); our @EXPORT_OK = qw(hostname hostdomain hostfqdn domainname); our $VERSION = "3.11"; my ($host, $domain, $fqdn) = (undef, undef, undef); # Try every conceivable way to get hostname. sub _hostname { # we already know it return $host if (defined $host); if ($^O eq 'MSWin32') { require Socket; my ($name, $alias, $type, $len, @addr) = gethostbyname($ENV{'COMPUTERNAME'} || 'localhost'); while (@addr) { my $a = shift(@addr); $host = gethostbyaddr($a, Socket::AF_INET()); last if defined $host; } if (defined($host) && index($host, '.') > 0) { $fqdn = $host; ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; } return $host; } elsif ($^O eq 'MacOS') { chomp($host = `hostname`); } elsif ($^O eq 'VMS') { ## multiple varieties of net s/w makes this hard $host = $ENV{'UCX$INET_HOST'} if defined($ENV{'UCX$INET_HOST'}); $host = $ENV{'MULTINET_HOST_NAME'} if defined($ENV{'MULTINET_HOST_NAME'}); if (index($host, '.') > 0) { $fqdn = $host; ($host, $domain) = $fqdn =~ /^([^.]+)\.(.*)$/; } return $host; } else { local $SIG{'__DIE__'}; # syscall is preferred since it avoids tainting problems eval { my $tmp = "\0" x 256; ## preload scalar eval { package main; require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) defined(&main::SYS_gethostname); } || eval { package main; require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) defined(&main::SYS_gethostname); } and $host = (syscall(&main::SYS_gethostname, $tmp, 256) == 0) ? $tmp : undef; } # POSIX || eval { require POSIX; $host = (POSIX::uname())[1]; } # trusty old hostname command || eval { chop($host = `(hostname) 2>/dev/null`); # BSD'ish } # sysV/POSIX uname command (may truncate) || eval { chop($host = `uname -n 2>/dev/null`); ## SYSV'ish && POSIX'ish } # Apollo pre-SR10 || eval { $host = (split(/[:. ]/, `/com/host`, 6))[0]; } || eval { $host = ""; }; } # remove garbage $host =~ s/[\0\r\n]+//go; $host =~ s/(\A\.+|\.+\Z)//go; $host =~ s/\.\.+/\./go; $host; } sub _hostdomain { # we already know it return $domain if (defined $domain); local $SIG{'__DIE__'}; return $domain = $NetConfig{'inet_domain'} if defined $NetConfig{'inet_domain'}; # try looking in /etc/resolv.conf # putting this here and assuming that it is correct, eliminates # calls to gethostbyname, and therefore DNS lookups. This helps # those on dialup systems. local ($_); if (open(my $res, '<', "/etc/resolv.conf")) { while (<$res>) { $domain = $1 if (/\A\s*(?:domain|search)\s+(\S+)/); } close($res); return $domain if (defined $domain); } # just try hostname and system calls my $host = _hostname(); my (@hosts); @hosts = ($host, "localhost"); unless (defined($host) && $host =~ /\./) { my $dom = undef; eval { my $tmp = "\0" x 256; ## preload scalar eval { package main; require "syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) } || eval { package main; require "sys/syscall.ph"; ## no critic (Modules::RequireBarewordIncludes) } and $dom = (syscall(&main::SYS_getdomainname, $tmp, 256) == 0) ? $tmp : undef; }; if ($^O eq 'VMS') { $dom ||= $ENV{'TCPIP$INET_DOMAIN'} || $ENV{'UCX$INET_DOMAIN'}; } chop($dom = `domainname 2>/dev/null`) unless (defined $dom || $^O =~ /^(?:cygwin|MSWin32|android)/); if (defined $dom) { my @h = (); $dom =~ s/^\.+//; while (length($dom)) { push(@h, "$host.$dom"); $dom =~ s/^[^.]+.+// or last; } unshift(@hosts, @h); } } # Attempt to locate FQDN foreach (grep { defined $_ } @hosts) { my @info = gethostbyname($_); next unless @info; # look at real name & aliases foreach my $site ($info[0], split(/ /, $info[1])) { if (rindex($site, ".") > 0) { # Extract domain from FQDN ($domain = $site) =~ s/\A[^.]+\.//; return $domain; } } } # Look for environment variable $domain ||= $ENV{LOCALDOMAIN} || $ENV{DOMAIN}; if (defined $domain) { $domain =~ s/[\r\n\0]+//g; $domain =~ s/(\A\.+|\.+\Z)//g; $domain =~ s/\.\.+/\./g; } $domain; } sub domainname { return $fqdn if (defined $fqdn); _hostname(); # *.local names are special on darwin. If we call gethostbyname below, it # may hang while waiting for another, non-existent computer to respond. if($^O eq 'darwin' && $host =~ /\.local$/) { return $host; } _hostdomain(); # Assumption: If the host name does not contain a period # and the domain name does, then assume that they are correct # this helps to eliminate calls to gethostbyname, and therefore # eliminate DNS lookups return $fqdn = $host . "." . $domain if (defined $host and defined $domain and $host !~ /\./ and $domain =~ /\./); # For hosts that have no name, just an IP address return $fqdn = $host if defined $host and $host =~ /^\d+(\.\d+){3}$/; my @host = defined $host ? split(/\./, $host) : ('localhost'); my @domain = defined $domain ? split(/\./, $domain) : (); my @fqdn = (); # Determine from @host & @domain the FQDN my @d = @domain; LOOP: while (1) { my @h = @host; while (@h) { my $tmp = join(".", @h, @d); if ((gethostbyname($tmp))[0]) { @fqdn = (@h, @d); $fqdn = $tmp; last LOOP; } pop @h; } last unless shift @d; } if (@fqdn) { $host = shift @fqdn; until ((gethostbyname($host))[0]) { $host .= "." . shift @fqdn; } $domain = join(".", @fqdn); } else { undef $host; undef $domain; undef $fqdn; } $fqdn; } sub hostfqdn { domainname() } sub hostname { domainname() unless (defined $host); return $host; } sub hostdomain { domainname() unless (defined $domain); return $domain; } 1; # Keep require happy __END__ =head1 NAME Net::Domain - Attempt to evaluate the current host's internet name and domain =head1 SYNOPSIS use Net::Domain qw(hostname hostfqdn hostdomain domainname); =head1 DESCRIPTION Using various methods B to find the Fully Qualified Domain Name (FQDN) of the current host. From this determine the host-name and the host-domain. Each of the functions will return I if the FQDN cannot be determined. =over 4 =item hostfqdn () Identify and return the FQDN of the current host. =item domainname () An alias for hostfqdn (). =item hostname () Returns the smallest part of the FQDN which can be used to identify the host. =item hostdomain () Returns the remainder of the FQDN after the I has been removed. =back =head1 AUTHOR Graham Barr EFE. Adapted from Sys::Hostname by David Sundstrom EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-1998 Graham Barr. All rights reserved. Copyright (C) 2013-2014 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut HTTP/Methods.pm000064400000041705152346665430007311 0ustar00package Net::HTTP::Methods; $Net::HTTP::Methods::VERSION = '6.17'; use strict; use warnings; use URI; my $CRLF = "\015\012"; # "\r\n" is not portable *_bytes = defined(&utf8::downgrade) ? sub { unless (utf8::downgrade($_[0], 1)) { require Carp; Carp::croak("Wide character in HTTP request (bytes required)"); } return $_[0]; } : sub { return $_[0]; }; sub new { my $class = shift; unshift(@_, "Host") if @_ == 1; my %cnf = @_; require Symbol; my $self = bless Symbol::gensym(), $class; return $self->http_configure(\%cnf); } sub http_configure { my($self, $cnf) = @_; die "Listen option not allowed" if $cnf->{Listen}; my $explicit_host = (exists $cnf->{Host}); my $host = delete $cnf->{Host}; my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost}; if (!$peer) { die "No Host option provided" unless $host; $cnf->{PeerAddr} = $peer = $host; } # CONNECTIONS # PREFER: port number from PeerAddr, then PeerPort, then http_default_port my $peer_uri = URI->new("http://$peer"); $cnf->{"PeerPort"} = $peer_uri->_port || $cnf->{PeerPort} || $self->http_default_port; $cnf->{"PeerAddr"} = $peer_uri->host; # HOST header: # If specified but blank, ignore. # If specified with a value, add the port number # If not specified, set to PeerAddr and port number # ALWAYS: If IPv6 address, use [brackets] (thanks to the URI package) # ALWAYS: omit port number if http_default_port if (($host) || (! $explicit_host)) { my $uri = ($explicit_host) ? URI->new("http://$host") : $peer_uri->clone; if (!$uri->_port) { # Always use *our* $self->http_default_port instead of URI's (Covers HTTP, HTTPS) $uri->port( $cnf->{PeerPort} || $self->http_default_port); } my $host_port = $uri->host_port; # Returns host:port or [ipv6]:port my $remove = ":" . $self->http_default_port; # we want to remove the default port number if (substr($host_port,0-length($remove)) eq $remove) { substr($host_port,0-length($remove)) = ""; } $host = $host_port; } $cnf->{Proto} = 'tcp'; my $keep_alive = delete $cnf->{KeepAlive}; my $http_version = delete $cnf->{HTTPVersion}; $http_version = "1.1" unless defined $http_version; my $peer_http_version = delete $cnf->{PeerHTTPVersion}; $peer_http_version = "1.0" unless defined $peer_http_version; my $send_te = delete $cnf->{SendTE}; my $max_line_length = delete $cnf->{MaxLineLength}; $max_line_length = 8*1024 unless defined $max_line_length; my $max_header_lines = delete $cnf->{MaxHeaderLines}; $max_header_lines = 128 unless defined $max_header_lines; return undef unless $self->http_connect($cnf); $self->host($host); $self->keep_alive($keep_alive); $self->send_te($send_te); $self->http_version($http_version); $self->peer_http_version($peer_http_version); $self->max_line_length($max_line_length); $self->max_header_lines($max_header_lines); ${*$self}{'http_buf'} = ""; return $self; } sub http_default_port { 80; } # set up property accessors for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) { my $prop_name = "http_" . $method; no strict 'refs'; *$method = sub { my $self = shift; my $old = ${*$self}{$prop_name}; ${*$self}{$prop_name} = shift if @_; return $old; }; } # we want this one to be a bit smarter sub http_version { my $self = shift; my $old = ${*$self}{'http_version'}; if (@_) { my $v = shift; $v = "1.0" if $v eq "1"; # float unless ($v eq "1.0" or $v eq "1.1") { require Carp; Carp::croak("Unsupported HTTP version '$v'"); } ${*$self}{'http_version'} = $v; } $old; } sub format_request { my $self = shift; my $method = shift; my $uri = shift; my $content = (@_ % 2) ? pop : ""; for ($method, $uri) { require Carp; Carp::croak("Bad method or uri") if /\s/ || !length; } push(@{${*$self}{'http_request_method'}}, $method); my $ver = ${*$self}{'http_version'}; my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0"; my @h; my @connection; my %given = (host => 0, "content-length" => 0, "te" => 0); while (@_) { my($k, $v) = splice(@_, 0, 2); my $lc_k = lc($k); if ($lc_k eq "connection") { $v =~ s/^\s+//; $v =~ s/\s+$//; push(@connection, split(/\s*,\s*/, $v)); next; } if (exists $given{$lc_k}) { $given{$lc_k}++; } push(@h, "$k: $v"); } if (length($content) && !$given{'content-length'}) { push(@h, "Content-Length: " . length($content)); } my @h2; if ($given{te}) { push(@connection, "TE") unless grep lc($_) eq "te", @connection; } elsif ($self->send_te && gunzip_ok()) { # gzip is less wanted since the IO::Uncompress::Gunzip interface for # it does not really allow chunked decoding to take place easily. push(@h2, "TE: deflate,gzip;q=0.3"); push(@connection, "TE"); } unless (grep lc($_) eq "close", @connection) { if ($self->keep_alive) { if ($peer_ver eq "1.0") { # from looking at Netscape's headers push(@h2, "Keep-Alive: 300"); unshift(@connection, "Keep-Alive"); } } else { push(@connection, "close") if $ver ge "1.1"; } } push(@h2, "Connection: " . join(", ", @connection)) if @connection; unless ($given{host}) { my $h = ${*$self}{'http_host'}; push(@h2, "Host: $h") if $h; } return _bytes(join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content)); } sub write_request { my $self = shift; $self->print($self->format_request(@_)); } sub format_chunk { my $self = shift; return $_[0] unless defined($_[0]) && length($_[0]); return _bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF); } sub write_chunk { my $self = shift; return 1 unless defined($_[0]) && length($_[0]); $self->print(_bytes(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF)); } sub format_chunk_eof { my $self = shift; my @h; while (@_) { push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2)); } return _bytes(join("", "0$CRLF", @h, $CRLF)); } sub write_chunk_eof { my $self = shift; $self->print($self->format_chunk_eof(@_)); } sub my_read { die if @_ > 3; my $self = shift; my $len = $_[1]; for (${*$self}{'http_buf'}) { if (length) { $_[0] = substr($_, 0, $len, ""); return length($_[0]); } else { die "read timeout" unless $self->can_read; return $self->sysread($_[0], $len); } } } sub my_readline { my $self = shift; my $what = shift; for (${*$self}{'http_buf'}) { my $max_line_length = ${*$self}{'http_max_line_length'}; my $pos; while (1) { # find line ending $pos = index($_, "\012"); last if $pos >= 0; die "$what line too long (limit is $max_line_length)" if $max_line_length && length($_) > $max_line_length; # need to read more data to find a line ending my $new_bytes = 0; READ: { # wait until bytes start arriving $self->can_read or die "read timeout"; # consume all incoming bytes my $bytes_read = $self->sysread($_, 1024, length); if(defined $bytes_read) { $new_bytes += $bytes_read; } elsif($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) { redo READ; } else { # if we have already accumulated some data let's at # least return that as a line length or die "$what read failed: $!"; } # no line-ending, no new bytes return length($_) ? substr($_, 0, length($_), "") : undef if $new_bytes==0; } } die "$what line too long ($pos; limit is $max_line_length)" if $max_line_length && $pos > $max_line_length; my $line = substr($_, 0, $pos+1, ""); $line =~ s/(\015?\012)\z// || die "Assert"; return wantarray ? ($line, $1) : $line; } } sub can_read { my $self = shift; return 1 unless defined(fileno($self)); return 1 if $self->isa('IO::Socket::SSL') && $self->pending; return 1 if $self->isa('Net::SSL') && $self->can('pending') && $self->pending; # With no timeout, wait forever. An explicit timeout of 0 can be # used to just check if the socket is readable without waiting. my $timeout = @_ ? shift : (${*$self}{io_socket_timeout} || undef); my $fbits = ''; vec($fbits, fileno($self), 1) = 1; SELECT: { my $before; $before = time if $timeout; my $nfound = select($fbits, undef, undef, $timeout); if ($nfound < 0) { if ($!{EINTR} || $!{EAGAIN} || $!{EWOULDBLOCK}) { # don't really think EAGAIN/EWOULDBLOCK can happen here if ($timeout) { $timeout -= time - $before; $timeout = 0 if $timeout < 0; } redo SELECT; } die "select failed: $!"; } return $nfound > 0; } } sub _rbuf { my $self = shift; if (@_) { for (${*$self}{'http_buf'}) { my $old; $old = $_ if defined wantarray; $_ = shift; return $old; } } else { return ${*$self}{'http_buf'}; } } sub _rbuf_length { my $self = shift; return length ${*$self}{'http_buf'}; } sub _read_header_lines { my $self = shift; my $junk_out = shift; my @headers; my $line_count = 0; my $max_header_lines = ${*$self}{'http_max_header_lines'}; while (my $line = my_readline($self, 'Header')) { if ($line =~ /^(\S+?)\s*:\s*(.*)/s) { push(@headers, $1, $2); } elsif (@headers && $line =~ s/^\s+//) { $headers[-1] .= " " . $line; } elsif ($junk_out) { push(@$junk_out, $line); } else { die "Bad header: '$line'\n"; } if ($max_header_lines) { $line_count++; if ($line_count >= $max_header_lines) { die "Too many header lines (limit is $max_header_lines)"; } } } return @headers; } sub read_response_headers { my($self, %opt) = @_; my $laxed = $opt{laxed}; my($status, $eol) = my_readline($self, 'Status'); unless (defined $status) { die "Server closed connection without sending any data back"; } my($peer_ver, $code, $message) = split(/\s+/, $status, 3); if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) { die "Bad response status line: '$status'" unless $laxed; # assume HTTP/0.9 ${*$self}{'http_peer_http_version'} = "0.9"; ${*$self}{'http_status'} = "200"; substr(${*$self}{'http_buf'}, 0, 0) = $status . ($eol || ""); return 200 unless wantarray; return (200, "Assumed OK"); }; ${*$self}{'http_peer_http_version'} = $peer_ver; ${*$self}{'http_status'} = $code; my $junk_out; if ($laxed) { $junk_out = $opt{junk_out} || []; } my @headers = $self->_read_header_lines($junk_out); # pick out headers that read_entity_body might need my @te; my $content_length; for (my $i = 0; $i < @headers; $i += 2) { my $h = lc($headers[$i]); if ($h eq 'transfer-encoding') { my $te = $headers[$i+1]; $te =~ s/^\s+//; $te =~ s/\s+$//; push(@te, $te) if length($te); } elsif ($h eq 'content-length') { # ignore bogus and overflow values if ($headers[$i+1] =~ /^\s*(\d{1,15})(?:\s|$)/) { $content_length = $1; } } } ${*$self}{'http_te'} = join(",", @te); ${*$self}{'http_content_length'} = $content_length; ${*$self}{'http_first_body'}++; delete ${*$self}{'http_trailers'}; return $code unless wantarray; return ($code, $message, @headers); } sub read_entity_body { my $self = shift; my $buf_ref = \$_[0]; my $size = $_[1]; die "Offset not supported yet" if $_[2]; my $chunked; my $bytes; if (${*$self}{'http_first_body'}) { ${*$self}{'http_first_body'} = 0; delete ${*$self}{'http_chunked'}; delete ${*$self}{'http_bytes'}; my $method = shift(@{${*$self}{'http_request_method'}}); my $status = ${*$self}{'http_status'}; if ($method eq "HEAD") { # this response is always empty regardless of other headers $bytes = 0; } elsif (my $te = ${*$self}{'http_te'}) { my @te = split(/\s*,\s*/, lc($te)); die "Chunked must be last Transfer-Encoding '$te'" unless pop(@te) eq "chunked"; pop(@te) while @te && $te[-1] eq "chunked"; # ignore repeated chunked spec for (@te) { if ($_ eq "deflate" && inflate_ok()) { #require Compress::Raw::Zlib; my ($i, $status) = Compress::Raw::Zlib::Inflate->new(); die "Can't make inflator: $status" unless $i; $_ = sub { my $out; $i->inflate($_[0], \$out); $out } } elsif ($_ eq "gzip" && gunzip_ok()) { #require IO::Uncompress::Gunzip; my @buf; $_ = sub { push(@buf, $_[0]); return "" unless $_[1]; my $input = join("", @buf); my $output; IO::Uncompress::Gunzip::gunzip(\$input, \$output, Transparent => 0) or die "Can't gunzip content: $IO::Uncompress::Gunzip::GunzipError"; return \$output; }; } elsif ($_ eq "identity") { $_ = sub { $_[0] }; } else { die "Can't handle transfer encoding '$te'"; } } @te = reverse(@te); ${*$self}{'http_te2'} = @te ? \@te : ""; $chunked = -1; } elsif (defined(my $content_length = ${*$self}{'http_content_length'})) { $bytes = $content_length; } elsif ($status =~ /^(?:1|[23]04)/) { # RFC 2616 says that these responses should always be empty # but that does not appear to be true in practice [RT#17907] $bytes = 0; } else { # XXX Multi-Part types are self delimiting, but RFC 2616 says we # only has to deal with 'multipart/byteranges' # Read until EOF } } else { $chunked = ${*$self}{'http_chunked'}; $bytes = ${*$self}{'http_bytes'}; } if (defined $chunked) { # The state encoded in $chunked is: # $chunked == 0: read CRLF after chunk, then chunk header # $chunked == -1: read chunk header # $chunked > 0: bytes left in current chunk to read if ($chunked <= 0) { my $line = my_readline($self, 'Entity body'); if ($chunked == 0) { die "Missing newline after chunk data: '$line'" if !defined($line) || $line ne ""; $line = my_readline($self, 'Entity body'); } die "EOF when chunk header expected" unless defined($line); my $chunk_len = $line; $chunk_len =~ s/;.*//; # ignore potential chunk parameters unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) { die "Bad chunk-size in HTTP response: $line"; } $chunked = hex($1); ${*$self}{'http_chunked'} = $chunked; if ($chunked == 0) { ${*$self}{'http_trailers'} = [$self->_read_header_lines]; $$buf_ref = ""; my $n = 0; if (my $transforms = delete ${*$self}{'http_te2'}) { for (@$transforms) { $$buf_ref = &$_($$buf_ref, 1); } $n = length($$buf_ref); } # in case somebody tries to read more, make sure we continue # to return EOF delete ${*$self}{'http_chunked'}; ${*$self}{'http_bytes'} = 0; return $n; } } my $n = $chunked; $n = $size if $size && $size < $n; $n = my_read($self, $$buf_ref, $n); return undef unless defined $n; ${*$self}{'http_chunked'} = $chunked - $n; if ($n > 0) { if (my $transforms = ${*$self}{'http_te2'}) { for (@$transforms) { $$buf_ref = &$_($$buf_ref, 0); } $n = length($$buf_ref); $n = -1 if $n == 0; } } return $n; } elsif (defined $bytes) { unless ($bytes) { $$buf_ref = ""; return 0; } my $n = $bytes; $n = $size if $size && $size < $n; $n = my_read($self, $$buf_ref, $n); ${*$self}{'http_bytes'} = defined $n ? $bytes - $n : $bytes; return $n; } else { # read until eof $size ||= 8*1024; return my_read($self, $$buf_ref, $size); } } sub get_trailers { my $self = shift; @{${*$self}{'http_trailers'} || []}; } BEGIN { my $gunzip_ok; my $inflate_ok; sub gunzip_ok { return $gunzip_ok if defined $gunzip_ok; # Try to load IO::Uncompress::Gunzip. local $@; local $SIG{__DIE__}; $gunzip_ok = 0; eval { require IO::Uncompress::Gunzip; $gunzip_ok++; }; return $gunzip_ok; } sub inflate_ok { return $inflate_ok if defined $inflate_ok; # Try to load Compress::Raw::Zlib. local $@; local $SIG{__DIE__}; $inflate_ok = 0; eval { require Compress::Raw::Zlib; $inflate_ok++; }; return $inflate_ok; } } # BEGIN 1; =pod =encoding UTF-8 =head1 NAME Net::HTTP::Methods - Methods shared by Net::HTTP and Net::HTTPS =head1 VERSION version 6.17 =head1 AUTHOR Gisle Aas =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2001-2017 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ # ABSTRACT: Methods shared by Net::HTTP and Net::HTTPS HTTP/NB.pm000064400000004744152346665430006207 0ustar00package Net::HTTP::NB; $Net::HTTP::NB::VERSION = '6.17'; use strict; use warnings; use base 'Net::HTTP'; sub can_read { return 1; } sub sysread { my $self = $_[0]; if (${*$self}{'httpnb_read_count'}++) { ${*$self}{'http_buf'} = ${*$self}{'httpnb_save'}; die "Multi-read\n"; } my $buf; my $offset = $_[3] || 0; my $n = sysread($self, $_[1], $_[2], $offset); ${*$self}{'httpnb_save'} .= substr($_[1], $offset); return $n; } sub read_response_headers { my $self = shift; ${*$self}{'httpnb_read_count'} = 0; ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; my @h = eval { $self->SUPER::read_response_headers(@_) }; if ($@) { return if $@ eq "Multi-read\n"; die; } return @h; } sub read_entity_body { my $self = shift; ${*$self}{'httpnb_read_count'} = 0; ${*$self}{'httpnb_save'} = ${*$self}{'http_buf'}; # XXX I'm not so sure this does the correct thing in case of # transfer-encoding transforms my $n = eval { $self->SUPER::read_entity_body(@_); }; if ($@) { $_[0] = ""; return -1; } return $n; } 1; =pod =encoding UTF-8 =head1 NAME Net::HTTP::NB - Non-blocking HTTP client =head1 VERSION version 6.17 =head1 SYNOPSIS use Net::HTTP::NB; my $s = Net::HTTP::NB->new(Host => "www.perl.com") || die $@; $s->write_request(GET => "/"); use IO::Select; my $sel = IO::Select->new($s); READ_HEADER: { die "Header timeout" unless $sel->can_read(10); my($code, $mess, %h) = $s->read_response_headers; redo READ_HEADER unless $code; } while (1) { die "Body timeout" unless $sel->can_read(10); my $buf; my $n = $s->read_entity_body($buf, 1024); last unless $n; print $buf; } =head1 DESCRIPTION Same interface as C but it will never try multiple reads when the read_response_headers() or read_entity_body() methods are invoked. This make it possible to multiplex multiple Net::HTTP::NB using select without risk blocking. If read_response_headers() did not see enough data to complete the headers an empty list is returned. If read_entity_body() did not see new entity data in its read the value -1 is returned. =head1 SEE ALSO L =head1 AUTHOR Gisle Aas =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2001-2017 by Gisle Aas. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. =cut __END__ #ABSTRACT: Non-blocking HTTP client Netrc.pm000064400000017360152346665430006202 0ustar00# Net::Netrc.pm # # Copyright (C) 1995-1998 Graham Barr. All rights reserved. # Copyright (C) 2013-2014 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::Netrc; use 5.008001; use strict; use warnings; use Carp; use FileHandle; our $VERSION = "3.11"; our $TESTING; my %netrc = (); sub _readrc { my($class, $host) = @_; my ($home, $file); if ($^O eq "MacOS") { $home = $ENV{HOME} || `pwd`; chomp($home); $file = ($home =~ /:$/ ? $home . "netrc" : $home . ":netrc"); } else { # Some OS's don't have "getpwuid", so we default to $ENV{HOME} $home = eval { (getpwuid($>))[7] } || $ENV{HOME}; $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; if (-e $home . "/.netrc") { $file = $home . "/.netrc"; } elsif (-e $home . "/_netrc") { $file = $home . "/_netrc"; } else { return unless $TESTING; } } my ($login, $pass, $acct) = (undef, undef, undef); my $fh; local $_; $netrc{default} = undef; # OS/2 and Win32 do not handle stat in a way compatible with this check :-( unless ($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'MacOS' || $^O =~ /^cygwin/) { my @stat = stat($file); if (@stat) { if ($stat[2] & 077) { ## no critic (ValuesAndExpressions::ProhibitLeadingZeros) carp "Bad permissions: $file"; return; } if ($stat[4] != $<) { carp "Not owner: $file"; return; } } } if ($fh = FileHandle->new($file, "r")) { my ($mach, $macdef, $tok, @tok) = (0, 0); while (<$fh>) { undef $macdef if /\A\n\Z/; if ($macdef) { push(@$macdef, $_); next; } s/^\s*//; chomp; while (length && s/^("((?:[^"]+|\\.)*)"|((?:[^\\\s]+|\\.)*))\s*//) { (my $tok = $+) =~ s/\\(.)/$1/g; push(@tok, $tok); } TOKEN: while (@tok) { if ($tok[0] eq "default") { shift(@tok); $mach = bless {}, $class; $netrc{default} = [$mach]; next TOKEN; } last TOKEN unless @tok > 1; $tok = shift(@tok); if ($tok eq "machine") { my $host = shift @tok; $mach = bless {machine => $host}, $class; $netrc{$host} = [] unless exists($netrc{$host}); push(@{$netrc{$host}}, $mach); } elsif ($tok =~ /^(login|password|account)$/) { next TOKEN unless $mach; my $value = shift @tok; # Following line added by rmerrell to remove '/' escape char in .netrc $value =~ s/\/\\/\\/g; $mach->{$1} = $value; } elsif ($tok eq "macdef") { next TOKEN unless $mach; my $value = shift @tok; $mach->{macdef} = {} unless exists $mach->{macdef}; $macdef = $mach->{machdef}{$value} = []; } } } $fh->close(); } } sub lookup { my ($class, $mach, $login) = @_; $class->_readrc() unless exists $netrc{default}; $mach ||= 'default'; undef $login if $mach eq 'default'; if (exists $netrc{$mach}) { if (defined $login) { foreach my $m (@{$netrc{$mach}}) { return $m if (exists $m->{login} && $m->{login} eq $login); } return; } return $netrc{$mach}->[0]; } return $netrc{default}->[0] if defined $netrc{default}; return; } sub login { my $me = shift; exists $me->{login} ? $me->{login} : undef; } sub account { my $me = shift; exists $me->{account} ? $me->{account} : undef; } sub password { my $me = shift; exists $me->{password} ? $me->{password} : undef; } sub lpa { my $me = shift; ($me->login, $me->password, $me->account); } 1; __END__ =head1 NAME Net::Netrc - OO interface to users netrc file =head1 SYNOPSIS use Net::Netrc; $mach = Net::Netrc->lookup('some.machine'); $login = $mach->login; ($login, $password, $account) = $mach->lpa; =head1 DESCRIPTION C is a class implementing a simple interface to the .netrc file used as by the ftp program. C also implements security checks just like the ftp program, these checks are, first that the .netrc file must be owned by the user and second the ownership permissions should be such that only the owner has read and write access. If these conditions are not met then a warning is output and the .netrc file is not read. =head1 THE .netrc FILE The .netrc file contains login and initialization information used by the auto-login process. It resides in the user's home directory. The following tokens are recognized; they may be separated by spaces, tabs, or new-lines: =over 4 =item machine name Identify a remote machine name. The auto-login process searches the .netrc file for a machine token that matches the remote machine specified. Once a match is made, the subsequent .netrc tokens are processed, stopping when the end of file is reached or an- other machine or a default token is encountered. =item default This is the same as machine name except that default matches any name. There can be only one default token, and it must be after all machine tokens. This is normally used as: default login anonymous password user@site thereby giving the user automatic anonymous login to machines not specified in .netrc. =item login name Identify a user on the remote machine. If this token is present, the auto-login process will initiate a login using the specified name. =item password string Supply a password. If this token is present, the auto-login process will supply the specified string if the remote server requires a password as part of the login process. =item account string Supply an additional account password. If this token is present, the auto-login process will supply the specified string if the remote server requires an additional account password. =item macdef name Define a macro. C only parses this field to be compatible with I. =back =head1 CONSTRUCTOR The constructor for a C object is not called new as it does not really create a new object. But instead is called C as this is essentially what it does. =over 4 =item lookup ( MACHINE [, LOGIN ]) Lookup and return a reference to the entry for C. If C is given then the entry returned will have the given login. If C is not given then the first entry in the .netrc file for C will be returned. If a matching entry cannot be found, and a default entry exists, then a reference to the default entry is returned. If there is no matching entry found and there is no default defined, or no .netrc file is found, then C is returned. =back =head1 METHODS =over 4 =item login () Return the login id for the netrc entry =item password () Return the password for the netrc entry =item account () Return the account information for the netrc entry =item lpa () Return a list of login, password and account information for the netrc entry =back =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 SEE ALSO L, L =head1 COPYRIGHT Copyright (C) 1995-1998 Graham Barr. All rights reserved. Copyright (C) 2013-2014 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut Config.pm000064400000020450152346665430006326 0ustar00# Net::Config.pm # # Copyright (C) 2000 Graham Barr. All rights reserved. # Copyright (C) 2013-2014, 2016 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::Config; use 5.008001; use strict; use warnings; use Exporter; use Socket qw(inet_aton inet_ntoa); our @EXPORT = qw(%NetConfig); our @ISA = qw(Net::LocalCfg Exporter); our $VERSION = "3.11"; our($CONFIGURE, $LIBNET_CFG); eval { local @INC = @INC; pop @INC if $INC[-1] eq '.'; local $SIG{__DIE__}; require Net::LocalCfg; }; our %NetConfig = ( nntp_hosts => [], snpp_hosts => [], pop3_hosts => [], smtp_hosts => [], ph_hosts => [], daytime_hosts => [], time_hosts => [], inet_domain => undef, ftp_firewall => undef, ftp_ext_passive => 1, ftp_int_passive => 1, test_hosts => 1, test_exist => 1, ); # # Try to get as much configuration info as possible from InternetConfig # { ## no critic (BuiltinFunctions::ProhibitStringyEval) $^O eq 'MacOS' and eval < [ \$InternetConfig{ kICNNTPHost() } ], pop3_hosts => [ \$InternetConfig{ kICMailAccount() } =~ /\@(.*)/ ], smtp_hosts => [ \$InternetConfig{ kICSMTPHost() } ], ftp_testhost => \$InternetConfig{ kICFTPHost() } ? \$InternetConfig{ kICFTPHost()} : undef, ph_hosts => [ \$InternetConfig{ kICPhHost() } ], ftp_ext_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0, ftp_int_passive => \$InternetConfig{"646F676F\xA5UsePassiveMode"} || 0, socks_hosts => \$InternetConfig{ kICUseSocks() } ? [ \$InternetConfig{ kICSocksHost() } ] : [], ftp_firewall => \$InternetConfig{ kICUseFTPProxy() } ? [ \$InternetConfig{ kICFTPProxyHost() } ] : [], ); \@NetConfig{keys %nc} = values %nc; } TRY_INTERNET_CONFIG } my $file = __FILE__; my $ref; $file =~ s/Config.pm/libnet.cfg/; if (-f $file) { $ref = eval { local $SIG{__DIE__}; do $file }; if (ref($ref) eq 'HASH') { %NetConfig = (%NetConfig, %{$ref}); $LIBNET_CFG = $file; } } if ($< == $> and !$CONFIGURE) { my $home = eval { local $SIG{__DIE__}; (getpwuid($>))[7] } || $ENV{HOME}; $home ||= $ENV{HOMEDRIVE} . ($ENV{HOMEPATH} || '') if defined $ENV{HOMEDRIVE}; if (defined $home) { $file = $home . "/.libnetrc"; $ref = eval { local $SIG{__DIE__}; do $file } if -f $file; %NetConfig = (%NetConfig, %{$ref}) if ref($ref) eq 'HASH'; } } my ($k, $v); while (($k, $v) = each %NetConfig) { $NetConfig{$k} = [$v] if ($k =~ /_hosts$/ and $k ne "test_hosts" and defined($v) and !ref($v)); } # Take a hostname and determine if it is inside the firewall sub requires_firewall { shift; # ignore package my $host = shift; return 0 unless defined $NetConfig{'ftp_firewall'}; $host = inet_aton($host) or return -1; $host = inet_ntoa($host); if (exists $NetConfig{'local_netmask'}) { my $quad = unpack("N", pack("C*", split(/\./, $host))); my $list = $NetConfig{'local_netmask'}; $list = [$list] unless ref($list); foreach (@$list) { my ($net, $bits) = (m#^(\d+\.\d+\.\d+\.\d+)/(\d+)$#) or next; my $mask = ~0 << (32 - $bits); my $addr = unpack("N", pack("C*", split(/\./, $net))); return 0 if (($addr & $mask) == ($quad & $mask)); } return 1; } return 0; } *is_external = \&requires_firewall; 1; __END__ =head1 NAME Net::Config - Local configuration data for libnet =head1 SYNOPSIS use Net::Config qw(%NetConfig); =head1 DESCRIPTION C holds configuration data for the modules in the libnet distribution. During installation you will be asked for these values. The configuration data is held globally in a file in the perl installation tree, but a user may override any of these values by providing their own. This can be done by having a C<.libnetrc> file in their home directory. This file should return a reference to a HASH containing the keys described below. For example # .libnetrc { nntp_hosts => [ "my_preferred_host" ], ph_hosts => [ "my_ph_server" ], } __END__ =head1 METHODS C defines the following methods. They are methods as they are invoked as class methods. This is because C inherits from C so you can override these methods if you want. =over 4 =item requires_firewall ( HOST ) Attempts to determine if a given host is outside your firewall. Possible return values are. -1 Cannot lookup hostname 0 Host is inside firewall (or there is no ftp_firewall entry) 1 Host is outside the firewall This is done by using hostname lookup and the C entry in the configuration data. =back =head1 NetConfig VALUES =over 4 =item nntp_hosts =item snpp_hosts =item pop3_hosts =item smtp_hosts =item ph_hosts =item daytime_hosts =item time_hosts Each is a reference to an array of hostnames (in order of preference), which should be used for the given protocol =item inet_domain Your internet domain name =item ftp_firewall If you have an FTP proxy firewall (B an HTTP or SOCKS firewall) then this value should be set to the firewall hostname. If your firewall does not listen to port 21, then this value should be set to C<"hostname:port"> (eg C<"hostname:99">) =item ftp_firewall_type There are many different ftp firewall products available. But unfortunately there is no standard for how to traverse a firewall. The list below shows the sequence of commands that Net::FTP will use user Username for remote host pass Password for remote host fwuser Username for firewall fwpass Password for firewall remote.host The hostname of the remote ftp server =over 4 =item 0Z<> There is no firewall =item 1Z<> USER user@remote.host PASS pass =item 2Z<> USER fwuser PASS fwpass USER user@remote.host PASS pass =item 3Z<> USER fwuser PASS fwpass SITE remote.site USER user PASS pass =item 4Z<> USER fwuser PASS fwpass OPEN remote.site USER user PASS pass =item 5Z<> USER user@fwuser@remote.site PASS pass@fwpass =item 6Z<> USER fwuser@remote.site PASS fwpass USER user PASS pass =item 7Z<> USER user@remote.host PASS pass AUTH fwuser RESP fwpass =back =item ftp_ext_passive =item ftp_int_passive FTP servers can work in passive or active mode. Active mode is when you want to transfer data you have to tell the server the address and port to connect to. Passive mode is when the server provide the address and port and you establish the connection. With some firewalls active mode does not work as the server cannot connect to your machine (because you are behind a firewall) and the firewall does not re-write the command. In this case you should set C to a I value. Some servers are configured to only work in passive mode. If you have one of these you can force C to always transfer in passive mode; when not going via a firewall, by setting C to a I value. =item local_netmask A reference to a list of netmask strings in the form C<"134.99.4.0/24">. These are used by the C function to determine if a given host is inside or outside your firewall. =back The following entries are used during installation & testing on the libnet package =over 4 =item test_hosts If true then C may attempt to connect to hosts given in the configuration. =item test_exists If true then C will check each hostname given that it exists =back =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1998-2011 Graham Barr. All rights reserved. Copyright (C) 2013-2014, 2016 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut FTP.pm000064400000147643152346665430005570 0ustar00# Net::FTP.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. # Copyright (C) 2013-2017 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. # # Documentation (at end) improved 1996 by Nathan Torkington . package Net::FTP; use 5.008001; use strict; use warnings; use Carp; use Fcntl qw(O_WRONLY O_RDONLY O_APPEND O_CREAT O_TRUNC); use IO::Socket; use Net::Cmd; use Net::Config; use Socket; use Time::Local; our $VERSION = '3.11'; our $IOCLASS; my $family_key; BEGIN { # Code for detecting if we can use SSL my $ssl_class = eval { require IO::Socket::SSL; # first version with default CA on most platforms no warnings 'numeric'; IO::Socket::SSL->VERSION(2.007); } && 'IO::Socket::SSL'; my $nossl_warn = !$ssl_class && 'To use SSL please install IO::Socket::SSL with version>=2.007'; # Code for detecting if we can use IPv6 my $inet6_class = eval { require IO::Socket::IP; no warnings 'numeric'; IO::Socket::IP->VERSION(0.25); } && 'IO::Socket::IP' || eval { require IO::Socket::INET6; no warnings 'numeric'; IO::Socket::INET6->VERSION(2.62); } && 'IO::Socket::INET6'; sub can_ssl { $ssl_class }; sub can_inet6 { $inet6_class }; $IOCLASS = $ssl_class || $inet6_class || 'IO::Socket::INET'; $family_key = ( $ssl_class ? $ssl_class->can_ipv6 : $inet6_class || '' ) eq 'IO::Socket::IP' ? 'Family' : 'Domain'; } our @ISA = ('Exporter','Net::Cmd',$IOCLASS); use constant TELNET_IAC => 255; use constant TELNET_IP => 244; use constant TELNET_DM => 242; use constant EBCDIC => $^O eq 'os390'; sub new { my $pkg = shift; my ($peer, %arg); if (@_ % 2) { $peer = shift; %arg = @_; } else { %arg = @_; $peer = delete $arg{Host}; } my $host = $peer; my $fire = undef; my $fire_type = undef; if (exists($arg{Firewall}) || Net::Config->requires_firewall($peer)) { $fire = $arg{Firewall} || $ENV{FTP_FIREWALL} || $NetConfig{ftp_firewall} || undef; if (defined $fire) { $peer = $fire; delete $arg{Port}; $fire_type = $arg{FirewallType} || $ENV{FTP_FIREWALL_TYPE} || $NetConfig{firewall_type} || undef; } } my %tlsargs; if (can_ssl()) { # for name verification strip port from domain:port, ipv4:port, [ipv6]:port (my $hostname = $host) =~s{(? 'ftp', SSL_verifycn_name => $hostname, # use SNI if supported by IO::Socket::SSL $pkg->can_client_sni ? (SSL_hostname => $hostname):(), # reuse SSL session of control connection in data connections SSL_session_cache => Net::FTP::_SSL_SingleSessionCache->new, ); # user defined SSL arg $tlsargs{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg); } elsif ($arg{SSL}) { croak("IO::Socket::SSL >= 2.007 needed for SSL support"); } my $ftp = $pkg->SUPER::new( PeerAddr => $peer, PeerPort => $arg{Port} || ($arg{SSL} ? 'ftps(990)' : 'ftp(21)'), LocalAddr => $arg{'LocalAddr'}, $family_key => $arg{Domain} || $arg{Family}, Proto => 'tcp', Timeout => defined $arg{Timeout} ? $arg{Timeout} : 120, %tlsargs, $arg{SSL} ? ():( SSL_startHandshake => 0 ), ) or return; ${*$ftp}{'net_ftp_host'} = $host; # Remote hostname ${*$ftp}{'net_ftp_type'} = 'A'; # ASCII/binary/etc mode ${*$ftp}{'net_ftp_blksize'} = abs($arg{'BlockSize'} || 10240); ${*$ftp}{'net_ftp_localaddr'} = $arg{'LocalAddr'}; ${*$ftp}{'net_ftp_domain'} = $arg{Domain} || $arg{Family}; ${*$ftp}{'net_ftp_firewall'} = $fire if (defined $fire); ${*$ftp}{'net_ftp_firewall_type'} = $fire_type if (defined $fire_type); ${*$ftp}{'net_ftp_passive'} = int exists $arg{Passive} ? $arg{Passive} : exists $ENV{FTP_PASSIVE} ? $ENV{FTP_PASSIVE} : defined $fire ? $NetConfig{ftp_ext_passive} : $NetConfig{ftp_int_passive}; # Whew! :-) ${*$ftp}{net_ftp_tlsargs} = \%tlsargs if %tlsargs; if ($arg{SSL}) { ${*$ftp}{net_ftp_tlsprot} = 'P'; ${*$ftp}{net_ftp_tlsdirect} = 1; } $ftp->hash(exists $arg{Hash} ? $arg{Hash} : 0, 1024); $ftp->autoflush(1); $ftp->debug(exists $arg{Debug} ? $arg{Debug} : undef); unless ($ftp->response() == CMD_OK) { $ftp->close(); # keep @$ if no message. Happens, when response did not start with a code. $@ = $ftp->message || $@; undef $ftp; } $ftp; } ## ## User interface methods ## sub host { my $me = shift; ${*$me}{'net_ftp_host'}; } sub passive { my $ftp = shift; return ${*$ftp}{'net_ftp_passive'} unless @_; ${*$ftp}{'net_ftp_passive'} = shift; } sub hash { my $ftp = shift; # self my ($h, $b) = @_; unless ($h) { delete ${*$ftp}{'net_ftp_hash'}; return [\*STDERR, 0]; } ($h, $b) = (ref($h) ? $h : \*STDERR, $b || 1024); select((select($h), $| = 1)[0]); $b = 512 if $b < 512; ${*$ftp}{'net_ftp_hash'} = [$h, $b]; } sub quit { my $ftp = shift; $ftp->_QUIT; $ftp->close; } sub DESTROY { } sub ascii { shift->type('A', @_); } sub binary { shift->type('I', @_); } sub ebcdic { carp "TYPE E is unsupported, shall default to I"; shift->type('E', @_); } sub byte { carp "TYPE L is unsupported, shall default to I"; shift->type('L', @_); } # Allow the user to send a command directly, BE CAREFUL !! sub quot { my $ftp = shift; my $cmd = shift; $ftp->command(uc $cmd, @_); $ftp->response(); } sub site { my $ftp = shift; $ftp->command("SITE", @_); $ftp->response(); } sub mdtm { my $ftp = shift; my $file = shift; # Server Y2K bug workaround # # sigh; some idiotic FTP servers use ("19%d",tm.tm_year) instead of # ("%d",tm.tm_year+1900). This results in an extra digit in the # string returned. To account for this we allow an optional extra # digit in the year. Then if the first two digits are 19 we use the # remainder, otherwise we subtract 1900 from the whole year. $ftp->_MDTM($file) && $ftp->message =~ /((\d\d)(\d\d\d?))(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ ? timegm($8, $7, $6, $5, $4 - 1, $2 eq '19' ? $3 : ($1 - 1900)) : undef; } sub size { my $ftp = shift; my $file = shift; my $io; if ($ftp->supported("SIZE")) { return $ftp->_SIZE($file) ? ($ftp->message =~ /(\d+)\s*(bytes?\s*)?$/)[0] : undef; } elsif ($ftp->supported("STAT")) { my @msg; return unless $ftp->_STAT($file) && (@msg = $ftp->message) == 3; foreach my $line (@msg) { return (split(/\s+/, $line))[4] if $line =~ /^[-rwxSsTt]{10}/; } } else { my @files = $ftp->dir($file); if (@files) { return (split(/\s+/, $1))[4] if $files[0] =~ /^([-rwxSsTt]{10}.*)$/; } } undef; } sub starttls { my $ftp = shift; can_ssl() or croak("IO::Socket::SSL >= 2.007 needed for SSL support"); $ftp->is_SSL and croak("called starttls within SSL session"); $ftp->_AUTH('TLS') == CMD_OK or return; $ftp->connect_SSL or return; $ftp->prot('P'); return 1; } sub prot { my ($ftp,$prot) = @_; $prot eq 'C' or $prot eq 'P' or croak("prot must by C or P"); $ftp->_PBSZ(0) or return; $ftp->_PROT($prot) or return; ${*$ftp}{net_ftp_tlsprot} = $prot; return 1; } sub stoptls { my $ftp = shift; $ftp->is_SSL or croak("called stoptls outside SSL session"); ${*$ftp}{net_ftp_tlsdirect} and croak("cannot stoptls direct SSL session"); $ftp->_CCC() or return; $ftp->stop_SSL(); return 1; } sub login { my ($ftp, $user, $pass, $acct) = @_; my ($ok, $ruser, $fwtype); unless (defined $user) { require Net::Netrc; my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}); ($user, $pass, $acct) = $rc->lpa() if ($rc); } $user ||= "anonymous"; $ruser = $user; $fwtype = ${*$ftp}{'net_ftp_firewall_type'} || $NetConfig{'ftp_firewall_type'} || 0; if ($fwtype && defined ${*$ftp}{'net_ftp_firewall'}) { if ($fwtype == 1 || $fwtype == 7) { $user .= '@' . ${*$ftp}{'net_ftp_host'}; } else { require Net::Netrc; my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); my ($fwuser, $fwpass, $fwacct) = $rc ? $rc->lpa() : (); if ($fwtype == 5) { $user = join('@', $user, $fwuser, ${*$ftp}{'net_ftp_host'}); $pass = $pass . '@' . $fwpass; } else { if ($fwtype == 2) { $user .= '@' . ${*$ftp}{'net_ftp_host'}; } elsif ($fwtype == 6) { $fwuser .= '@' . ${*$ftp}{'net_ftp_host'}; } $ok = $ftp->_USER($fwuser); return 0 unless $ok == CMD_OK || $ok == CMD_MORE; $ok = $ftp->_PASS($fwpass || ""); return 0 unless $ok == CMD_OK || $ok == CMD_MORE; $ok = $ftp->_ACCT($fwacct) if defined($fwacct); if ($fwtype == 3) { $ok = $ftp->command("SITE", ${*$ftp}{'net_ftp_host'})->response; } elsif ($fwtype == 4) { $ok = $ftp->command("OPEN", ${*$ftp}{'net_ftp_host'})->response; } return 0 unless $ok == CMD_OK || $ok == CMD_MORE; } } } $ok = $ftp->_USER($user); # Some dumb firewalls don't prefix the connection messages $ok = $ftp->response() if ($ok == CMD_OK && $ftp->code == 220 && $user =~ /\@/); if ($ok == CMD_MORE) { unless (defined $pass) { require Net::Netrc; my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_host'}, $ruser); ($ruser, $pass, $acct) = $rc->lpa() if ($rc); $pass = '-anonymous@' if (!defined $pass && (!defined($ruser) || $ruser =~ /^anonymous/o)); } $ok = $ftp->_PASS($pass || ""); } $ok = $ftp->_ACCT($acct) if (defined($acct) && ($ok == CMD_MORE || $ok == CMD_OK)); if ($fwtype == 7 && $ok == CMD_OK && defined ${*$ftp}{'net_ftp_firewall'}) { my ($f, $auth, $resp) = _auth_id($ftp); $ftp->authorize($auth, $resp) if defined($resp); } $ok == CMD_OK; } sub account { @_ == 2 or croak 'usage: $ftp->account( ACCT )'; my $ftp = shift; my $acct = shift; $ftp->_ACCT($acct) == CMD_OK; } sub _auth_id { my ($ftp, $auth, $resp) = @_; unless (defined $resp) { require Net::Netrc; $auth ||= eval { (getpwuid($>))[0] } || $ENV{NAME}; my $rc = Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}, $auth) || Net::Netrc->lookup(${*$ftp}{'net_ftp_firewall'}); ($auth, $resp) = $rc->lpa() if ($rc); } ($ftp, $auth, $resp); } sub authorize { @_ >= 1 || @_ <= 3 or croak 'usage: $ftp->authorize( [AUTH [, RESP]])'; my ($ftp, $auth, $resp) = &_auth_id; my $ok = $ftp->_AUTH($auth || ""); return $ftp->_RESP($resp || "") if ($ok == CMD_MORE); $ok == CMD_OK; } sub rename { @_ == 3 or croak 'usage: $ftp->rename(FROM, TO)'; my ($ftp, $from, $to) = @_; $ftp->_RNFR($from) && $ftp->_RNTO($to); } sub type { my $ftp = shift; my $type = shift; my $oldval = ${*$ftp}{'net_ftp_type'}; return $oldval unless (defined $type); return unless ($ftp->_TYPE($type, @_)); ${*$ftp}{'net_ftp_type'} = join(" ", $type, @_); $oldval; } sub alloc { my $ftp = shift; my $size = shift; my $oldval = ${*$ftp}{'net_ftp_allo'}; return $oldval unless (defined $size); return unless ($ftp->supported("ALLO") and $ftp->_ALLO($size, @_)); ${*$ftp}{'net_ftp_allo'} = join(" ", $size, @_); $oldval; } sub abort { my $ftp = shift; send($ftp, pack("CCC", TELNET_IAC, TELNET_IP, TELNET_IAC), MSG_OOB); $ftp->command(pack("C", TELNET_DM) . "ABOR"); ${*$ftp}{'net_ftp_dataconn'}->close() if defined ${*$ftp}{'net_ftp_dataconn'}; $ftp->response(); $ftp->status == CMD_OK; } sub get { my ($ftp, $remote, $local, $where) = @_; my ($loc, $len, $buf, $resp, $data); local *FD; my $localfd = ref($local) || ref(\$local) eq "GLOB"; ($local = $remote) =~ s#^.*/## unless (defined $local); croak("Bad remote filename '$remote'\n") if $remote =~ /[\r\n]/s; ${*$ftp}{'net_ftp_rest'} = $where if defined $where; my $rest = ${*$ftp}{'net_ftp_rest'}; delete ${*$ftp}{'net_ftp_port'}; delete ${*$ftp}{'net_ftp_pasv'}; $data = $ftp->retr($remote) or return; if ($localfd) { $loc = $local; } else { $loc = \*FD; unless (sysopen($loc, $local, O_CREAT | O_WRONLY | ($rest ? O_APPEND: O_TRUNC))) { carp "Cannot open Local file $local: $!\n"; $data->abort; return; } } if ($ftp->type eq 'I' && !binmode($loc)) { carp "Cannot binmode Local file $local: $!\n"; $data->abort; close($loc) unless $localfd; return; } $buf = ''; my ($count, $hashh, $hashb, $ref) = (0); ($hashh, $hashb) = @$ref if ($ref = ${*$ftp}{'net_ftp_hash'}); my $blksize = ${*$ftp}{'net_ftp_blksize'}; local $\; # Just in case while (1) { last unless $len = $data->read($buf, $blksize); if (EBCDIC && $ftp->type ne 'I') { $buf = $ftp->toebcdic($buf); $len = length($buf); } if ($hashh) { $count += $len; print $hashh "#" x (int($count / $hashb)); $count %= $hashb; } unless (print $loc $buf) { carp "Cannot write to Local file $local: $!\n"; $data->abort; close($loc) unless $localfd; return; } } print $hashh "\n" if $hashh; unless ($localfd) { unless (close($loc)) { carp "Cannot close file $local (perhaps disk space) $!\n"; return; } } unless ($data->close()) # implied $ftp->response { carp "Unable to close datastream"; return; } return $local; } sub cwd { @_ == 1 || @_ == 2 or croak 'usage: $ftp->cwd( [ DIR ] )'; my ($ftp, $dir) = @_; $dir = "/" unless defined($dir) && $dir =~ /\S/; $dir eq ".." ? $ftp->_CDUP() : $ftp->_CWD($dir); } sub cdup { @_ == 1 or croak 'usage: $ftp->cdup()'; $_[0]->_CDUP; } sub pwd { @_ == 1 || croak 'usage: $ftp->pwd()'; my $ftp = shift; $ftp->_PWD(); $ftp->_extract_path; } # rmdir( $ftp, $dir, [ $recurse ] ) # # Removes $dir on remote host via FTP. # $ftp is handle for remote host # # If $recurse is TRUE, the directory and deleted recursively. # This means all of its contents and subdirectories. # # Initial version contributed by Dinkum Software # sub rmdir { @_ == 2 || @_ == 3 or croak('usage: $ftp->rmdir( DIR [, RECURSE ] )'); # Pick off the args my ($ftp, $dir, $recurse) = @_; my $ok; return $ok if $ok = $ftp->_RMD($dir) or !$recurse; # Try to delete the contents # Get a list of all the files in the directory, excluding the current and parent directories my @filelist = map { /^(?:\S+;)+ (.+)$/ ? ($1) : () } grep { !/^(?:\S+;)*type=[cp]dir;/i } $ftp->_list_cmd("MLSD", $dir); # Fallback to using the less well-defined NLST command if MLSD fails @filelist = grep { !/^\.{1,2}$/ } $ftp->ls($dir) unless @filelist; return unless @filelist; # failed, it is probably not a directory return $ftp->delete($dir) if @filelist == 1 and $dir eq $filelist[0]; # Go thru and delete each file or the directory foreach my $file (map { m,/, ? $_ : "$dir/$_" } @filelist) { next # successfully deleted the file if $ftp->delete($file); # Failed to delete it, assume its a directory # Recurse and ignore errors, the final rmdir() will # fail on any errors here return $ok unless $ok = $ftp->rmdir($file, 1); } # Directory should be empty # Try to remove the directory again # Pass results directly to caller # If any of the prior deletes failed, this # rmdir() will fail because directory is not empty return $ftp->_RMD($dir); } sub restart { @_ == 2 || croak 'usage: $ftp->restart( BYTE_OFFSET )'; my ($ftp, $where) = @_; ${*$ftp}{'net_ftp_rest'} = $where; return; } sub mkdir { @_ == 2 || @_ == 3 or croak 'usage: $ftp->mkdir( DIR [, RECURSE ] )'; my ($ftp, $dir, $recurse) = @_; $ftp->_MKD($dir) || $recurse or return; my $path = $dir; unless ($ftp->ok) { my @path = split(m#(?=/+)#, $dir); $path = ""; while (@path) { $path .= shift @path; $ftp->_MKD($path); $path = $ftp->_extract_path($path); } # If the creation of the last element was not successful, see if we # can cd to it, if so then return path unless ($ftp->ok) { my ($status, $message) = ($ftp->status, $ftp->message); my $pwd = $ftp->pwd; if ($pwd && $ftp->cwd($dir)) { $path = $dir; $ftp->cwd($pwd); } else { undef $path; } $ftp->set_status($status, $message); } } $path; } sub delete { @_ == 2 || croak 'usage: $ftp->delete( FILENAME )'; $_[0]->_DELE($_[1]); } sub put { shift->_store_cmd("stor", @_) } sub put_unique { shift->_store_cmd("stou", @_) } sub append { shift->_store_cmd("appe", @_) } sub nlst { shift->_data_cmd("NLST", @_) } sub list { shift->_data_cmd("LIST", @_) } sub retr { shift->_data_cmd("RETR", @_) } sub stor { shift->_data_cmd("STOR", @_) } sub stou { shift->_data_cmd("STOU", @_) } sub appe { shift->_data_cmd("APPE", @_) } sub _store_cmd { my ($ftp, $cmd, $local, $remote) = @_; my ($loc, $sock, $len, $buf); local *FD; my $localfd = ref($local) || ref(\$local) eq "GLOB"; if (!defined($remote) and 'STOU' ne uc($cmd)) { croak 'Must specify remote filename with stream input' if $localfd; require File::Basename; $remote = File::Basename::basename($local); } if (defined ${*$ftp}{'net_ftp_allo'}) { delete ${*$ftp}{'net_ftp_allo'}; } else { # if the user hasn't already invoked the alloc method since the last # _store_cmd call, figure out if the local file is a regular file(not # a pipe, or device) and if so get the file size from stat, and send # an ALLO command before sending the STOR, STOU, or APPE command. my $size = do { local $^W; -f $local && -s _ }; # no ALLO if sending data from a pipe ${*$ftp}{'net_ftp_allo'} = $size if $size; } croak("Bad remote filename '$remote'\n") if defined($remote) and $remote =~ /[\r\n]/s; if ($localfd) { $loc = $local; } else { $loc = \*FD; unless (sysopen($loc, $local, O_RDONLY)) { carp "Cannot open Local file $local: $!\n"; return; } } if ($ftp->type eq 'I' && !binmode($loc)) { carp "Cannot binmode Local file $local: $!\n"; return; } delete ${*$ftp}{'net_ftp_port'}; delete ${*$ftp}{'net_ftp_pasv'}; $sock = $ftp->_data_cmd($cmd, grep { defined } $remote) or return; $remote = ($ftp->message =~ /\w+\s*:\s*(.*)/)[0] if 'STOU' eq uc $cmd; my $blksize = ${*$ftp}{'net_ftp_blksize'}; my ($count, $hashh, $hashb, $ref) = (0); ($hashh, $hashb) = @$ref if ($ref = ${*$ftp}{'net_ftp_hash'}); while (1) { last unless $len = read($loc, $buf = "", $blksize); if (EBCDIC && $ftp->type ne 'I') { $buf = $ftp->toascii($buf); $len = length($buf); } if ($hashh) { $count += $len; print $hashh "#" x (int($count / $hashb)); $count %= $hashb; } my $wlen; unless (defined($wlen = $sock->write($buf, $len)) && $wlen == $len) { $sock->abort; close($loc) unless $localfd; print $hashh "\n" if $hashh; return; } } print $hashh "\n" if $hashh; close($loc) unless $localfd; $sock->close() or return; if ('STOU' eq uc $cmd and $ftp->message =~ m/unique\s+file\s*name\s*:\s*(.*)\)|"(.*)"/) { require File::Basename; $remote = File::Basename::basename($+); } return $remote; } sub port { @_ == 1 || @_ == 2 or croak 'usage: $self->port([PORT])'; return _eprt('PORT',@_); } sub eprt { @_ == 1 || @_ == 2 or croak 'usage: $self->eprt([PORT])'; return _eprt('EPRT',@_); } sub _eprt { my ($cmd,$ftp,$port) = @_; delete ${*$ftp}{net_ftp_intern_port}; unless ($port) { my $listen = ${*$ftp}{net_ftp_listen} ||= $IOCLASS->new( Listen => 1, Timeout => $ftp->timeout, LocalAddr => $ftp->sockhost, $family_key => $ftp->sockdomain, can_ssl() ? ( %{ ${*$ftp}{net_ftp_tlsargs} }, SSL_startHandshake => 0, ):(), ); ${*$ftp}{net_ftp_intern_port} = 1; my $fam = ($listen->sockdomain == AF_INET) ? 1:2; if ( $cmd eq 'EPRT' || $fam == 2 ) { $port = "|$fam|".$listen->sockhost."|".$listen->sockport."|"; $cmd = 'EPRT'; } else { my $p = $listen->sockport; $port = join(',',split(m{\.},$listen->sockhost),$p >> 8,$p & 0xff); } } elsif (ref($port) eq 'ARRAY') { $port = join(',',split(m{\.},@$port[0]),@$port[1] >> 8,@$port[1] & 0xff); } my $ok = $cmd eq 'EPRT' ? $ftp->_EPRT($port) : $ftp->_PORT($port); ${*$ftp}{net_ftp_port} = $port if $ok; return $ok; } sub ls { shift->_list_cmd("NLST", @_); } sub dir { shift->_list_cmd("LIST", @_); } sub pasv { my $ftp = shift; @_ and croak 'usage: $ftp->port()'; return $ftp->epsv if $ftp->sockdomain != AF_INET; delete ${*$ftp}{net_ftp_intern_port}; if ( $ftp->_PASV && $ftp->message =~ m{(\d+,\d+,\d+,\d+),(\d+),(\d+)} ) { my $port = 256 * $2 + $3; ( my $ip = $1 ) =~s{,}{.}g; return ${*$ftp}{net_ftp_pasv} = [ $ip,$port ]; } return; } sub epsv { my $ftp = shift; @_ and croak 'usage: $ftp->epsv()'; delete ${*$ftp}{net_ftp_intern_port}; $ftp->_EPSV && $ftp->message =~ m{\(([\x33-\x7e])\1\1(\d+)\1\)} ? ${*$ftp}{net_ftp_pasv} = [ $ftp->peerhost, $2 ] : undef; } sub unique_name { my $ftp = shift; ${*$ftp}{'net_ftp_unique'} || undef; } sub supported { @_ == 2 or croak 'usage: $ftp->supported( CMD )'; my $ftp = shift; my $cmd = uc shift; my $hash = ${*$ftp}{'net_ftp_supported'} ||= {}; return $hash->{$cmd} if exists $hash->{$cmd}; return $hash->{$cmd} = 1 if $ftp->feature($cmd); return $hash->{$cmd} = 0 unless $ftp->_HELP($cmd); my $text = $ftp->message; if ($text =~ /following.+commands/i) { $text =~ s/^.*\n//; while ($text =~ /(\*?)(\w+)(\*?)/sg) { $hash->{"\U$2"} = !length("$1$3"); } } else { $hash->{$cmd} = $text !~ /unimplemented/i; } $hash->{$cmd} ||= 0; } ## ## Deprecated methods ## sub lsl { carp "Use of Net::FTP::lsl deprecated, use 'dir'" if $^W; goto &dir; } sub authorise { carp "Use of Net::FTP::authorise deprecated, use 'authorize'" if $^W; goto &authorize; } ## ## Private methods ## sub _extract_path { my ($ftp, $path) = @_; # This tries to work both with and without the quote doubling # convention (RFC 959 requires it, but the first 3 servers I checked # didn't implement it). It will fail on a server which uses a quote in # the message which isn't a part of or surrounding the path. $ftp->ok && $ftp->message =~ /(?:^|\s)\"(.*)\"(?:$|\s)/ && ($path = $1) =~ s/\"\"/\"/g; $path; } ## ## Communication methods ## sub _dataconn { my $ftp = shift; my $pkg = "Net::FTP::" . $ftp->type; eval "require " . $pkg ## no critic (BuiltinFunctions::ProhibitStringyEval) or croak("cannot load $pkg required for type ".$ftp->type); $pkg =~ s/ /_/g; delete ${*$ftp}{net_ftp_dataconn}; my $conn; my $pasv = ${*$ftp}{net_ftp_pasv}; if ($pasv) { $conn = $pkg->new( PeerAddr => $pasv->[0], PeerPort => $pasv->[1], LocalAddr => ${*$ftp}{net_ftp_localaddr}, $family_key => ${*$ftp}{net_ftp_domain}, Timeout => $ftp->timeout, can_ssl() ? ( SSL_startHandshake => 0, $ftp->is_SSL ? ( SSL_reuse_ctx => $ftp, SSL_verifycn_name => ${*$ftp}{net_ftp_tlsargs}{SSL_verifycn_name}, # This will cause the use of SNI if supported by IO::Socket::SSL. $ftp->can_client_sni ? ( SSL_hostname => ${*$ftp}{net_ftp_tlsargs}{SSL_hostname} ):(), ) :( %{${*$ftp}{net_ftp_tlsargs}} ), ):(), ) or return; } elsif (my $listen = delete ${*$ftp}{net_ftp_listen}) { $conn = $listen->accept($pkg) or return; $conn->timeout($ftp->timeout); close($listen); } else { croak("no listener in active mode"); } if (( ${*$ftp}{net_ftp_tlsprot} || '') eq 'P') { if ($conn->connect_SSL) { # SSL handshake ok } else { carp("failed to ssl upgrade dataconn: $IO::Socket::SSL::SSL_ERROR"); return; } } ${*$ftp}{net_ftp_dataconn} = $conn; ${*$conn} = ""; ${*$conn}{net_ftp_cmd} = $ftp; ${*$conn}{net_ftp_blksize} = ${*$ftp}{net_ftp_blksize}; return $conn; } sub _list_cmd { my $ftp = shift; my $cmd = uc shift; delete ${*$ftp}{'net_ftp_port'}; delete ${*$ftp}{'net_ftp_pasv'}; my $data = $ftp->_data_cmd($cmd, @_); return unless (defined $data); require Net::FTP::A; bless $data, "Net::FTP::A"; # Force ASCII mode my $databuf = ''; my $buf = ''; my $blksize = ${*$ftp}{'net_ftp_blksize'}; while ($data->read($databuf, $blksize)) { $buf .= $databuf; } my $list = [split(/\n/, $buf)]; $data->close(); if (EBCDIC) { for (@$list) { $_ = $ftp->toebcdic($_) } } wantarray ? @{$list} : $list; } sub _data_cmd { my $ftp = shift; my $cmd = uc shift; my $ok = 1; my $where = delete ${*$ftp}{'net_ftp_rest'} || 0; my $arg; for my $arg (@_) { croak("Bad argument '$arg'\n") if $arg =~ /[\r\n]/s; } if ( ${*$ftp}{'net_ftp_passive'} && !defined ${*$ftp}{'net_ftp_pasv'} && !defined ${*$ftp}{'net_ftp_port'}) { return unless defined $ftp->pasv; if ($where and !$ftp->_REST($where)) { my ($status, $message) = ($ftp->status, $ftp->message); $ftp->abort; $ftp->set_status($status, $message); return; } # first send command, then open data connection # otherwise the peer might not do a full accept (with SSL # handshake if PROT P) $ftp->command($cmd, @_); my $data = $ftp->_dataconn(); if (CMD_INFO == $ftp->response()) { $data->reading if $data && $cmd =~ /RETR|LIST|NLST|MLSD/; return $data; } $data->_close if $data; return; } $ok = $ftp->port unless (defined ${*$ftp}{'net_ftp_port'} || defined ${*$ftp}{'net_ftp_pasv'}); $ok = $ftp->_REST($where) if $ok && $where; return unless $ok; if ($cmd =~ /(STOR|APPE|STOU)/ and exists ${*$ftp}{net_ftp_allo} and $ftp->supported("ALLO")) { $ftp->_ALLO(delete ${*$ftp}{net_ftp_allo}) or return; } $ftp->command($cmd, @_); return 1 if (defined ${*$ftp}{'net_ftp_pasv'}); $ok = CMD_INFO == $ftp->response(); return $ok unless exists ${*$ftp}{'net_ftp_intern_port'}; if ($ok) { my $data = $ftp->_dataconn(); $data->reading if $data && $cmd =~ /RETR|LIST|NLST|MLSD/; return $data; } close(delete ${*$ftp}{'net_ftp_listen'}); return; } ## ## Over-ride methods (Net::Cmd) ## sub debug_text { $_[2] =~ /^(pass|resp|acct)/i ? "$1 ....\n" : $_[2]; } sub command { my $ftp = shift; delete ${*$ftp}{'net_ftp_port'}; $ftp->SUPER::command(@_); } sub response { my $ftp = shift; my $code = $ftp->SUPER::response() || 5; # assume 500 if undef delete ${*$ftp}{'net_ftp_pasv'} if ($code != CMD_MORE && $code != CMD_INFO); $code; } sub parse_response { return ($1, $2 eq "-") if $_[1] =~ s/^(\d\d\d)([- ]?)//o; my $ftp = shift; # Darn MS FTP server is a load of CRAP !!!! # Expect to see undef here. return () unless 0 + (${*$ftp}{'net_cmd_code'} || 0); (${*$ftp}{'net_cmd_code'}, 1); } ## ## Allow 2 servers to talk directly ## sub pasv_xfer_unique { my ($sftp, $sfile, $dftp, $dfile) = @_; $sftp->pasv_xfer($sfile, $dftp, $dfile, 1); } sub pasv_xfer { my ($sftp, $sfile, $dftp, $dfile, $unique) = @_; ($dfile = $sfile) =~ s#.*/## unless (defined $dfile); my $port = $sftp->pasv or return; $dftp->port($port) or return; return unless ($unique ? $dftp->stou($dfile) : $dftp->stor($dfile)); unless ($sftp->retr($sfile) && $sftp->response == CMD_INFO) { $sftp->retr($sfile); $dftp->abort; $dftp->response(); return; } $dftp->pasv_wait($sftp); } sub pasv_wait { @_ == 2 or croak 'usage: $ftp->pasv_wait(NON_PASV_FTP)'; my ($ftp, $non_pasv) = @_; my ($file, $rin, $rout); vec($rin = '', fileno($ftp), 1) = 1; select($rout = $rin, undef, undef, undef); my $dres = $ftp->response(); my $sres = $non_pasv->response(); return unless $dres == CMD_OK && $sres == CMD_OK; return unless $ftp->ok() && $non_pasv->ok(); return $1 if $ftp->message =~ /unique file name:\s*(\S*)\s*\)/; return $1 if $non_pasv->message =~ /unique file name:\s*(\S*)\s*\)/; return 1; } sub feature { @_ == 2 or croak 'usage: $ftp->feature( NAME )'; my ($ftp, $feat) = @_; my $feature = ${*$ftp}{net_ftp_feature} ||= do { my @feat; # Example response # 211-Features: # MDTM # REST STREAM # SIZE # 211 End @feat = map { /^\s+(.*\S)/ } $ftp->message if $ftp->_FEAT; \@feat; }; return grep { /^\Q$feat\E\b/i } @$feature; } sub cmd { shift->command(@_)->response() } ######################################## # # RFC959 + RFC2428 + RFC4217 commands # sub _ABOR { shift->command("ABOR")->response() == CMD_OK } sub _ALLO { shift->command("ALLO", @_)->response() == CMD_OK } sub _CDUP { shift->command("CDUP")->response() == CMD_OK } sub _NOOP { shift->command("NOOP")->response() == CMD_OK } sub _PASV { shift->command("PASV")->response() == CMD_OK } sub _QUIT { shift->command("QUIT")->response() == CMD_OK } sub _DELE { shift->command("DELE", @_)->response() == CMD_OK } sub _CWD { shift->command("CWD", @_)->response() == CMD_OK } sub _PORT { shift->command("PORT", @_)->response() == CMD_OK } sub _RMD { shift->command("RMD", @_)->response() == CMD_OK } sub _MKD { shift->command("MKD", @_)->response() == CMD_OK } sub _PWD { shift->command("PWD", @_)->response() == CMD_OK } sub _TYPE { shift->command("TYPE", @_)->response() == CMD_OK } sub _RNTO { shift->command("RNTO", @_)->response() == CMD_OK } sub _RESP { shift->command("RESP", @_)->response() == CMD_OK } sub _MDTM { shift->command("MDTM", @_)->response() == CMD_OK } sub _SIZE { shift->command("SIZE", @_)->response() == CMD_OK } sub _HELP { shift->command("HELP", @_)->response() == CMD_OK } sub _STAT { shift->command("STAT", @_)->response() == CMD_OK } sub _FEAT { shift->command("FEAT", @_)->response() == CMD_OK } sub _PBSZ { shift->command("PBSZ", @_)->response() == CMD_OK } sub _PROT { shift->command("PROT", @_)->response() == CMD_OK } sub _CCC { shift->command("CCC", @_)->response() == CMD_OK } sub _EPRT { shift->command("EPRT", @_)->response() == CMD_OK } sub _EPSV { shift->command("EPSV", @_)->response() == CMD_OK } sub _APPE { shift->command("APPE", @_)->response() == CMD_INFO } sub _LIST { shift->command("LIST", @_)->response() == CMD_INFO } sub _NLST { shift->command("NLST", @_)->response() == CMD_INFO } sub _RETR { shift->command("RETR", @_)->response() == CMD_INFO } sub _STOR { shift->command("STOR", @_)->response() == CMD_INFO } sub _STOU { shift->command("STOU", @_)->response() == CMD_INFO } sub _RNFR { shift->command("RNFR", @_)->response() == CMD_MORE } sub _REST { shift->command("REST", @_)->response() == CMD_MORE } sub _PASS { shift->command("PASS", @_)->response() } sub _ACCT { shift->command("ACCT", @_)->response() } sub _AUTH { shift->command("AUTH", @_)->response() } sub _USER { my $ftp = shift; my $ok = $ftp->command("USER", @_)->response(); # A certain brain dead firewall :-) $ok = $ftp->command("user", @_)->response() unless $ok == CMD_MORE or $ok == CMD_OK; $ok; } sub _SMNT { shift->unsupported(@_) } sub _MODE { shift->unsupported(@_) } sub _SYST { shift->unsupported(@_) } sub _STRU { shift->unsupported(@_) } sub _REIN { shift->unsupported(@_) } { # Session Cache with single entry # used to make sure that we reuse same session for control and data channels package Net::FTP::_SSL_SingleSessionCache; sub new { my $x; return bless \$x,shift } sub add_session { my ($cache,$key,$session) = @_; Net::SSLeay::SESSION_free($$cache) if $$cache; $$cache = $session; } sub get_session { my $cache = shift; return $$cache } sub DESTROY { my $cache = shift; Net::SSLeay::SESSION_free($$cache) if $$cache; } } 1; __END__ =head1 NAME Net::FTP - FTP Client class =head1 SYNOPSIS use Net::FTP; $ftp = Net::FTP->new("some.host.name", Debug => 0) or die "Cannot connect to some.host.name: $@"; $ftp->login("anonymous",'-anonymous@') or die "Cannot login ", $ftp->message; $ftp->cwd("/pub") or die "Cannot change working directory ", $ftp->message; $ftp->get("that.file") or die "get failed ", $ftp->message; $ftp->quit; =head1 DESCRIPTION C is a class implementing a simple FTP client in Perl as described in RFC959. It provides wrappers for the commonly used subset of the RFC959 commands. If L or L is installed it also provides support for IPv6 as defined in RFC2428. And with L installed it provides support for implicit FTPS and explicit FTPS as defined in RFC4217. The Net::FTP class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. =head1 OVERVIEW FTP stands for File Transfer Protocol. It is a way of transferring files between networked machines. The protocol defines a client (whose commands are provided by this module) and a server (not implemented in this module). Communication is always initiated by the client, and the server responds with a message and a status code (and sometimes with data). The FTP protocol allows files to be sent to or fetched from the server. Each transfer involves a B (on the client) and a B (on the server). In this module, the same file name will be used for both local and remote if only one is specified. This means that transferring remote file C will try to put that file in C locally, unless you specify a local file name. The protocol also defines several standard B which the file can undergo during transfer. These are ASCII, EBCDIC, binary, and byte. ASCII is the default type, and indicates that the sender of files will translate the ends of lines to a standard representation which the receiver will then translate back into their local representation. EBCDIC indicates the file being transferred is in EBCDIC format. Binary (also known as image) format sends the data as a contiguous bit stream. Byte format transfers the data as bytes, the values of which remain the same regardless of differences in byte size between the two machines (in theory - in practice you should only use this if you really know what you're doing). This class does not support the EBCDIC or byte formats, and will default to binary instead if they are attempted. =head1 CONSTRUCTOR =over 4 =item new ([ HOST ] [, OPTIONS ]) This is the constructor for a new Net::FTP object. C is the name of the remote host to which an FTP connection is required. C is optional. If C is not given then it may instead be passed as the C option described below. C are passed in a hash like fashion, using key and value pairs. Possible options are: B - FTP host to connect to. It may be a single scalar, as defined for the C option in L, or a reference to an array with hosts to try in turn. The L method will return the value which was used to connect to the host. B - The name of a machine which acts as an FTP firewall. This can be overridden by an environment variable C. If specified, and the given host cannot be directly connected to, then the connection is made to the firewall machine and the string C<@hostname> is appended to the login identifier. This kind of setup is also referred to as an ftp proxy. B - The type of firewall running on the machine indicated by B. This can be overridden by an environment variable C. For a list of permissible types, see the description of ftp_firewall_type in L. B - This is the block size that Net::FTP will use when doing transfers. (defaults to 10240) B - The port number to connect to on the remote machine for the FTP connection B - If the connection should be done from start with SSL, contrary to later upgrade with C. B - SSL arguments which will be applied when upgrading the control or data connection to SSL. You can use SSL arguments as documented in L, but it will usually use the right arguments already. B - Set a timeout value in seconds (defaults to 120) B - debug level (see the debug method in L) B - If set to a non-zero value then all data transfers will be done using passive mode. If set to zero then data transfers will be done using active mode. If the machine is connected to the Internet directly, both passive and active mode should work equally well. Behind most firewall and NAT configurations passive mode has a better chance of working. However, in some rare firewall configurations, active mode actually works when passive mode doesn't. Some really old FTP servers might not implement passive transfers. If not specified, then the transfer mode is set by the environment variable C or if that one is not set by the settings done by the F utility. If none of these apply then passive mode is used. B - If given a reference to a file handle (e.g., C<\*STDERR>), print hash marks (#) on that filehandle every 1024 bytes. This simply invokes the C method for you, so that hash marks are displayed for all transfers. You can, of course, call C explicitly whenever you'd like. B - Local address to use for all socket connections. This argument will be passed to the super class, i.e. L or L. B - Domain to use, i.e. AF_INET or AF_INET6. This argument will be passed to the IO::Socket super class. This can be used to enforce IPv4 even with L which would default to IPv6. B is accepted as alternative name for B. If the constructor fails undef will be returned and an error message will be in $@ =back =head1 METHODS Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method states that it returns a value, failure will be returned as I or an empty list. C inherits from C so methods defined in C may be used to send commands to the remote FTP server in addition to the methods documented here. =over 4 =item login ([LOGIN [,PASSWORD [, ACCOUNT] ] ]) Log into the remote FTP server with the given login information. If no arguments are given then the C uses the C package to lookup the login information for the connected host. If no information is found then a login of I is used. If no password is given and the login is I then I will be used for password. If the connection is via a firewall then the C method will be called with no arguments. =item starttls () Upgrade existing plain connection to SSL. The SSL arguments have to be given in C already because they are needed for data connections too. =item stoptls () Downgrade existing SSL connection back to plain. This is needed to work with some FTP helpers at firewalls, which need to see the PORT and PASV commands and responses to dynamically open the necessary ports. In this case C is usually only done to protect the authorization. =item prot ( LEVEL ) Set what type of data channel protection the client and server will be using. Only Cs "C" (clear) and "P" (private) are supported. =item host () Returns the value used by the constructor, and passed to the IO::Socket super class to connect to the host. =item account( ACCT ) Set a string identifying the user's account. =item authorize ( [AUTH [, RESP]]) This is a protocol used by some firewall ftp proxies. It is used to authorise the user to send data out. If both arguments are not specified then C uses C to do a lookup. =item site (ARGS) Send a SITE command to the remote server and wait for a response. Returns most significant digit of the response code. =item ascii () Transfer file in ASCII. CRLF translation will be done if required =item binary () Transfer file in binary mode. No transformation will be done. B: If both server and client machines use the same line ending for text files, then it will be faster to transfer all files in binary mode. =item type ( [ TYPE ] ) Set or get if files will be transferred in ASCII or binary mode. =item rename ( OLDNAME, NEWNAME ) Rename a file on the remote FTP server from C to C. This is done by sending the RNFR and RNTO commands. =item delete ( FILENAME ) Send a request to the server to delete C. =item cwd ( [ DIR ] ) Attempt to change directory to the directory given in C<$dir>. If C<$dir> is C<"..">, the FTP C command is used to attempt to move up one directory. If no directory is given then an attempt is made to change the directory to the root directory. =item cdup () Change directory to the parent of the current directory. =item passive ( [ PASSIVE ] ) Set or get if data connections will be initiated in passive mode. =item pwd () Returns the full pathname of the current directory. =item restart ( WHERE ) Set the byte offset at which to begin the next data transfer. Net::FTP simply records this value and uses it when during the next data transfer. For this reason this method will not return an error, but setting it may cause a subsequent data transfer to fail. =item rmdir ( DIR [, RECURSE ]) Remove the directory with the name C. If C is I then C will attempt to delete everything inside the directory. =item mkdir ( DIR [, RECURSE ]) Create a new directory with the name C. If C is I then C will attempt to create all the directories in the given path. Returns the full pathname to the new directory. =item alloc ( SIZE [, RECORD_SIZE] ) The alloc command allows you to give the ftp server a hint about the size of the file about to be transferred using the ALLO ftp command. Some storage systems use this to make intelligent decisions about how to store the file. The C argument represents the size of the file in bytes. The C argument indicates a maximum record or page size for files sent with a record or page structure. The size of the file will be determined, and sent to the server automatically for normal files so that this method need only be called if you are transferring data from a socket, named pipe, or other stream not associated with a normal file. =item ls ( [ DIR ] ) Get a directory listing of C, or the current directory. In an array context, returns a list of lines returned from the server. In a scalar context, returns a reference to a list. =item dir ( [ DIR ] ) Get a directory listing of C, or the current directory in long format. In an array context, returns a list of lines returned from the server. In a scalar context, returns a reference to a list. =item get ( REMOTE_FILE [, LOCAL_FILE [, WHERE]] ) Get C from the server and store locally. C may be a filename or a filehandle. If not specified, the file will be stored in the current directory with the same leafname as the remote file. If C is given then the first C bytes of the file will not be transferred, and the remaining bytes will be appended to the local file if it already exists. Returns C, or the generated local file name if C is not given. If an error was encountered undef is returned. =item put ( LOCAL_FILE [, REMOTE_FILE ] ) Put a file on the remote server. C may be a name or a filehandle. If C is a filehandle then C must be specified. If C is not specified then the file will be stored in the current directory with the same leafname as C. Returns C, or the generated remote filename if C is not given. B: If for some reason the transfer does not complete and an error is returned then the contents that had been transferred will not be remove automatically. =item put_unique ( LOCAL_FILE [, REMOTE_FILE ] ) Same as put but uses the C command. Returns the name of the file on the server. =item append ( LOCAL_FILE [, REMOTE_FILE ] ) Same as put but appends to the file on the remote server. Returns C, or the generated remote filename if C is not given. =item unique_name () Returns the name of the last file stored on the server using the C command. =item mdtm ( FILE ) Returns the I of the given file =item size ( FILE ) Returns the size in bytes for the given file as stored on the remote server. B: The size reported is the size of the stored file on the remote server. If the file is subsequently transferred from the server in ASCII mode and the remote server and local machine have different ideas about "End Of Line" then the size of file on the local machine after transfer may be different. =item supported ( CMD ) Returns TRUE if the remote server supports the given command. =item hash ( [FILEHANDLE_GLOB_REF],[ BYTES_PER_HASH_MARK] ) Called without parameters, or with the first argument false, hash marks are suppressed. If the first argument is true but not a reference to a file handle glob, then \*STDERR is used. The second argument is the number of bytes per hash mark printed, and defaults to 1024. In all cases the return value is a reference to an array of two: the filehandle glob reference and the bytes per hash mark. =item feature ( NAME ) Determine if the server supports the specified feature. The return value is a list of lines the server responded with to describe the options that it supports for the given feature. If the feature is unsupported then the empty list is returned. if ($ftp->feature( 'MDTM' )) { # Do something } if (grep { /\bTLS\b/ } $ftp->feature('AUTH')) { # Server supports TLS } =back The following methods can return different results depending on how they are called. If the user explicitly calls either of the C or C methods then these methods will return a I or I value. If the user does not call either of these methods then the result will be a reference to a C based object. =over 4 =item nlst ( [ DIR ] ) Send an C command to the server, with an optional parameter. =item list ( [ DIR ] ) Same as C but using the C command =item retr ( FILE ) Begin the retrieval of a file called C from the remote server. =item stor ( FILE ) Tell the server that you wish to store a file. C is the name of the new file that should be created. =item stou ( FILE ) Same as C but using the C command. The name of the unique file which was created on the server will be available via the C method after the data connection has been closed. =item appe ( FILE ) Tell the server that we want to append some data to the end of a file called C. If this file does not exist then create it. =back If for some reason you want to have complete control over the data connection, this includes generating it and calling the C method when required, then the user can use these methods to do so. However calling these methods only affects the use of the methods above that can return a data connection. They have no effect on methods C, C, C and those that do not require data connections. =over 4 =item port ( [ PORT ] ) =item eprt ( [ PORT ] ) Send a C (IPv4) or C (IPv6) command to the server. If C is specified then it is sent to the server. If not, then a listen socket is created and the correct information sent to the server. =item pasv () =item epsv () Tell the server to go into passive mode (C for IPv4, C for IPv6). Returns the text that represents the port on which the server is listening, this text is in a suitable form to send to another ftp server using the C or C method. =back The following methods can be used to transfer files between two remote servers, providing that these two servers can connect directly to each other. =over 4 =item pasv_xfer ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ) This method will do a file transfer between two remote ftp servers. If C is omitted then the leaf name of C will be used. =item pasv_xfer_unique ( SRC_FILE, DEST_SERVER [, DEST_FILE ] ) Like C but the file is stored on the remote server using the STOU command. =item pasv_wait ( NON_PASV_SERVER ) This method can be used to wait for a transfer to complete between a passive server and a non-passive server. The method should be called on the passive server with the C object for the non-passive server passed as an argument. =item abort () Abort the current data transfer. =item quit () Send the QUIT command to the remote FTP server and close the socket connection. =back =head2 Methods for the adventurous =over 4 =item quot (CMD [,ARGS]) Send a command, that Net::FTP does not directly support, to the remote server and wait for a response. Returns most significant digit of the response code. B This call should only be used on commands that do not require data connections. Misuse of this method can hang the connection. =item can_inet6 () Returns whether we can use IPv6. =item can_ssl () Returns whether we can use SSL. =back =head1 THE dataconn CLASS Some of the methods defined in C return an object which will be derived from the C class. See L for more details. =head1 UNIMPLEMENTED The following RFC959 commands have not been implemented: =over 4 =item B Mount a different file system structure without changing login or accounting information. =item B Ask the server for "helpful information" (that's what the RFC says) on the commands it accepts. =item B Specifies transfer mode (stream, block or compressed) for file to be transferred. =item B Request remote server system identification. =item B Request remote server status. =item B Specifies file structure for file to be transferred. =item B Reinitialize the connection, flushing all I/O and account information. =back =head1 REPORTING BUGS When reporting bugs/problems please include as much information as possible. It may be difficult for me to reproduce the problem as almost every setup is different. A small script which yields the problem will probably be of help. It would also be useful if this script was run with the extra options C<< Debug => 1 >> passed to the constructor, and the output sent with the bug report. If you cannot include a small script then please include a Debug trace from a run of your program which does yield the problem. =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 SEE ALSO L, L, L ftp(1), ftpd(8), RFC 959, RFC 2428, RFC 4217 http://www.ietf.org/rfc/rfc959.txt http://www.ietf.org/rfc/rfc2428.txt http://www.ietf.org/rfc/rfc4217.txt =head1 USE EXAMPLES For an example of the use of Net::FTP see =over 4 =item http://www.csh.rit.edu/~adam/Progs/ C is a program that can retrieve, send, or list files via the FTP protocol in a non-interactive manner. =back =head1 CREDITS Henry Gabryjelski - for the suggestion of creating directories recursively. Nathan Torkington - for some input on the documentation. Roderick Schertler - for various inputs =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. Copyright (C) 2013-2017 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut SMTP.pm000064400000070177152346665430005717 0ustar00# Net::SMTP.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. # Copyright (C) 2013-2016 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::SMTP; use 5.008001; use strict; use warnings; use Carp; use IO::Socket; use Net::Cmd; use Net::Config; use Socket; our $VERSION = "3.11"; # Code for detecting if we can use SSL my $ssl_class = eval { require IO::Socket::SSL; # first version with default CA on most platforms no warnings 'numeric'; IO::Socket::SSL->VERSION(2.007); } && 'IO::Socket::SSL'; my $nossl_warn = !$ssl_class && 'To use SSL please install IO::Socket::SSL with version>=2.007'; # Code for detecting if we can use IPv6 my $family_key = 'Domain'; my $inet6_class = eval { require IO::Socket::IP; no warnings 'numeric'; IO::Socket::IP->VERSION(0.25) || die; $family_key = 'Family'; } && 'IO::Socket::IP' || eval { require IO::Socket::INET6; no warnings 'numeric'; IO::Socket::INET6->VERSION(2.62); } && 'IO::Socket::INET6'; sub can_ssl { $ssl_class }; sub can_inet6 { $inet6_class }; our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); sub new { my $self = shift; my $type = ref($self) || $self; my ($host, %arg); if (@_ % 2) { $host = shift; %arg = @_; } else { %arg = @_; $host = delete $arg{Host}; } if ($arg{SSL}) { # SSL from start die $nossl_warn if !$ssl_class; $arg{Port} ||= 465; } my $hosts = defined $host ? $host : $NetConfig{smtp_hosts}; my $obj; $arg{Timeout} = 120 if ! defined $arg{Timeout}; foreach my $h (@{ref($hosts) ? $hosts : [$hosts]}) { $obj = $type->SUPER::new( PeerAddr => ($host = $h), PeerPort => $arg{Port} || 'smtp(25)', LocalAddr => $arg{LocalAddr}, LocalPort => $arg{LocalPort}, $family_key => $arg{Domain} || $arg{Family}, Proto => 'tcp', Timeout => $arg{Timeout} ) and last; } return unless defined $obj; ${*$obj}{'net_smtp_arg'} = \%arg; ${*$obj}{'net_smtp_host'} = $host; if ($arg{SSL}) { Net::SMTP::_SSL->start_SSL($obj,%arg) or return; } $obj->autoflush(1); $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); unless ($obj->response() == CMD_OK) { my $err = ref($obj) . ": " . $obj->code . " " . $obj->message; $obj->close(); $@ = $err; return; } ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses}; (${*$obj}{'net_smtp_banner'}) = $obj->message; (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/; if (!exists $arg{SendHello} || $arg{SendHello}) { unless ($obj->hello($arg{Hello} || "")) { my $err = ref($obj) . ": " . $obj->code . " " . $obj->message; $obj->close(); $@ = $err; return; } } $obj; } sub host { my $me = shift; ${*$me}{'net_smtp_host'}; } ## ## User interface methods ## sub banner { my $me = shift; return ${*$me}{'net_smtp_banner'} || undef; } sub domain { my $me = shift; return ${*$me}{'net_smtp_domain'} || undef; } sub etrn { my $self = shift; defined($self->supports('ETRN', 500, ["Command unknown: 'ETRN'"])) && $self->_ETRN(@_); } sub auth { my ($self, $username, $password) = @_; eval { require MIME::Base64; require Authen::SASL; } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0; my $mechanisms = $self->supports('AUTH', 500, ["Command unknown: 'AUTH'"]); return unless defined $mechanisms; my $sasl; if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { $sasl = $username; my $requested_mechanisms = $sasl->mechanism(); if (! defined($requested_mechanisms) || $requested_mechanisms eq '') { $sasl->mechanism($mechanisms); } } else { die "auth(username, password)" if not length $username; $sasl = Authen::SASL->new( mechanism => $mechanisms, callback => { user => $username, pass => $password, authname => $username, }, debug => $self->debug ); } my $client; my $str; do { if ($client) { # $client mechanism failed, so we need to exclude this mechanism from list my $failed_mechanism = $client->mechanism; return unless defined $failed_mechanism; $self->debug_text("Auth mechanism failed: $failed_mechanism") if $self->debug; $mechanisms =~ s/\b\Q$failed_mechanism\E\b//; return unless $mechanisms =~ /\S/; $sasl->mechanism($mechanisms); } # We should probably allow the user to pass the host, but I don't # currently know and SASL mechanisms that are used by smtp that need it $client = $sasl->client_new('smtp', ${*$self}{'net_smtp_host'}, 0); $str = $client->client_start; } while (!defined $str); # We don't support sasl mechanisms that encrypt the socket traffic. # todo that we would really need to change the ISA hierarchy # so we don't inherit from IO::Socket, but instead hold it in an attribute my @cmd = ("AUTH", $client->mechanism); my $code; push @cmd, MIME::Base64::encode_base64($str, '') if defined $str and length $str; while (($code = $self->command(@cmd)->response()) == CMD_MORE) { my $str2 = MIME::Base64::decode_base64(($self->message)[0]); $self->debug_print(0, "(decoded) " . $str2 . "\n") if $self->debug; $str = $client->client_step($str2); @cmd = ( MIME::Base64::encode_base64($str, '') ); $self->debug_print(1, "(decoded) " . $str . "\n") if $self->debug; } $code == CMD_OK; } sub hello { my $me = shift; my $domain = shift || "localhost.localdomain"; my $ok = $me->_EHLO($domain); my @msg = $me->message; if ($ok) { my $h = ${*$me}{'net_smtp_esmtp'} = {}; foreach my $ln (@msg) { $h->{uc $1} = $2 if $ln =~ /([-\w]+)\b[= \t]*([^\n]*)/; } } elsif ($me->status == CMD_ERROR) { @msg = $me->message if $ok = $me->_HELO($domain); } return unless $ok; ${*$me}{net_smtp_hello_domain} = $domain; $msg[0] =~ /\A\s*(\S+)/; return ($1 || " "); } sub starttls { my $self = shift; $ssl_class or die $nossl_warn; $self->_STARTTLS or return; Net::SMTP::_SSL->start_SSL($self, %{ ${*$self}{'net_smtp_arg'} }, # (ssl) args given in new @_ # more (ssl) args ) or return; # another hello after starttls to read new ESMTP capabilities return $self->hello(${*$self}{net_smtp_hello_domain}); } sub supports { my $self = shift; my $cmd = uc shift; return ${*$self}{'net_smtp_esmtp'}->{$cmd} if exists ${*$self}{'net_smtp_esmtp'}->{$cmd}; $self->set_status(@_) if @_; return; } sub _addr { my $self = shift; my $addr = shift; $addr = "" unless defined $addr; if (${*$self}{'net_smtp_exact_addr'}) { return $1 if $addr =~ /^\s*(<.*>)\s*$/s; } else { return $1 if $addr =~ /(<[^>]*>)/; $addr =~ s/^\s+|\s+$//sg; } "<$addr>"; } sub mail { my $me = shift; my $addr = _addr($me, shift); my $opts = ""; if (@_) { my %opt = @_; my ($k, $v); if (exists ${*$me}{'net_smtp_esmtp'}) { my $esmtp = ${*$me}{'net_smtp_esmtp'}; if (defined($v = delete $opt{Size})) { if (exists $esmtp->{SIZE}) { $opts .= sprintf " SIZE=%d", $v + 0; } else { carp 'Net::SMTP::mail: SIZE option not supported by host'; } } if (defined($v = delete $opt{Return})) { if (exists $esmtp->{DSN}) { $opts .= " RET=" . ((uc($v) eq "FULL") ? "FULL" : "HDRS"); } else { carp 'Net::SMTP::mail: DSN option not supported by host'; } } if (defined($v = delete $opt{Bits})) { if ($v eq "8") { if (exists $esmtp->{'8BITMIME'}) { $opts .= " BODY=8BITMIME"; } else { carp 'Net::SMTP::mail: 8BITMIME option not supported by host'; } } elsif ($v eq "binary") { if (exists $esmtp->{'BINARYMIME'} && exists $esmtp->{'CHUNKING'}) { $opts .= " BODY=BINARYMIME"; ${*$me}{'net_smtp_chunking'} = 1; } else { carp 'Net::SMTP::mail: BINARYMIME option not supported by host'; } } elsif (exists $esmtp->{'8BITMIME'} or exists $esmtp->{'BINARYMIME'}) { $opts .= " BODY=7BIT"; } else { carp 'Net::SMTP::mail: 8BITMIME and BINARYMIME options not supported by host'; } } if (defined($v = delete $opt{Transaction})) { if (exists $esmtp->{CHECKPOINT}) { $opts .= " TRANSID=" . _addr($me, $v); } else { carp 'Net::SMTP::mail: CHECKPOINT option not supported by host'; } } if (defined($v = delete $opt{Envelope})) { if (exists $esmtp->{DSN}) { $v =~ s/([^\041-\176]|=|\+)/sprintf "+%02X", ord($1)/sge; $opts .= " ENVID=$v"; } else { carp 'Net::SMTP::mail: DSN option not supported by host'; } } if (defined($v = delete $opt{ENVID})) { # expected to be in a format as required by RFC 3461, xtext-encoded if (exists $esmtp->{DSN}) { $opts .= " ENVID=$v"; } else { carp 'Net::SMTP::mail: DSN option not supported by host'; } } if (defined($v = delete $opt{AUTH})) { # expected to be in a format as required by RFC 2554, # rfc2821-quoted and xtext-encoded, or <> if (exists $esmtp->{AUTH}) { $v = '<>' if !defined($v) || $v eq ''; $opts .= " AUTH=$v"; } else { carp 'Net::SMTP::mail: AUTH option not supported by host'; } } if (defined($v = delete $opt{XVERP})) { if (exists $esmtp->{'XVERP'}) { $opts .= " XVERP"; } else { carp 'Net::SMTP::mail: XVERP option not supported by host'; } } carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' if scalar keys %opt; } else { carp 'Net::SMTP::mail: ESMTP not supported by host - options discarded :-('; } } $me->_MAIL("FROM:" . $addr . $opts); } sub send { my $me = shift; $me->_SEND("FROM:" . _addr($me, $_[0])) } sub send_or_mail { my $me = shift; $me->_SOML("FROM:" . _addr($me, $_[0])) } sub send_and_mail { my $me = shift; $me->_SAML("FROM:" . _addr($me, $_[0])) } sub reset { my $me = shift; $me->dataend() if (exists ${*$me}{'net_smtp_lastch'}); $me->_RSET(); } sub recipient { my $smtp = shift; my $opts = ""; my $skip_bad = 0; if (@_ && ref($_[-1])) { my %opt = %{pop(@_)}; my $v; $skip_bad = delete $opt{'SkipBad'}; if (exists ${*$smtp}{'net_smtp_esmtp'}) { my $esmtp = ${*$smtp}{'net_smtp_esmtp'}; if (defined($v = delete $opt{Notify})) { if (exists $esmtp->{DSN}) { $opts .= " NOTIFY=" . join(",", map { uc $_ } @$v); } else { carp 'Net::SMTP::recipient: DSN option not supported by host'; } } if (defined($v = delete $opt{ORcpt})) { if (exists $esmtp->{DSN}) { $opts .= " ORCPT=" . $v; } else { carp 'Net::SMTP::recipient: DSN option not supported by host'; } } carp 'Net::SMTP::recipient: unknown option(s) ' . join(" ", keys %opt) . ' - ignored' if scalar keys %opt; } elsif (%opt) { carp 'Net::SMTP::recipient: ESMTP not supported by host - options discarded :-('; } } my @ok; foreach my $addr (@_) { if ($smtp->_RCPT("TO:" . _addr($smtp, $addr) . $opts)) { push(@ok, $addr) if $skip_bad; } elsif (!$skip_bad) { return 0; } } return $skip_bad ? @ok : 1; } BEGIN { *to = \&recipient; *cc = \&recipient; *bcc = \&recipient; } sub data { my $me = shift; if (exists ${*$me}{'net_smtp_chunking'}) { carp 'Net::SMTP::data: CHUNKING extension in use, must call bdat instead'; } else { my $ok = $me->_DATA() && $me->datasend(@_); $ok && @_ ? $me->dataend : $ok; } } sub bdat { my $me = shift; if (exists ${*$me}{'net_smtp_chunking'}) { my $data = shift; $me->_BDAT(length $data) && $me->rawdatasend($data) && $me->response() == CMD_OK; } else { carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead'; } } sub bdatlast { my $me = shift; if (exists ${*$me}{'net_smtp_chunking'}) { my $data = shift; $me->_BDAT(length $data, "LAST") && $me->rawdatasend($data) && $me->response() == CMD_OK; } else { carp 'Net::SMTP::bdat: CHUNKING extension is not in use, call data instead'; } } sub datafh { my $me = shift; return unless $me->_DATA(); return $me->tied_fh; } sub expand { my $me = shift; $me->_EXPN(@_) ? ($me->message) : (); } sub verify { shift->_VRFY(@_) } sub help { my $me = shift; $me->_HELP(@_) ? scalar $me->message : undef; } sub quit { my $me = shift; $me->_QUIT; $me->close; } sub DESTROY { # ignore } ## ## RFC821 commands ## sub _EHLO { shift->command("EHLO", @_)->response() == CMD_OK } sub _HELO { shift->command("HELO", @_)->response() == CMD_OK } sub _MAIL { shift->command("MAIL", @_)->response() == CMD_OK } sub _RCPT { shift->command("RCPT", @_)->response() == CMD_OK } sub _SEND { shift->command("SEND", @_)->response() == CMD_OK } sub _SAML { shift->command("SAML", @_)->response() == CMD_OK } sub _SOML { shift->command("SOML", @_)->response() == CMD_OK } sub _VRFY { shift->command("VRFY", @_)->response() == CMD_OK } sub _EXPN { shift->command("EXPN", @_)->response() == CMD_OK } sub _HELP { shift->command("HELP", @_)->response() == CMD_OK } sub _RSET { shift->command("RSET")->response() == CMD_OK } sub _NOOP { shift->command("NOOP")->response() == CMD_OK } sub _QUIT { shift->command("QUIT")->response() == CMD_OK } sub _DATA { shift->command("DATA")->response() == CMD_MORE } sub _BDAT { shift->command("BDAT", @_) } sub _TURN { shift->unsupported(@_); } sub _ETRN { shift->command("ETRN", @_)->response() == CMD_OK } sub _AUTH { shift->command("AUTH", @_)->response() == CMD_OK } sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK } { package Net::SMTP::_SSL; our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::SMTP' ); sub starttls { die "SMTP connection is already in SSL mode" } sub start_SSL { my ($class,$smtp,%arg) = @_; delete @arg{ grep { !m{^SSL_} } keys %arg }; ( $arg{SSL_verifycn_name} ||= $smtp->host ) =~s{(?can_client_sni; $arg{SSL_verifycn_scheme} ||= 'smtp'; my $ok = $class->SUPER::start_SSL($smtp,%arg); $@ = $ssl_class->errstr if !$ok; return $ok; } } 1; __END__ =head1 NAME Net::SMTP - Simple Mail Transfer Protocol Client =head1 SYNOPSIS use Net::SMTP; # Constructors $smtp = Net::SMTP->new('mailhost'); $smtp = Net::SMTP->new('mailhost', Timeout => 60); =head1 DESCRIPTION This module implements a client interface to the SMTP and ESMTP protocol, enabling a perl5 application to talk to SMTP servers. This documentation assumes that you are familiar with the concepts of the SMTP protocol described in RFC2821. With L installed it also provides support for implicit and explicit TLS encryption, i.e. SMTPS or SMTP+STARTTLS. The Net::SMTP class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. =head1 EXAMPLES This example prints the mail domain name of the SMTP server known as mailhost: #!/usr/local/bin/perl -w use Net::SMTP; $smtp = Net::SMTP->new('mailhost'); print $smtp->domain,"\n"; $smtp->quit; This example sends a small message to the postmaster at the SMTP server known as mailhost: #!/usr/local/bin/perl -w use Net::SMTP; my $smtp = Net::SMTP->new('mailhost'); $smtp->mail($ENV{USER}); if ($smtp->to('postmaster')) { $smtp->data(); $smtp->datasend("To: postmaster\n"); $smtp->datasend("\n"); $smtp->datasend("A simple test message\n"); $smtp->dataend(); } else { print "Error: ", $smtp->message(); } $smtp->quit; =head1 CONSTRUCTOR =over 4 =item new ( [ HOST ] [, OPTIONS ] ) This is the constructor for a new Net::SMTP object. C is the name of the remote host to which an SMTP connection is required. On failure C will be returned and C<$@> will contain the reason for the failure. C is optional. If C is not given then it may instead be passed as the C option described below. If neither is given then the C specified in C will be used. C are passed in a hash like fashion, using key and value pairs. Possible options are: B - SMTP requires that you identify yourself. This option specifies a string to pass as your mail domain. If not given localhost.localdomain will be used. B - If false then the EHLO (or HELO) command that is normally sent when constructing the object will not be sent. In that case the command will have to be sent manually by calling C instead. B - SMTP host to connect to. It may be a single scalar (hostname[:port]), as defined for the C option in L, or a reference to an array with hosts to try in turn. The L method will return the value which was used to connect to the host. Format - C from L new method. B - port to connect to. Default - 25 for plain SMTP and 465 for immediate SSL. B - If the connection should be done from start with SSL, contrary to later upgrade with C. You can use SSL arguments as documented in L, but it will usually use the right arguments already. B and B - These parameters are passed directly to IO::Socket to allow binding the socket to a specific local address and port. B - This parameter is passed directly to IO::Socket and makes it possible to enforce IPv4 connections even if L is used as super class. Alternatively B can be used. B - Maximum time, in seconds, to wait for a response from the SMTP server (default: 120) B - If true the all ADDRESS arguments must be as defined by C in RFC2822. If not given, or false, then Net::SMTP will attempt to extract the address from the value passed. B - Enable debugging information Example: $smtp = Net::SMTP->new('mailhost', Hello => 'my.mail.domain', Timeout => 30, Debug => 1, ); # the same $smtp = Net::SMTP->new( Host => 'mailhost', Hello => 'my.mail.domain', Timeout => 30, Debug => 1, ); # the same with direct SSL $smtp = Net::SMTP->new('mailhost', Hello => 'my.mail.domain', Timeout => 30, Debug => 1, SSL => 1, ); # Connect to the default server from Net::config $smtp = Net::SMTP->new( Hello => 'my.mail.domain', Timeout => 30, ); =back =head1 METHODS Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method states that it returns a value, failure will be returned as I or an empty list. C inherits from C so methods defined in C may be used to send commands to the remote SMTP server in addition to the methods documented here. =over 4 =item banner () Returns the banner message which the server replied with when the initial connection was made. =item domain () Returns the domain that the remote SMTP server identified itself as during connection. =item hello ( DOMAIN ) Tell the remote server the mail domain which you are in using the EHLO command (or HELO if EHLO fails). Since this method is invoked automatically when the Net::SMTP object is constructed the user should normally not have to call it manually. =item host () Returns the value used by the constructor, and passed to IO::Socket::INET, to connect to the host. =item etrn ( DOMAIN ) Request a queue run for the DOMAIN given. =item starttls ( SSLARGS ) Upgrade existing plain connection to SSL. You can use SSL arguments as documented in L, but it will usually use the right arguments already. =item auth ( USERNAME, PASSWORD ) =item auth ( SASL ) Attempt SASL authentication. Requires Authen::SASL module. The first form constructs a new Authen::SASL object using the given username and password; the second form uses the given Authen::SASL object. =item mail ( ADDRESS [, OPTIONS] ) =item send ( ADDRESS ) =item send_or_mail ( ADDRESS ) =item send_and_mail ( ADDRESS ) Send the appropriate command to the server MAIL, SEND, SOML or SAML. C
is the address of the sender. This initiates the sending of a message. The method C should be called for each address that the message is to be sent to. The C method can some additional ESMTP OPTIONS which is passed in hash like fashion, using key and value pairs. Possible options are: Size => Return => "FULL" | "HDRS" Bits => "7" | "8" | "binary" Transaction =>
Envelope => # xtext-encodes its argument ENVID => # similar to Envelope, but expects argument encoded XVERP => 1 AUTH => # encoded address according to RFC 2554 The C and C parameters are used for DSN (Delivery Status Notification). The submitter address in C option is expected to be in a format as required by RFC 2554, in an RFC2821-quoted form and xtext-encoded, or <> . =item reset () Reset the status of the server. This may be called after a message has been initiated, but before any data has been sent, to cancel the sending of the message. =item recipient ( ADDRESS [, ADDRESS, [...]] [, OPTIONS ] ) Notify the server that the current message should be sent to all of the addresses given. Each address is sent as a separate command to the server. Should the sending of any address result in a failure then the process is aborted and a I value is returned. It is up to the user to call C if they so desire. The C method can also pass additional case-sensitive OPTIONS as an anonymous hash using key and value pairs. Possible options are: Notify => ['NEVER'] or ['SUCCESS','FAILURE','DELAY'] (see below) ORcpt => SkipBad => 1 (to ignore bad addresses) If C is true the C will not return an error when a bad address is encountered and it will return an array of addresses that did succeed. $smtp->recipient($recipient1,$recipient2); # Good $smtp->recipient($recipient1,$recipient2, { SkipBad => 1 }); # Good $smtp->recipient($recipient1,$recipient2, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good @goodrecips=$smtp->recipient(@recipients, { Notify => ['FAILURE'], SkipBad => 1 }); # Good $smtp->recipient("$recipient,$recipient2"); # BAD Notify is used to request Delivery Status Notifications (DSNs), but your SMTP/ESMTP service may not respect this request depending upon its version and your site's SMTP configuration. Leaving out the Notify option usually defaults an SMTP service to its default behavior equivalent to ['FAILURE'] notifications only, but again this may be dependent upon your site's SMTP configuration. The NEVER keyword must appear by itself if used within the Notify option and "requests that a DSN not be returned to the sender under any conditions." {Notify => ['NEVER']} $smtp->recipient(@recipients, { Notify => ['NEVER'], SkipBad => 1 }); # Good You may use any combination of these three values 'SUCCESS','FAILURE','DELAY' in the anonymous array reference as defined by RFC3461 (see http://www.ietf.org/rfc/rfc3461.txt for more information. Note: quotations in this topic from same.). A Notify parameter of 'SUCCESS' or 'FAILURE' "requests that a DSN be issued on successful delivery or delivery failure, respectively." A Notify parameter of 'DELAY' "indicates the sender's willingness to receive delayed DSNs. Delayed DSNs may be issued if delivery of a message has been delayed for an unusual amount of time (as determined by the Message Transfer Agent (MTA) at which the message is delayed), but the final delivery status (whether successful or failure) cannot be determined. The absence of the DELAY keyword in a NOTIFY parameter requests that a "delayed" DSN NOT be issued under any conditions." {Notify => ['SUCCESS','FAILURE','DELAY']} $smtp->recipient(@recipients, { Notify => ['FAILURE','DELAY'], SkipBad => 1 }); # Good ORcpt is also part of the SMTP DSN extension according to RFC3461. It is used to pass along the original recipient that the mail was first sent to. The machine that generates a DSN will use this address to inform the sender, because he can't know if recipients get rewritten by mail servers. It is expected to be in a format as required by RFC3461, xtext-encoded. =item to ( ADDRESS [, ADDRESS [...]] ) =item cc ( ADDRESS [, ADDRESS [...]] ) =item bcc ( ADDRESS [, ADDRESS [...]] ) Synonyms for C. =item data ( [ DATA ] ) Initiate the sending of the data from the current message. C may be a reference to a list or a list and must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. If specified the contents of C and a termination string C<".\r\n"> is sent to the server. The result will be true if the data was accepted. If C is not specified then the result will indicate that the server wishes the data to be sent. The data must then be sent using the C and C methods described in L. =item bdat ( DATA ) =item bdatlast ( DATA ) Use the alternate DATA command "BDAT" of the data chunking service extension defined in RFC1830 for efficiently sending large MIME messages. =item expand ( ADDRESS ) Request the server to expand the given address Returns an array which contains the text read from the server. =item verify ( ADDRESS ) Verify that C
is a legitimate mailing address. Most sites usually disable this feature in their SMTP service configuration. Use "Debug => 1" option under new() to see if disabled. =item help ( [ $subject ] ) Request help text from the server. Returns the text or undef upon failure =item quit () Send the QUIT command to the remote SMTP server and close the socket connection. =item can_inet6 () Returns whether we can use IPv6. =item can_ssl () Returns whether we can use SSL. =back =head1 ADDRESSES Net::SMTP attempts to DWIM with addresses that are passed. For example an application might extract The From: line from an email and pass that to mail(). While this may work, it is not recommended. The application should really use a module like L to extract the mail address and pass that. If C is passed to the constructor, then addresses should be a valid rfc2821-quoted address, although Net::SMTP will accept the address surrounded by angle brackets. funny user@domain WRONG "funny user"@domain RIGHT, recommended <"funny user"@domain> OK =head1 SEE ALSO L, L =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. Copyright (C) 2013-2016 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut NNTP.pm000064400000100160152346665430005675 0ustar00# Net::NNTP.pm # # Copyright (C) 1995-1997 Graham Barr. All rights reserved. # Copyright (C) 2013-2016 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::NNTP; use 5.008001; use strict; use warnings; use Carp; use IO::Socket; use Net::Cmd; use Net::Config; use Time::Local; our $VERSION = "3.11"; # Code for detecting if we can use SSL my $ssl_class = eval { require IO::Socket::SSL; # first version with default CA on most platforms no warnings 'numeric'; IO::Socket::SSL->VERSION(2.007); } && 'IO::Socket::SSL'; my $nossl_warn = !$ssl_class && 'To use SSL please install IO::Socket::SSL with version>=2.007'; # Code for detecting if we can use IPv6 my $family_key = 'Domain'; my $inet6_class = eval { require IO::Socket::IP; no warnings 'numeric'; IO::Socket::IP->VERSION(0.25) || die; $family_key = 'Family'; } && 'IO::Socket::IP' || eval { require IO::Socket::INET6; no warnings 'numeric'; IO::Socket::INET6->VERSION(2.62); } && 'IO::Socket::INET6'; sub can_ssl { $ssl_class }; sub can_inet6 { $inet6_class }; our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); sub new { my $self = shift; my $type = ref($self) || $self; my ($host, %arg); if (@_ % 2) { $host = shift; %arg = @_; } else { %arg = @_; $host = delete $arg{Host}; } my $obj; $host ||= $ENV{NNTPSERVER} || $ENV{NEWSHOST}; my $hosts = defined $host ? [$host] : $NetConfig{nntp_hosts}; @{$hosts} = qw(news) unless @{$hosts}; my %connect = ( Proto => 'tcp'); if ($arg{SSL}) { # SSL from start die $nossl_warn if ! $ssl_class; $arg{Port} ||= 563; $connect{$_} = $arg{$_} for(grep { m{^SSL_} } keys %arg); } foreach my $o (qw(LocalAddr LocalPort Timeout)) { $connect{$o} = $arg{$o} if exists $arg{$o}; } $connect{$family_key} = $arg{Domain} || $arg{Family}; $connect{Timeout} = 120 unless defined $connect{Timeout}; $connect{PeerPort} = $arg{Port} || 'nntp(119)'; foreach my $h (@{$hosts}) { $connect{PeerAddr} = $h; $obj = $type->SUPER::new(%connect) or next; ${*$obj}{'net_nntp_host'} = $h; ${*$obj}{'net_nntp_arg'} = \%arg; if ($arg{SSL}) { Net::NNTP::_SSL->start_SSL($obj,%arg) or next; } last: } return unless defined $obj; $obj->autoflush(1); $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); unless ($obj->response() == CMD_OK) { $obj->close; return; } my $c = $obj->code; my @m = $obj->message; unless (exists $arg{Reader} && $arg{Reader} == 0) { # if server is INN and we have transfer rights the we are currently # talking to innd not nnrpd if ($obj->reader) { # If reader succeeds the we need to consider this code to determine postok $c = $obj->code; } else { # I want to ignore this failure, so restore the previous status. $obj->set_status($c, \@m); } } ${*$obj}{'net_nntp_post'} = $c == 200 ? 1 : 0; $obj; } sub host { my $me = shift; ${*$me}{'net_nntp_host'}; } sub debug_text { my $nntp = shift; my $inout = shift; my $text = shift; if ( (ref($nntp) and $nntp->code == 350 and $text =~ /^(\S+)/) || ($text =~ /^(authinfo\s+pass)/io)) { $text = "$1 ....\n"; } $text; } sub postok { @_ == 1 or croak 'usage: $nntp->postok()'; my $nntp = shift; ${*$nntp}{'net_nntp_post'} || 0; } sub starttls { my $self = shift; $ssl_class or die $nossl_warn; $self->_STARTTLS or return; Net::NNTP::_SSL->start_SSL($self, %{ ${*$self}{'net_nntp_arg'} }, # (ssl) args given in new @_ # more (ssl) args ) or return; return 1; } sub article { @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->article( [ MSGID ], [ FH ] )'; my $nntp = shift; my @fh; @fh = (pop) if @_ == 2 || (@_ && (ref($_[0]) || ref(\$_[0]) eq 'GLOB')); $nntp->_ARTICLE(@_) ? $nntp->read_until_dot(@fh) : undef; } sub articlefh { @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->articlefh( [ MSGID ] )'; my $nntp = shift; return unless $nntp->_ARTICLE(@_); return $nntp->tied_fh; } sub authinfo { @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; my ($nntp, $user, $pass) = @_; $nntp->_AUTHINFO("USER", $user) == CMD_MORE && $nntp->_AUTHINFO("PASS", $pass) == CMD_OK; } sub authinfo_simple { @_ == 3 or croak 'usage: $nntp->authinfo( USER, PASS )'; my ($nntp, $user, $pass) = @_; $nntp->_AUTHINFO('SIMPLE') == CMD_MORE && $nntp->command($user, $pass)->response == CMD_OK; } sub body { @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->body( [ MSGID ], [ FH ] )'; my $nntp = shift; my @fh; @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); $nntp->_BODY(@_) ? $nntp->read_until_dot(@fh) : undef; } sub bodyfh { @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->bodyfh( [ MSGID ] )'; my $nntp = shift; return unless $nntp->_BODY(@_); return $nntp->tied_fh; } sub head { @_ >= 1 && @_ <= 3 or croak 'usage: $nntp->head( [ MSGID ], [ FH ] )'; my $nntp = shift; my @fh; @fh = (pop) if @_ == 2 || (@_ && ref($_[0]) || ref(\$_[0]) eq 'GLOB'); $nntp->_HEAD(@_) ? $nntp->read_until_dot(@fh) : undef; } sub headfh { @_ >= 1 && @_ <= 2 or croak 'usage: $nntp->headfh( [ MSGID ] )'; my $nntp = shift; return unless $nntp->_HEAD(@_); return $nntp->tied_fh; } sub nntpstat { @_ == 1 || @_ == 2 or croak 'usage: $nntp->nntpstat( [ MSGID ] )'; my $nntp = shift; $nntp->_STAT(@_) && $nntp->message =~ /(<[^>]+>)/o ? $1 : undef; } sub group { @_ == 1 || @_ == 2 or croak 'usage: $nntp->group( [ GROUP ] )'; my $nntp = shift; my $grp = ${*$nntp}{'net_nntp_group'}; return $grp unless (@_ || wantarray); my $newgrp = shift; $newgrp = (defined($grp) and length($grp)) ? $grp : "" unless defined($newgrp) and length($newgrp); return unless $nntp->_GROUP($newgrp) and $nntp->message =~ /(\d+)\s+(\d+)\s+(\d+)\s+(\S+)/; my ($count, $first, $last, $group) = ($1, $2, $3, $4); # group may be replied as '(current group)' $group = ${*$nntp}{'net_nntp_group'} if $group =~ /\(/; ${*$nntp}{'net_nntp_group'} = $group; wantarray ? ($count, $first, $last, $group) : $group; } sub help { @_ == 1 or croak 'usage: $nntp->help()'; my $nntp = shift; $nntp->_HELP ? $nntp->read_until_dot : undef; } sub ihave { @_ >= 2 or croak 'usage: $nntp->ihave( MESSAGE-ID [, MESSAGE ])'; my $nntp = shift; my $mid = shift; $nntp->_IHAVE($mid) && $nntp->datasend(@_) ? @_ == 0 || $nntp->dataend : undef; } sub last { @_ == 1 or croak 'usage: $nntp->last()'; my $nntp = shift; $nntp->_LAST && $nntp->message =~ /(<[^>]+>)/o ? $1 : undef; } sub list { @_ == 1 or croak 'usage: $nntp->list()'; my $nntp = shift; $nntp->_LIST ? $nntp->_grouplist : undef; } sub newgroups { @_ >= 2 or croak 'usage: $nntp->newgroups( SINCE [, DISTRIBUTIONS ])'; my $nntp = shift; my $time = _timestr(shift); my $dist = shift || ""; $dist = join(",", @{$dist}) if ref($dist); $nntp->_NEWGROUPS($time, $dist) ? $nntp->_grouplist : undef; } sub newnews { @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->newnews( SINCE [, GROUPS [, DISTRIBUTIONS ]])'; my $nntp = shift; my $time = _timestr(shift); my $grp = @_ ? shift: $nntp->group; my $dist = shift || ""; $grp ||= "*"; $grp = join(",", @{$grp}) if ref($grp); $dist = join(",", @{$dist}) if ref($dist); $nntp->_NEWNEWS($grp, $time, $dist) ? $nntp->_articlelist : undef; } sub next { @_ == 1 or croak 'usage: $nntp->next()'; my $nntp = shift; $nntp->_NEXT && $nntp->message =~ /(<[^>]+>)/o ? $1 : undef; } sub post { @_ >= 1 or croak 'usage: $nntp->post( [ MESSAGE ] )'; my $nntp = shift; $nntp->_POST() && $nntp->datasend(@_) ? @_ == 0 || $nntp->dataend : undef; } sub postfh { my $nntp = shift; return unless $nntp->_POST(); return $nntp->tied_fh; } sub quit { @_ == 1 or croak 'usage: $nntp->quit()'; my $nntp = shift; $nntp->_QUIT; $nntp->close; } sub slave { @_ == 1 or croak 'usage: $nntp->slave()'; my $nntp = shift; $nntp->_SLAVE; } ## ## The following methods are not implemented by all servers ## sub active { @_ == 1 || @_ == 2 or croak 'usage: $nntp->active( [ PATTERN ] )'; my $nntp = shift; $nntp->_LIST('ACTIVE', @_) ? $nntp->_grouplist : undef; } sub active_times { @_ == 1 or croak 'usage: $nntp->active_times()'; my $nntp = shift; $nntp->_LIST('ACTIVE.TIMES') ? $nntp->_grouplist : undef; } sub distributions { @_ == 1 or croak 'usage: $nntp->distributions()'; my $nntp = shift; $nntp->_LIST('DISTRIBUTIONS') ? $nntp->_description : undef; } sub distribution_patterns { @_ == 1 or croak 'usage: $nntp->distributions()'; my $nntp = shift; my $arr; local $_; ## no critic (ControlStructures::ProhibitMutatingListFunctions) $nntp->_LIST('DISTRIB.PATS') && ($arr = $nntp->read_until_dot) ? [grep { /^\d/ && (chomp, $_ = [split /:/]) } @$arr] : undef; } sub newsgroups { @_ == 1 || @_ == 2 or croak 'usage: $nntp->newsgroups( [ PATTERN ] )'; my $nntp = shift; $nntp->_LIST('NEWSGROUPS', @_) ? $nntp->_description : undef; } sub overview_fmt { @_ == 1 or croak 'usage: $nntp->overview_fmt()'; my $nntp = shift; $nntp->_LIST('OVERVIEW.FMT') ? $nntp->_articlelist : undef; } sub subscriptions { @_ == 1 or croak 'usage: $nntp->subscriptions()'; my $nntp = shift; $nntp->_LIST('SUBSCRIPTIONS') ? $nntp->_articlelist : undef; } sub listgroup { @_ == 1 || @_ == 2 or croak 'usage: $nntp->listgroup( [ GROUP ] )'; my $nntp = shift; $nntp->_LISTGROUP(@_) ? $nntp->_articlelist : undef; } sub reader { @_ == 1 or croak 'usage: $nntp->reader()'; my $nntp = shift; $nntp->_MODE('READER'); } sub xgtitle { @_ == 1 || @_ == 2 or croak 'usage: $nntp->xgtitle( [ PATTERN ] )'; my $nntp = shift; $nntp->_XGTITLE(@_) ? $nntp->_description : undef; } sub xhdr { @_ >= 2 && @_ <= 4 or croak 'usage: $nntp->xhdr( HEADER, [ MESSAGE-SPEC ] )'; my $nntp = shift; my $hdr = shift; my $arg = _msg_arg(@_); $nntp->_XHDR($hdr, $arg) ? $nntp->_description : undef; } sub xover { @_ == 2 || @_ == 3 or croak 'usage: $nntp->xover( MESSAGE-SPEC )'; my $nntp = shift; my $arg = _msg_arg(@_); $nntp->_XOVER($arg) ? $nntp->_fieldlist : undef; } sub xpat { @_ == 4 || @_ == 5 or croak '$nntp->xpat( HEADER, PATTERN, MESSAGE-SPEC )'; my $nntp = shift; my $hdr = shift; my $pat = shift; my $arg = _msg_arg(@_); $pat = join(" ", @$pat) if ref($pat); $nntp->_XPAT($hdr, $arg, $pat) ? $nntp->_description : undef; } sub xpath { @_ == 2 or croak 'usage: $nntp->xpath( MESSAGE-ID )'; my ($nntp, $mid) = @_; return unless $nntp->_XPATH($mid); my $m; ($m = $nntp->message) =~ s/^\d+\s+//o; my @p = split /\s+/, $m; wantarray ? @p : $p[0]; } sub xrover { @_ == 2 || @_ == 3 or croak 'usage: $nntp->xrover( MESSAGE-SPEC )'; my $nntp = shift; my $arg = _msg_arg(@_); $nntp->_XROVER($arg) ? $nntp->_description : undef; } sub date { @_ == 1 or croak 'usage: $nntp->date()'; my $nntp = shift; $nntp->_DATE && $nntp->message =~ /(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)/ ? timegm($6, $5, $4, $3, $2 - 1, $1 - 1900) : undef; } ## ## Private subroutines ## sub _msg_arg { my $spec = shift; my $arg = ""; if (@_) { carp "Depriciated passing of two message numbers, " . "pass a reference" if $^W; $spec = [$spec, $_[0]]; } if (defined $spec) { if (ref($spec)) { $arg = $spec->[0]; if (defined $spec->[1]) { $arg .= "-" if $spec->[1] != $spec->[0]; $arg .= $spec->[1] if $spec->[1] > $spec->[0]; } } else { $arg = $spec; } } $arg; } sub _timestr { my $time = shift; my @g = reverse((gmtime($time))[0 .. 5]); $g[1] += 1; $g[0] %= 100; sprintf "%02d%02d%02d %02d%02d%02d GMT", @g; } sub _grouplist { my $nntp = shift; my $arr = $nntp->read_until_dot or return; my $hash = {}; foreach my $ln (@$arr) { my @a = split(/[\s\n]+/, $ln); $hash->{$a[0]} = [@a[1, 2, 3]]; } $hash; } sub _fieldlist { my $nntp = shift; my $arr = $nntp->read_until_dot or return; my $hash = {}; foreach my $ln (@$arr) { my @a = split(/[\t\n]/, $ln); my $m = shift @a; $hash->{$m} = [@a]; } $hash; } sub _articlelist { my $nntp = shift; my $arr = $nntp->read_until_dot; chomp(@$arr) if $arr; $arr; } sub _description { my $nntp = shift; my $arr = $nntp->read_until_dot or return; my $hash = {}; foreach my $ln (@$arr) { chomp($ln); $hash->{$1} = $ln if $ln =~ s/^\s*(\S+)\s*//o; } $hash; } ## ## The commands ## sub _ARTICLE { shift->command('ARTICLE', @_)->response == CMD_OK } sub _AUTHINFO { shift->command('AUTHINFO', @_)->response } sub _BODY { shift->command('BODY', @_)->response == CMD_OK } sub _DATE { shift->command('DATE')->response == CMD_INFO } sub _GROUP { shift->command('GROUP', @_)->response == CMD_OK } sub _HEAD { shift->command('HEAD', @_)->response == CMD_OK } sub _HELP { shift->command('HELP', @_)->response == CMD_INFO } sub _IHAVE { shift->command('IHAVE', @_)->response == CMD_MORE } sub _LAST { shift->command('LAST')->response == CMD_OK } sub _LIST { shift->command('LIST', @_)->response == CMD_OK } sub _LISTGROUP { shift->command('LISTGROUP', @_)->response == CMD_OK } sub _NEWGROUPS { shift->command('NEWGROUPS', @_)->response == CMD_OK } sub _NEWNEWS { shift->command('NEWNEWS', @_)->response == CMD_OK } sub _NEXT { shift->command('NEXT')->response == CMD_OK } sub _POST { shift->command('POST', @_)->response == CMD_MORE } sub _QUIT { shift->command('QUIT', @_)->response == CMD_OK } sub _SLAVE { shift->command('SLAVE', @_)->response == CMD_OK } sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_MORE } sub _STAT { shift->command('STAT', @_)->response == CMD_OK } sub _MODE { shift->command('MODE', @_)->response == CMD_OK } sub _XGTITLE { shift->command('XGTITLE', @_)->response == CMD_OK } sub _XHDR { shift->command('XHDR', @_)->response == CMD_OK } sub _XPAT { shift->command('XPAT', @_)->response == CMD_OK } sub _XPATH { shift->command('XPATH', @_)->response == CMD_OK } sub _XOVER { shift->command('XOVER', @_)->response == CMD_OK } sub _XROVER { shift->command('XROVER', @_)->response == CMD_OK } sub _XTHREAD { shift->unsupported } sub _XSEARCH { shift->unsupported } sub _XINDEX { shift->unsupported } ## ## IO/perl methods ## sub DESTROY { my $nntp = shift; defined(fileno($nntp)) && $nntp->quit; } { package Net::NNTP::_SSL; our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::NNTP' ); sub starttls { die "NNTP connection is already in SSL mode" } sub start_SSL { my ($class,$nntp,%arg) = @_; delete @arg{ grep { !m{^SSL_} } keys %arg }; ( $arg{SSL_verifycn_name} ||= $nntp->host ) =~s{(?can_client_sni; my $ok = $class->SUPER::start_SSL($nntp, SSL_verifycn_scheme => 'nntp', %arg ); $@ = $ssl_class->errstr if !$ok; return $ok; } } 1; __END__ =head1 NAME Net::NNTP - NNTP Client class =head1 SYNOPSIS use Net::NNTP; $nntp = Net::NNTP->new("some.host.name"); $nntp->quit; # start with SSL, e.g. nntps $nntp = Net::NNTP->new("some.host.name", SSL => 1); # start with plain and upgrade to SSL $nntp = Net::NNTP->new("some.host.name"); $nntp->starttls; =head1 DESCRIPTION C is a class implementing a simple NNTP client in Perl as described in RFC977 and RFC4642. With L installed it also provides support for implicit and explicit TLS encryption, i.e. NNTPS or NNTP+STARTTLS. The Net::NNTP class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. =head1 CONSTRUCTOR =over 4 =item new ( [ HOST ] [, OPTIONS ]) This is the constructor for a new Net::NNTP object. C is the name of the remote host to which a NNTP connection is required. If not given then it may be passed as the C option described below. If no host is passed then two environment variables are checked, first C then C, then C is checked, and if a host is not found then C is used. C are passed in a hash like fashion, using key and value pairs. Possible options are: B - NNTP host to connect to. It may be a single scalar, as defined for the C option in L, or a reference to an array with hosts to try in turn. The L method will return the value which was used to connect to the host. B - port to connect to. Default - 119 for plain NNTP and 563 for immediate SSL (nntps). B - If the connection should be done from start with SSL, contrary to later upgrade with C. You can use SSL arguments as documented in L, but it will usually use the right arguments already. B - Maximum time, in seconds, to wait for a response from the NNTP server, a value of zero will cause all IO operations to block. (default: 120) B - Enable the printing of debugging information to STDERR B - If the remote server is INN then initially the connection will be to innd, by default C will issue a C command so that the remote server becomes nnrpd. If the C option is given with a value of zero, then this command will not be sent and the connection will be left talking to innd. B and B - These parameters are passed directly to IO::Socket to allow binding the socket to a specific local address and port. B - This parameter is passed directly to IO::Socket and makes it possible to enforce IPv4 connections even if L is used as super class. Alternatively B can be used. =back =head1 METHODS Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method states that it returns a value, failure will be returned as I or an empty list. C inherits from C so methods defined in C may be used to send commands to the remote NNTP server in addition to the methods documented here. =over 4 =item host () Returns the value used by the constructor, and passed to IO::Socket::INET, to connect to the host. =item starttls () Upgrade existing plain connection to SSL. Any arguments necessary for SSL must be given in C already. =item article ( [ MSGID|MSGNUM ], [FH] ) Retrieve the header, a blank line, then the body (text) of the specified article. If C is specified then it is expected to be a valid filehandle and the result will be printed to it, on success a true value will be returned. If C is not specified then the return value, on success, will be a reference to an array containing the article requested, each entry in the array will contain one line of the article. If no arguments are passed then the current article in the currently selected newsgroup is fetched. C is a numeric id of an article in the current newsgroup, and will change the current article pointer. C is the message id of an article as shown in that article's header. It is anticipated that the client will obtain the C from a list provided by the C command, from references contained within another article, or from the message-id provided in the response to some other commands. If there is an error then C will be returned. =item body ( [ MSGID|MSGNUM ], [FH] ) Like C
but only fetches the body of the article. =item head ( [ MSGID|MSGNUM ], [FH] ) Like C
but only fetches the headers for the article. =item articlefh ( [ MSGID|MSGNUM ] ) =item bodyfh ( [ MSGID|MSGNUM ] ) =item headfh ( [ MSGID|MSGNUM ] ) These are similar to article(), body() and head(), but rather than returning the requested data directly, they return a tied filehandle from which to read the article. =item nntpstat ( [ MSGID|MSGNUM ] ) The C command is similar to the C
command except that no text is returned. When selecting by message number within a group, the C command serves to set the "current article pointer" without sending text. Using the C command to select by message-id is valid but of questionable value, since a selection by message-id does B alter the "current article pointer". Returns the message-id of the "current article". =item group ( [ GROUP ] ) Set and/or get the current group. If C is not given then information is returned on the current group. In a scalar context it returns the group name. In an array context the return value is a list containing, the number of articles in the group, the number of the first article, the number of the last article and the group name. =item help ( ) Request help text (a short summary of commands that are understood by this implementation) from the server. Returns the text or undef upon failure. =item ihave ( MSGID [, MESSAGE ]) The C command informs the server that the client has an article whose id is C. If the server desires a copy of that article and C has been given then it will be sent. Returns I if the server desires the article and C was successfully sent, if specified. If C is not specified then the message must be sent using the C and C methods from L C can be either an array of lines or a reference to an array and must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. =item last () Set the "current article pointer" to the previous article in the current newsgroup. Returns the message-id of the article. =item date () Returns the date on the remote server. This date will be in a UNIX time format (seconds since 1970) =item postok () C will return I if the servers initial response indicated that it will allow posting. =item authinfo ( USER, PASS ) Authenticates to the server (using the original AUTHINFO USER / AUTHINFO PASS form, defined in RFC2980) using the supplied username and password. Please note that the password is sent in clear text to the server. This command should not be used with valuable passwords unless the connection to the server is somehow protected. =item authinfo_simple ( USER, PASS ) Authenticates to the server (using the proposed NNTP V2 AUTHINFO SIMPLE form, defined and deprecated in RFC2980) using the supplied username and password. As with L the password is sent in clear text. =item list () Obtain information about all the active newsgroups. The results is a reference to a hash where the key is a group name and each value is a reference to an array. The elements in this array are:- the last article number in the group, the first article number in the group and any information flags about the group. =item newgroups ( SINCE [, DISTRIBUTIONS ]) C is a time value and C is either a distribution pattern or a reference to a list of distribution patterns. The result is the same as C, but the groups return will be limited to those created after C and, if specified, in one of the distribution areas in C. =item newnews ( SINCE [, GROUPS [, DISTRIBUTIONS ]]) C is a time value. C is either a group pattern or a reference to a list of group patterns. C is either a distribution pattern or a reference to a list of distribution patterns. Returns a reference to a list which contains the message-ids of all news posted after C, that are in a groups which matched C and a distribution which matches C. =item next () Set the "current article pointer" to the next article in the current newsgroup. Returns the message-id of the article. =item post ( [ MESSAGE ] ) Post a new article to the news server. If C is specified and posting is allowed then the message will be sent. If C is not specified then the message must be sent using the C and C methods from L C can be either an array of lines or a reference to an array and must be encoded by the caller to octets of whatever encoding is required, e.g. by using the Encode module's C function. The message, either sent via C or as the C parameter, must be in the format as described by RFC822 and must contain From:, Newsgroups: and Subject: headers. =item postfh () Post a new article to the news server using a tied filehandle. If posting is allowed, this method will return a tied filehandle that you can print() the contents of the article to be posted. You must explicitly close() the filehandle when you are finished posting the article, and the return value from the close() call will indicate whether the message was successfully posted. =item slave () Tell the remote server that I am not a user client, but probably another news server. =item quit () Quit the remote server and close the socket connection. =item can_inet6 () Returns whether we can use IPv6. =item can_ssl () Returns whether we can use SSL. =back =head2 Extension methods These methods use commands that are not part of the RFC977 documentation. Some servers may not support all of them. =over 4 =item newsgroups ( [ PATTERN ] ) Returns a reference to a hash where the keys are all the group names which match C, or all of the groups if no pattern is specified, and each value contains the description text for the group. =item distributions () Returns a reference to a hash where the keys are all the possible distribution names and the values are the distribution descriptions. =item distribution_patterns () Returns a reference to an array where each element, itself an array reference, consists of the three fields of a line of the distrib.pats list maintained by some NNTP servers, namely: a weight, a wildmat and a value which the client may use to construct a Distribution header. =item subscriptions () Returns a reference to a list which contains a list of groups which are recommended for a new user to subscribe to. =item overview_fmt () Returns a reference to an array which contain the names of the fields returned by C. =item active_times () Returns a reference to a hash where the keys are the group names and each value is a reference to an array containing the time the groups was created and an identifier, possibly an Email address, of the creator. =item active ( [ PATTERN ] ) Similar to C but only active groups that match the pattern are returned. C can be a group pattern. =item xgtitle ( PATTERN ) Returns a reference to a hash where the keys are all the group names which match C and each value is the description text for the group. =item xhdr ( HEADER, MESSAGE-SPEC ) Obtain the header field C
for all the messages specified. The return value will be a reference to a hash where the keys are the message numbers and each value contains the text of the requested header for that message. =item xover ( MESSAGE-SPEC ) The return value will be a reference to a hash where the keys are the message numbers and each value contains a reference to an array which contains the overview fields for that message. The names of the fields can be obtained by calling C. =item xpath ( MESSAGE-ID ) Returns the path name to the file on the server which contains the specified message. =item xpat ( HEADER, PATTERN, MESSAGE-SPEC) The result is the same as C except the is will be restricted to headers where the text of the header matches C =item xrover () The XROVER command returns reference information for the article(s) specified. Returns a reference to a HASH where the keys are the message numbers and the values are the References: lines from the articles =item listgroup ( [ GROUP ] ) Returns a reference to a list of all the active messages in C, or the current group if C is not specified. =item reader () Tell the server that you are a reader and not another server. This is required by some servers. For example if you are connecting to an INN server and you have transfer permission your connection will be connected to the transfer daemon, not the NNTP daemon. Issuing this command will cause the transfer daemon to hand over control to the NNTP daemon. Some servers do not understand this command, but issuing it and ignoring the response is harmless. =back =head1 UNSUPPORTED The following NNTP command are unsupported by the package, and there are no plans to do so. AUTHINFO GENERIC XTHREAD XSEARCH XINDEX =head1 DEFINITIONS =over 4 =item MESSAGE-SPEC C is either a single message-id, a single message number, or a reference to a list of two message numbers. If C is a reference to a list of two message numbers and the second number in a range is less than or equal to the first then the range represents all messages in the group after the first message number. B For compatibility reasons only with earlier versions of Net::NNTP a message spec can be passed as a list of two numbers, this is deprecated and a reference to the list should now be passed =item PATTERN The C protocol uses the C format for patterns. The WILDMAT format was first developed by Rich Salz based on the format used in the UNIX "find" command to articulate file names. It was developed to provide a uniform mechanism for matching patterns in the same manner that the UNIX shell matches filenames. Patterns are implicitly anchored at the beginning and end of each string when testing for a match. There are five pattern matching operations other than a strict one-to-one match between the pattern and the source to be checked for a match. The first is an asterisk C<*> to match any sequence of zero or more characters. The second is a question mark C to match any single character. The third specifies a specific set of characters. The set is specified as a list of characters, or as a range of characters where the beginning and end of the range are separated by a minus (or dash) character, or as any combination of lists and ranges. The dash can also be included in the set as a character it if is the beginning or end of the set. This set is enclosed in square brackets. The close square bracket C<]> may be used in a set if it is the first character in the set. The fourth operation is the same as the logical not of the third operation and is specified the same way as the third with the addition of a caret character C<^> at the beginning of the test string just inside the open square bracket. The final operation uses the backslash character to invalidate the special meaning of an open square bracket C<[>, the asterisk, backslash or the question mark. Two backslashes in sequence will result in the evaluation of the backslash as a character with no special meaning. =over 4 =item Examples =item C<[^]-]> matches any single character other than a close square bracket or a minus sign/dash. =item C<*bdc> matches any string that ends with the string "bdc" including the string "bdc" (without quotes). =item C<[0-9a-zA-Z]> matches any single printable alphanumeric ASCII character. =item C matches any four character string which begins with a and ends with d. =back =back =head1 SEE ALSO L, L =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-1997 Graham Barr. All rights reserved. Copyright (C) 2013-2016 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut POP3.pm000064400000051431152346665430005645 0ustar00# Net::POP3.pm # # Copyright (C) 1995-2004 Graham Barr. All rights reserved. # Copyright (C) 2013-2016 Steve Hay. All rights reserved. # This module is free software; you can redistribute it and/or modify it under # the same terms as Perl itself, i.e. under the terms of either the GNU General # Public License or the Artistic License, as specified in the F file. package Net::POP3; use 5.008001; use strict; use warnings; use Carp; use IO::Socket; use Net::Cmd; use Net::Config; our $VERSION = "3.11"; # Code for detecting if we can use SSL my $ssl_class = eval { require IO::Socket::SSL; # first version with default CA on most platforms no warnings 'numeric'; IO::Socket::SSL->VERSION(2.007); } && 'IO::Socket::SSL'; my $nossl_warn = !$ssl_class && 'To use SSL please install IO::Socket::SSL with version>=2.007'; # Code for detecting if we can use IPv6 my $family_key = 'Domain'; my $inet6_class = eval { require IO::Socket::IP; no warnings 'numeric'; IO::Socket::IP->VERSION(0.25) || die; $family_key = 'Family'; } && 'IO::Socket::IP' || eval { require IO::Socket::INET6; no warnings 'numeric'; IO::Socket::INET6->VERSION(2.62); } && 'IO::Socket::INET6'; sub can_ssl { $ssl_class }; sub can_inet6 { $inet6_class }; our @ISA = ('Net::Cmd', $inet6_class || 'IO::Socket::INET'); sub new { my $self = shift; my $type = ref($self) || $self; my ($host, %arg); if (@_ % 2) { $host = shift; %arg = @_; } else { %arg = @_; $host = delete $arg{Host}; } my $hosts = defined $host ? [$host] : $NetConfig{pop3_hosts}; my $obj; if ($arg{SSL}) { # SSL from start die $nossl_warn if !$ssl_class; $arg{Port} ||= 995; } $arg{Timeout} = 120 if ! defined $arg{Timeout}; foreach my $h (@{$hosts}) { $obj = $type->SUPER::new( PeerAddr => ($host = $h), PeerPort => $arg{Port} || 'pop3(110)', Proto => 'tcp', $family_key => $arg{Domain} || $arg{Family}, LocalAddr => $arg{LocalAddr}, LocalPort => exists($arg{ResvPort}) ? $arg{ResvPort} : $arg{LocalPort}, Timeout => $arg{Timeout}, ) and last; } return unless defined $obj; ${*$obj}{'net_pop3_arg'} = \%arg; ${*$obj}{'net_pop3_host'} = $host; if ($arg{SSL}) { Net::POP3::_SSL->start_SSL($obj,%arg) or return; } $obj->autoflush(1); $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); unless ($obj->response() == CMD_OK) { $obj->close(); return; } ${*$obj}{'net_pop3_banner'} = $obj->message; $obj; } sub host { my $me = shift; ${*$me}{'net_pop3_host'}; } ## ## We don't want people sending me their passwords when they report problems ## now do we :-) ## sub debug_text { $_[2] =~ /^(pass|rpop)/i ? "$1 ....\n" : $_[2]; } sub login { @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->login( USER, PASS )'; my ($me, $user, $pass) = @_; if (@_ <= 2) { ($user, $pass) = $me->_lookup_credentials($user); } $me->user($user) and $me->pass($pass); } sub starttls { my $self = shift; $ssl_class or die $nossl_warn; $self->_STLS or return; Net::POP3::_SSL->start_SSL($self, %{ ${*$self}{'net_pop3_arg'} }, # (ssl) args given in new @_ # more (ssl) args ) or return; return 1; } sub apop { @_ >= 1 && @_ <= 3 or croak 'usage: $pop3->apop( USER, PASS )'; my ($me, $user, $pass) = @_; my $banner; my $md; if (eval { local $SIG{__DIE__}; require Digest::MD5 }) { $md = Digest::MD5->new(); } elsif (eval { local $SIG{__DIE__}; require MD5 }) { $md = MD5->new(); } else { carp "You need to install Digest::MD5 or MD5 to use the APOP command"; return; } return unless ($banner = (${*$me}{'net_pop3_banner'} =~ /(<.*>)/)[0]); if (@_ <= 2) { ($user, $pass) = $me->_lookup_credentials($user); } $md->add($banner, $pass); return unless ($me->_APOP($user, $md->hexdigest)); $me->_get_mailbox_count(); } sub user { @_ == 2 or croak 'usage: $pop3->user( USER )'; $_[0]->_USER($_[1]) ? 1 : undef; } sub pass { @_ == 2 or croak 'usage: $pop3->pass( PASS )'; my ($me, $pass) = @_; return unless ($me->_PASS($pass)); $me->_get_mailbox_count(); } sub reset { @_ == 1 or croak 'usage: $obj->reset()'; my $me = shift; return 0 unless ($me->_RSET); if (defined ${*$me}{'net_pop3_mail'}) { local $_; foreach (@{${*$me}{'net_pop3_mail'}}) { delete $_->{'net_pop3_deleted'}; } } } sub last { @_ == 1 or croak 'usage: $obj->last()'; return unless $_[0]->_LAST && $_[0]->message =~ /(\d+)/; return $1; } sub top { @_ == 2 || @_ == 3 or croak 'usage: $pop3->top( MSGNUM [, NUMLINES ])'; my $me = shift; return unless $me->_TOP($_[0], $_[1] || 0); $me->read_until_dot; } sub popstat { @_ == 1 or croak 'usage: $pop3->popstat()'; my $me = shift; return () unless $me->_STAT && $me->message =~ /(\d+)\D+(\d+)/; ($1 || 0, $2 || 0); } sub list { @_ == 1 || @_ == 2 or croak 'usage: $pop3->list( [ MSGNUM ] )'; my $me = shift; return unless $me->_LIST(@_); if (@_) { $me->message =~ /\d+\D+(\d+)/; return $1 || undef; } my $info = $me->read_until_dot or return; my %hash = map { (/(\d+)\D+(\d+)/) } @$info; return \%hash; } sub get { @_ == 2 or @_ == 3 or croak 'usage: $pop3->get( MSGNUM [, FH ])'; my $me = shift; return unless $me->_RETR(shift); $me->read_until_dot(@_); } sub getfh { @_ == 2 or croak 'usage: $pop3->getfh( MSGNUM )'; my $me = shift; return unless $me->_RETR(shift); return $me->tied_fh; } sub delete { @_ == 2 or croak 'usage: $pop3->delete( MSGNUM )'; my $me = shift; return 0 unless $me->_DELE(@_); ${*$me}{'net_pop3_deleted'} = 1; } sub uidl { @_ == 1 || @_ == 2 or croak 'usage: $pop3->uidl( [ MSGNUM ] )'; my $me = shift; my $uidl; $me->_UIDL(@_) or return; if (@_) { $uidl = ($me->message =~ /\d+\s+([\041-\176]+)/)[0]; } else { my $ref = $me->read_until_dot or return; $uidl = {}; foreach my $ln (@$ref) { my ($msg, $uid) = $ln =~ /^\s*(\d+)\s+([\041-\176]+)/; $uidl->{$msg} = $uid; } } return $uidl; } sub ping { @_ == 2 or croak 'usage: $pop3->ping( USER )'; my $me = shift; return () unless $me->_PING(@_) && $me->message =~ /(\d+)\D+(\d+)/; ($1 || 0, $2 || 0); } sub _lookup_credentials { my ($me, $user) = @_; require Net::Netrc; $user ||= eval { local $SIG{__DIE__}; (getpwuid($>))[0] } || $ENV{NAME} || $ENV{USER} || $ENV{LOGNAME}; my $m = Net::Netrc->lookup(${*$me}{'net_pop3_host'}, $user); $m ||= Net::Netrc->lookup(${*$me}{'net_pop3_host'}); my $pass = $m ? $m->password || "" : ""; ($user, $pass); } sub _get_mailbox_count { my ($me) = @_; my $ret = ${*$me}{'net_pop3_count'} = ($me->message =~ /(\d+)\s+message/io) ? $1 : ($me->popstat)[0]; $ret ? $ret : "0E0"; } sub _STAT { shift->command('STAT' )->response() == CMD_OK } sub _LIST { shift->command('LIST', @_)->response() == CMD_OK } sub _RETR { shift->command('RETR', $_[0])->response() == CMD_OK } sub _DELE { shift->command('DELE', $_[0])->response() == CMD_OK } sub _NOOP { shift->command('NOOP' )->response() == CMD_OK } sub _RSET { shift->command('RSET' )->response() == CMD_OK } sub _QUIT { shift->command('QUIT' )->response() == CMD_OK } sub _TOP { shift->command( 'TOP', @_)->response() == CMD_OK } sub _UIDL { shift->command('UIDL', @_)->response() == CMD_OK } sub _USER { shift->command('USER', $_[0])->response() == CMD_OK } sub _PASS { shift->command('PASS', $_[0])->response() == CMD_OK } sub _APOP { shift->command('APOP', @_)->response() == CMD_OK } sub _PING { shift->command('PING', $_[0])->response() == CMD_OK } sub _RPOP { shift->command('RPOP', $_[0])->response() == CMD_OK } sub _LAST { shift->command('LAST' )->response() == CMD_OK } sub _CAPA { shift->command('CAPA' )->response() == CMD_OK } sub _STLS { shift->command("STLS", )->response() == CMD_OK } sub quit { my $me = shift; $me->_QUIT; $me->close; } sub DESTROY { my $me = shift; if (defined fileno($me) and ${*$me}{'net_pop3_deleted'}) { $me->reset; $me->quit; } } ## ## POP3 has weird responses, so we emulate them to look the same :-) ## sub response { my $cmd = shift; my $str = $cmd->getline() or return; my $code = "500"; $cmd->debug_print(0, $str) if ($cmd->debug); if ($str =~ s/^\+OK\s*//io) { $code = "200"; } elsif ($str =~ s/^\+\s*//io) { $code = "300"; } else { $str =~ s/^-ERR\s*//io; } ${*$cmd}{'net_cmd_resp'} = [$str]; ${*$cmd}{'net_cmd_code'} = $code; substr($code, 0, 1); } sub capa { my $this = shift; my ($capa, %capabilities); # Fake a capability here $capabilities{APOP} = '' if ($this->banner() =~ /<.*>/); if ($this->_CAPA()) { $capabilities{CAPA} = 1; $capa = $this->read_until_dot(); %capabilities = (%capabilities, map {/^\s*(\S+)\s*(.*)/} @$capa); } else { # Check AUTH for SASL capabilities if ($this->command('AUTH')->response() == CMD_OK) { my $mechanism = $this->read_until_dot(); $capabilities{SASL} = join " ", map {m/([A-Z0-9_-]+)/} @{$mechanism}; } } return ${*$this}{'net_pop3e_capabilities'} = \%capabilities; } sub capabilities { my $this = shift; ${*$this}{'net_pop3e_capabilities'} || $this->capa; } sub auth { my ($self, $username, $password) = @_; eval { require MIME::Base64; require Authen::SASL; } or $self->set_status(500, ["Need MIME::Base64 and Authen::SASL todo auth"]), return 0; my $capa = $self->capa; my $mechanisms = $capa->{SASL} || 'CRAM-MD5'; my $sasl; if (ref($username) and UNIVERSAL::isa($username, 'Authen::SASL')) { $sasl = $username; my $user_mech = $sasl->mechanism || ''; my @user_mech = split(/\s+/, $user_mech); my %user_mech; @user_mech{@user_mech} = (); my @server_mech = split(/\s+/, $mechanisms); my @mech = @user_mech ? grep { exists $user_mech{$_} } @server_mech : @server_mech; unless (@mech) { $self->set_status( 500, [ 'Client SASL mechanisms (', join(', ', @user_mech), ') do not match the SASL mechnism the server announces (', join(', ', @server_mech), ')', ] ); return 0; } $sasl->mechanism(join(" ", @mech)); } else { die "auth(username, password)" if not length $username; $sasl = Authen::SASL->new( mechanism => $mechanisms, callback => { user => $username, pass => $password, authname => $username, } ); } # We should probably allow the user to pass the host, but I don't # currently know and SASL mechanisms that are used by smtp that need it my ($hostname) = split /:/, ${*$self}{'net_pop3_host'}; my $client = eval { $sasl->client_new('pop', $hostname, 0) }; unless ($client) { my $mech = $sasl->mechanism; $self->set_status( 500, [ " Authen::SASL failure: $@", '(please check if your local Authen::SASL installation', "supports mechanism '$mech'" ] ); return 0; } my ($token) = $client->client_start or do { my $mech = $client->mechanism; $self->set_status( 500, [ ' Authen::SASL failure: $client->client_start ', "mechanism '$mech' hostname #$hostname#", $client->error ] ); return 0; }; # We don't support sasl mechanisms that encrypt the socket traffic. # todo that we would really need to change the ISA hierarchy # so we don't inherit from IO::Socket, but instead hold it in an attribute my @cmd = ("AUTH", $client->mechanism); my $code; push @cmd, MIME::Base64::encode_base64($token, '') if defined $token and length $token; while (($code = $self->command(@cmd)->response()) == CMD_MORE) { my ($token) = $client->client_step(MIME::Base64::decode_base64(($self->message)[0])) or do { $self->set_status( 500, [ ' Authen::SASL failure: $client->client_step ', "mechanism '", $client->mechanism, " hostname #$hostname#, ", $client->error ] ); return 0; }; @cmd = (MIME::Base64::encode_base64(defined $token ? $token : '', '')); } $code == CMD_OK; } sub banner { my $this = shift; return ${*$this}{'net_pop3_banner'}; } { package Net::POP3::_SSL; our @ISA = ( $ssl_class ? ($ssl_class):(), 'Net::POP3' ); sub starttls { die "POP3 connection is already in SSL mode" } sub start_SSL { my ($class,$pop3,%arg) = @_; delete @arg{ grep { !m{^SSL_} } keys %arg }; ( $arg{SSL_verifycn_name} ||= $pop3->host ) =~s{(?can_client_sni; $arg{SSL_verifycn_scheme} ||= 'pop3'; my $ok = $class->SUPER::start_SSL($pop3,%arg); $@ = $ssl_class->errstr if !$ok; return $ok; } } 1; __END__ =head1 NAME Net::POP3 - Post Office Protocol 3 Client class (RFC1939) =head1 SYNOPSIS use Net::POP3; # Constructors $pop = Net::POP3->new('pop3host'); $pop = Net::POP3->new('pop3host', Timeout => 60); $pop = Net::POP3->new('pop3host', SSL => 1, Timeout => 60); if ($pop->login($username, $password) > 0) { my $msgnums = $pop->list; # hashref of msgnum => size foreach my $msgnum (keys %$msgnums) { my $msg = $pop->get($msgnum); print @$msg; $pop->delete($msgnum); } } $pop->quit; =head1 DESCRIPTION This module implements a client interface to the POP3 protocol, enabling a perl5 application to talk to POP3 servers. This documentation assumes that you are familiar with the POP3 protocol described in RFC1939. With L installed it also provides support for implicit and explicit TLS encryption, i.e. POP3S or POP3+STARTTLS. A new Net::POP3 object must be created with the I method. Once this has been done, all POP3 commands are accessed via method calls on the object. The Net::POP3 class is a subclass of Net::Cmd and (depending on avaibility) of IO::Socket::IP, IO::Socket::INET6 or IO::Socket::INET. =head1 CONSTRUCTOR =over 4 =item new ( [ HOST ] [, OPTIONS ] ) This is the constructor for a new Net::POP3 object. C is the name of the remote host to which an POP3 connection is required. C is optional. If C is not given then it may instead be passed as the C option described below. If neither is given then the C specified in C will be used. C are passed in a hash like fashion, using key and value pairs. Possible options are: B - POP3 host to connect to. It may be a single scalar, as defined for the C option in L, or a reference to an array with hosts to try in turn. The L method will return the value which was used to connect to the host. B - port to connect to. Default - 110 for plain POP3 and 995 for POP3s (direct SSL). B - If the connection should be done from start with SSL, contrary to later upgrade with C. You can use SSL arguments as documented in L, but it will usually use the right arguments already. B and B - These parameters are passed directly to IO::Socket to allow binding the socket to a specific local address and port. For compatibility with older versions B can be used instead of B. B - This parameter is passed directly to IO::Socket and makes it possible to enforce IPv4 connections even if L is used as super class. Alternatively B can be used. B - Maximum time, in seconds, to wait for a response from the POP3 server (default: 120) B - Enable debugging information =back =head1 METHODS Unless otherwise stated all methods return either a I or I value, with I meaning that the operation was a success. When a method states that it returns a value, failure will be returned as I or an empty list. C inherits from C so methods defined in C may be used to send commands to the remote POP3 server in addition to the methods documented here. =over 4 =item host () Returns the value used by the constructor, and passed to IO::Socket::INET, to connect to the host. =item auth ( USERNAME, PASSWORD ) Attempt SASL authentication. =item user ( USER ) Send the USER command. =item pass ( PASS ) Send the PASS command. Returns the number of messages in the mailbox. =item login ( [ USER [, PASS ]] ) Send both the USER and PASS commands. If C is not given the C uses C to lookup the password using the host and username. If the username is not specified then the current user name will be used. Returns the number of messages in the mailbox. However if there are no messages on the server the string C<"0E0"> will be returned. This is will give a true value in a boolean context, but zero in a numeric context. If there was an error authenticating the user then I will be returned. =item starttls ( SSLARGS ) Upgrade existing plain connection to SSL. You can use SSL arguments as documented in L, but it will usually use the right arguments already. =item apop ( [ USER [, PASS ]] ) Authenticate with the server identifying as C with password C. Similar to L, but the password is not sent in clear text. To use this method you must have the Digest::MD5 or the MD5 module installed, otherwise this method will return I. =item banner () Return the sever's connection banner =item capa () Return a reference to a hash of the capabilities of the server. APOP is added as a pseudo capability. Note that I've been unable to find a list of the standard capability values, and some appear to be multi-word and some are not. We make an attempt at intelligently parsing them, but it may not be correct. =item capabilities () Just like capa, but only uses a cache from the last time we asked the server, so as to avoid asking more than once. =item top ( MSGNUM [, NUMLINES ] ) Get the header and the first C of the body for the message C. Returns a reference to an array which contains the lines of text read from the server. =item list ( [ MSGNUM ] ) If called with an argument the C returns the size of the message in octets. If called without arguments a reference to a hash is returned. The keys will be the C's of all undeleted messages and the values will be their size in octets. =item get ( MSGNUM [, FH ] ) Get the message C from the remote mailbox. If C is not given then get returns a reference to an array which contains the lines of text read from the server. If C is given then the lines returned from the server are printed to the filehandle C. =item getfh ( MSGNUM ) As per get(), but returns a tied filehandle. Reading from this filehandle returns the requested message. The filehandle will return EOF at the end of the message and should not be reused. =item last () Returns the highest C of all the messages accessed. =item popstat () Returns a list of two elements. These are the number of undeleted elements and the size of the mbox in octets. =item ping ( USER ) Returns a list of two elements. These are the number of new messages and the total number of messages for C. =item uidl ( [ MSGNUM ] ) Returns a unique identifier for C if given. If C is not given C returns a reference to a hash where the keys are the message numbers and the values are the unique identifiers. =item delete ( MSGNUM ) Mark message C to be deleted from the remote mailbox. All messages that are marked to be deleted will be removed from the remote mailbox when the server connection closed. =item reset () Reset the status of the remote POP3 server. This includes resetting the status of all messages to not be deleted. =item quit () Quit and close the connection to the remote POP3 server. Any messages marked as deleted will be deleted from the remote mailbox. =item can_inet6 () Returns whether we can use IPv6. =item can_ssl () Returns whether we can use SSL. =back =head1 NOTES If a C object goes out of scope before C method is called then the C method will called before the connection is closed. This means that any messages marked to be deleted will not be. =head1 SEE ALSO L, L, L =head1 AUTHOR Graham Barr EFE. Steve Hay EFE is now maintaining libnet as of version 1.22_02. =head1 COPYRIGHT Copyright (C) 1995-2004 Graham Barr. All rights reserved. Copyright (C) 2013-2016 Steve Hay. All rights reserved. =head1 LICENCE This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself, i.e. under the terms of either the GNU General Public License or the Artistic License, as specified in the F file. =cut FTP/L.pm000064400000000211152346665430005736 0ustar00package Net::FTP::L; use 5.008001; use strict; use warnings; use Net::FTP::I; our @ISA = qw(Net::FTP::I); our $VERSION = "3.11"; 1; FTP/E.pm000064400000000211152346665430005727 0ustar00package Net::FTP::E; use 5.008001; use strict; use warnings; use Net::FTP::I; our @ISA = qw(Net::FTP::I); our $VERSION = "3.11"; 1; FTP/I.pm000064400000003173152346665430005745 0ustar00## ## Package to read/write on BINARY data connections ## package Net::FTP::I; use 5.008001; use strict; use warnings; use Carp; use Net::FTP::dataconn; our @ISA = qw(Net::FTP::dataconn); our $VERSION = "3.11"; our $buf; sub read { my $data = shift; local *buf = \$_[0]; shift; my $size = shift || croak 'read($buf,$size,[$timeout])'; my $timeout = @_ ? shift: $data->timeout; my $n; if ($size > length ${*$data} and !${*$data}{'net_ftp_eof'}) { $data->can_read($timeout) or croak "Timeout"; my $blksize = ${*$data}{'net_ftp_blksize'}; $blksize = $size if $size > $blksize; unless ($n = sysread($data, ${*$data}, $blksize, length ${*$data})) { return unless defined $n; ${*$data}{'net_ftp_eof'} = 1; } } $buf = substr(${*$data}, 0, $size); $n = length($buf); substr(${*$data}, 0, $n) = ''; ${*$data}{'net_ftp_bytesread'} += $n; $n; } sub write { my $data = shift; local *buf = \$_[0]; shift; my $size = shift || croak 'write($buf,$size,[$timeout])'; my $timeout = @_ ? shift: $data->timeout; # If the remote server has closed the connection we will be signal'd # when we write. This can happen if the disk on the remote server fills up local $SIG{PIPE} = 'IGNORE' unless ($SIG{PIPE} || '') eq 'IGNORE' or $^O eq 'MacOS'; my $sent = $size; my $off = 0; my $blksize = ${*$data}{'net_ftp_blksize'}; while ($sent > 0) { $data->can_write($timeout) or croak "Timeout"; my $n = syswrite($data, $buf, $sent > $blksize ? $blksize : $sent, $off); return unless defined($n); $sent -= $n; $off += $n; } $size; } 1; FTP/dataconn.pm000064400000007374152346665430007353 0ustar00## ## Generic data connection package ## package Net::FTP::dataconn; use 5.008001; use strict; use warnings; use Carp; use Errno; use Net::Cmd; our $VERSION = '3.11'; $Net::FTP::IOCLASS or die "please load Net::FTP before Net::FTP::dataconn"; our @ISA = $Net::FTP::IOCLASS; sub reading { my $data = shift; ${*$data}{'net_ftp_bytesread'} = 0; } sub abort { my $data = shift; my $ftp = ${*$data}{'net_ftp_cmd'}; # no need to abort if we have finished the xfer return $data->close if ${*$data}{'net_ftp_eof'}; # for some reason if we continuously open RETR connections and not # read a single byte, then abort them after a while the server will # close our connection, this prevents the unexpected EOF on the # command channel -- GMB if (exists ${*$data}{'net_ftp_bytesread'} && (${*$data}{'net_ftp_bytesread'} == 0)) { my $buf = ""; my $timeout = $data->timeout; $data->can_read($timeout) && sysread($data, $buf, 1); } ${*$data}{'net_ftp_eof'} = 1; # fake $ftp->abort; # this will close me } sub _close { my $data = shift; my $ftp = ${*$data}{'net_ftp_cmd'}; $data->SUPER::close(); delete ${*$ftp}{'net_ftp_dataconn'} if defined $ftp && exists ${*$ftp}{'net_ftp_dataconn'} && $data == ${*$ftp}{'net_ftp_dataconn'}; } sub close { my $data = shift; my $ftp = ${*$data}{'net_ftp_cmd'}; if (exists ${*$data}{'net_ftp_bytesread'} && !${*$data}{'net_ftp_eof'}) { my $junk; eval { local($SIG{__DIE__}); $data->read($junk, 1, 0) }; return $data->abort unless ${*$data}{'net_ftp_eof'}; } $data->_close; return unless defined $ftp; $ftp->response() == CMD_OK && $ftp->message =~ /unique file name:\s*(\S*)\s*\)/ && (${*$ftp}{'net_ftp_unique'} = $1); $ftp->status == CMD_OK; } sub _select { my ($data, $timeout, $do_read) = @_; my ($rin, $rout, $win, $wout, $tout, $nfound); vec($rin = '', fileno($data), 1) = 1; ($win, $rin) = ($rin, $win) unless $do_read; while (1) { $nfound = select($rout = $rin, $wout = $win, undef, $tout = $timeout); last if $nfound >= 0; croak "select: $!" unless $!{EINTR}; } $nfound; } sub can_read { _select(@_[0, 1], 1); } sub can_write { _select(@_[0, 1], 0); } sub cmd { my $ftp = shift; ${*$ftp}{'net_ftp_cmd'}; } sub bytes_read { my $ftp = shift; ${*$ftp}{'net_ftp_bytesread'} || 0; } 1; __END__ =head1 NAME Net::FTP::dataconn - FTP Client data connection class =head1 DESCRIPTION Some of the methods defined in C return an object which will be derived from this class. The dataconn class itself is derived from the C class, so any normal IO operations can be performed. However the following methods are defined in the dataconn class and IO should be performed using these. =over 4 =item read ( BUFFER, SIZE [, TIMEOUT ] ) Read C bytes of data from the server and place it into C, also performing any translation necessary. C is optional, if not given, the timeout value from the command connection will be used. Returns the number of bytes read before any translation. =item write ( BUFFER, SIZE [, TIMEOUT ] ) Write C bytes of data from C to the server, also performing any translation necessary. C is optional, if not given, the timeout value from the command connection will be used. Returns the number of bytes written before any translation. =item bytes_read () Returns the number of bytes read so far. =item abort () Abort the current data transfer. =item close () Close the data connection and get a response from the FTP server. Returns I if the connection was closed successfully and the first digit of the response from the server was a '2'. =back =cut FTP/A.pm000064400000004540152346665430005734 0ustar00## ## Package to read/write on ASCII data connections ## package Net::FTP::A; use 5.008001; use strict; use warnings; use Carp; use Net::FTP::dataconn; our @ISA = qw(Net::FTP::dataconn); our $VERSION = "3.11"; our $buf; sub read { my $data = shift; local *buf = \$_[0]; shift; my $size = shift || croak 'read($buf,$size,[$offset])'; my $timeout = @_ ? shift: $data->timeout; if (length(${*$data}) < $size && !${*$data}{'net_ftp_eof'}) { my $blksize = ${*$data}{'net_ftp_blksize'}; $blksize = $size if $size > $blksize; my $l = 0; my $n; READ: { my $readbuf = defined(${*$data}{'net_ftp_cr'}) ? "\015" : ''; $data->can_read($timeout) or croak "Timeout"; if ($n = sysread($data, $readbuf, $blksize, length $readbuf)) { ${*$data}{'net_ftp_bytesread'} += $n; ${*$data}{'net_ftp_cr'} = substr($readbuf, -1) eq "\015" ? chop($readbuf) : undef; } else { return unless defined $n; ${*$data}{'net_ftp_eof'} = 1; } $readbuf =~ s/\015\012/\n/sgo; ${*$data} .= $readbuf; unless (length(${*$data})) { redo READ if ($n > 0); $size = length(${*$data}) if ($n == 0); } } } $buf = substr(${*$data}, 0, $size); substr(${*$data}, 0, $size) = ''; length $buf; } sub write { my $data = shift; local *buf = \$_[0]; shift; my $size = shift || croak 'write($buf,$size,[$timeout])'; my $timeout = @_ ? shift: $data->timeout; my $nr = (my $tmp = substr($buf, 0, $size)) =~ tr/\r\n/\015\012/; $tmp =~ s/(?can_write($timeout) or croak "Timeout"; $off += $wrote; $wrote = syswrite($data, substr($tmp, $off), $len > $blksize ? $blksize : $len); return unless defined($wrote); $len -= $wrote; } $size; } 1;