From: Kilian Saffran Date: Tue, 19 Mar 2019 09:44:25 +0000 (+0100) Subject: rdv mail system X-Git-Url: http://cloud.dks.lu/git/?a=commitdiff_plain;h=b7730c216bcb8be119baeb2aaebdebeda062e516;p=juridig.git rdv mail system --- diff --git a/index.php b/index.php index 97c6ef4..7810493 100644 --- a/index.php +++ b/index.php @@ -8,8 +8,8 @@ $user = null; include ('cfg.php'); include ('lib/database.php'); - include ('lib/processdata.php'); - include ('lib/sendemail.php'); + include ('lib/processdata.php'); + $db = new dksdb(); $db->connect(); //echo '
'.$_GET['p'].'
'; diff --git a/lib/database.php b/lib/database.php index 57571fa..1a7e69e 100644 --- a/lib/database.php +++ b/lib/database.php @@ -30,7 +30,10 @@ class dksdb { public function dbexec($sql){ $rows = null; if ($this->link){ - $rows = $this->link->exec($sql); + $rows = $this->link->exec($sql); + if ($rows === false){ + errorlog("Failed Statement: ".$sql); + } } return $rows; } diff --git a/lib/lib/IO/All.pm b/lib/lib/IO/All.pm new file mode 100644 index 0000000..958f55a --- /dev/null +++ b/lib/lib/IO/All.pm @@ -0,0 +1,790 @@ +use strict; use warnings; +package IO::All; +our $VERSION = '0.87'; + +require Carp; +# So one can use Carp::carp "$message" - without the parenthesis. +sub Carp::carp; + +use IO::All::Base -base; + +use File::Spec(); +use Symbol(); +use Fcntl; +use Cwd (); + +our @EXPORT = qw(io); + +#=============================================================================== +# Object creation and setup methods +#=============================================================================== +my $autoload = { + qw( + touch file + + dir_handle dir + All dir + all_files dir + All_Files dir + all_dirs dir + All_Dirs dir + all_links dir + All_Links dir + mkdir dir + mkpath dir + next dir + + stdin stdio + stdout stdio + stderr stdio + + socket_handle socket + accept socket + shutdown socket + + readlink link + symlink link + ) +}; + +# XXX - These should die if the given argument exists but is not a +# link, dbm, etc. +sub link { require IO::All::Link; goto &IO::All::Link::link; } +sub dbm { require IO::All::DBM; goto &IO::All::DBM::dbm; } +sub mldbm { require IO::All::MLDBM; goto &IO::All::MLDBM::mldbm; } + +sub autoload { my $self = shift; $autoload; } + +sub AUTOLOAD { + my $self = shift; + my $method = $IO::All::AUTOLOAD; + $method =~ s/.*:://; + my $pkg = ref($self) || $self; + $self->throw(qq{Can't locate object method "$method" via package "$pkg"}) + if $pkg ne $self->_package; + my $class = $self->_autoload_class($method); + my $foo = "$self"; + bless $self, $class; + $self->$method(@_); +} + +sub _autoload_class { + my $self = shift; + my $method = shift; + my $class_id = $self->autoload->{$method} || $method; + my $ucfirst_class_name = 'IO::All::' . ucfirst($class_id); + my $ucfirst_class_fn = "IO/All/" . ucfirst($class_id) . ".pm"; + return $ucfirst_class_name if $INC{$ucfirst_class_fn}; + return "IO::All::\U$class_id" if $INC{"IO/All/\U$class_id\E.pm"}; + require IO::All::Temp; + if (eval "require $ucfirst_class_name; 1") { + my $class = $ucfirst_class_name; + my $return = $class->can('new') + ? $class + : do { # (OS X hack) + my $value = $INC{$ucfirst_class_fn}; + delete $INC{$ucfirst_class_fn}; + $INC{"IO/All/\U$class_id\E.pm"} = $value; + "IO::All::\U$class_id"; + }; + return $return; + } + elsif (eval "require IO::All::\U$class_id; 1") { + return "IO::All::\U$class_id"; + } + $self->throw("Can't find a class for method '$method'"); +} + +sub new { + my $self = shift; + my $package = ref($self) || $self; + my $new = bless Symbol::gensym(), $package; + $new->_package($package); + $new->_copy_from($self) if ref($self); + my $name = shift; + return $name if UNIVERSAL::isa($name, 'IO::All'); + return $new->_init unless defined $name; + return $new->handle($name) + if UNIVERSAL::isa($name, 'GLOB') or ref(\ $name) eq 'GLOB'; + # WWW - link is first because a link to a dir returns true for + # both -l and -d. + return $new->link($name) if -l $name; + return $new->file($name) if -f $name; + return $new->dir($name) if -d $name; + return $new->$1($name) if $name =~ /^([a-z]{3,8}):/; + return $new->socket($name) if $name =~ /^[\w\-\.]*:\d{1,5}$/; + return $new->pipe($name) if $name =~ s/^\s*\|\s*// or $name =~ s/\s*\|\s*$//; + return $new->string if $name eq '$'; + return $new->stdio if $name eq '-'; + return $new->stderr if $name eq '='; + return $new->temp if $name eq '?'; + $new->name($name); + $new->_init; +} + +sub _copy_from { + my $self = shift; + my $other = shift; + for (keys(%{*$other})) { + # XXX Need to audit exclusions here + next if /^(_handle|io_handle|is_open)$/; + *$self->{$_} = *$other->{$_}; + } +} + +sub handle { + my $self = shift; + $self->_handle(shift) if @_; + return $self->_init; +} + +#=============================================================================== +# Overloading support +#=============================================================================== +my $old_warn_handler = $SIG{__WARN__}; +$SIG{__WARN__} = sub { + if ($_[0] !~ /^Useless use of .+ \(.+\) in void context/) { + goto &$old_warn_handler if $old_warn_handler; + warn(@_); + } +}; + +use overload '""' => '_overload_stringify'; +use overload '|' => '_overload_bitwise_or'; +use overload '<<' => '_overload_left_bitshift'; +use overload '>>' => '_overload_right_bitshift'; +use overload '<' => '_overload_less_than'; +use overload '>' => '_overload_greater_than'; +use overload 'cmp' => '_overload_cmp'; +use overload '${}' => '_overload_string_deref'; +use overload '@{}' => '_overload_array_deref'; +use overload '%{}' => '_overload_hash_deref'; +use overload '&{}' => '_overload_code_deref'; + +sub _overload_bitwise_or { shift->_overload_handler(@_, '|' ); } +sub _overload_left_bitshift { shift->_overload_handler(@_, '<<'); } +sub _overload_right_bitshift { shift->_overload_handler(@_, '>>'); } +sub _overload_less_than { shift->_overload_handler(@_, '<' ); } +sub _overload_greater_than { shift->_overload_handler(@_, '>' ); } +sub _overload_string_deref { shift->_overload_handler(@_, '${}'); } +sub _overload_array_deref { shift->_overload_handler(@_, '@{}'); } +sub _overload_hash_deref { shift->_overload_handler(@_, '%{}'); } +sub _overload_code_deref { shift->_overload_handler(@_, '&{}'); } + +sub _overload_handler { + my ($self) = @_; + my $method = $self->_get_overload_method(@_); + $self->$method(@_); +} + +my $op_swap = { + '>' => '<', '>>' => '<<', + '<' => '>', '<<' => '>>', +}; + +sub _overload_table { + my $self = shift; + ( + '* > *' => '_overload_any_to_any', + '* < *' => '_overload_any_from_any', + '* >> *' => '_overload_any_addto_any', + '* << *' => '_overload_any_addfrom_any', + + '* < scalar' => '_overload_scalar_to_any', + '* > scalar' => '_overload_any_to_scalar', + '* << scalar' => '_overload_scalar_addto_any', + '* >> scalar' => '_overload_any_addto_scalar', + ) +}; + +sub _get_overload_method { + my ($self, $arg1, $arg2, $swap, $operator) = @_; + if ($swap) { + $operator = $op_swap->{$operator} || $operator; + } + my $arg1_type = $self->_get_argument_type($arg1); + my $table1 = { $arg1->_overload_table }; + + if ($operator =~ /\{\}$/) { + my $key = "$operator $arg1_type"; + return $table1->{$key} || $self->_overload_undefined($key); + } + + my $arg2_type = $self->_get_argument_type($arg2); + my @table2 = UNIVERSAL::isa($arg2, "IO::All") + ? ($arg2->_overload_table) + : (); + my $table = { %$table1, @table2 }; + + my @keys = ( + "$arg1_type $operator $arg2_type", + "* $operator $arg2_type", + ); + push @keys, "$arg1_type $operator *", "* $operator *" + unless $arg2_type =~ /^(scalar|array|hash|code|ref)$/; + + for (@keys) { + return $table->{$_} + if defined $table->{$_}; + } + + return $self->_overload_undefined($keys[0]); +} + +sub _get_argument_type { + my $self = shift; + my $argument = shift; + my $ref = ref($argument); + return 'scalar' unless $ref; + return 'code' if $ref eq 'CODE'; + return 'array' if $ref eq 'ARRAY'; + return 'hash' if $ref eq 'HASH'; + return 'ref' unless $argument->isa('IO::All'); + $argument->file + if defined $argument->pathname and not $argument->type; + return $argument->type || 'unknown'; +} + +sub _overload_cmp { + my ($self, $other, $swap) = @_; + $self = defined($self) ? $self.'' : $self; + ($self, $other) = ($other, $self) if $swap; + $self cmp $other; +} + +sub _overload_stringify { + my $self = shift; + my $name = $self->pathname; + return defined($name) ? $name : overload::StrVal($self); +} + +sub _overload_undefined { + my $self = shift; + require Carp; + my $key = shift; + Carp::carp "Undefined behavior for overloaded IO::All operation: '$key'" + if $^W; + return '_overload_noop'; +} + +sub _overload_noop { + my $self = shift; + return; +} + +sub _overload_any_addfrom_any { + $_[1]->append($_[2]->all); + $_[1]; +} + +sub _overload_any_addto_any { + $_[2]->append($_[1]->all); + $_[2]; +} + +sub _overload_any_from_any { + $_[1]->close if $_[1]->is_file and $_[1]->is_open; + $_[1]->print($_[2]->all); + $_[1]; +} + +sub _overload_any_to_any { + $_[2]->close if $_[2]->is_file and $_[2]->is_open; + $_[2]->print($_[1]->all); + $_[2]; +} + +sub _overload_any_to_scalar { + $_[2] = $_[1]->all; +} + +sub _overload_any_addto_scalar { + $_[2] .= $_[1]->all; + $_[2]; +} + +sub _overload_scalar_addto_any { + $_[1]->append($_[2]); + $_[1]; +} + +sub _overload_scalar_to_any { + local $\; + $_[1]->close if $_[1]->is_file and $_[1]->is_open; + $_[1]->print($_[2]); + $_[1]; +} + +#=============================================================================== +# Private Accessors +#=============================================================================== +field '_package'; +field _strict => undef; +field _layers => []; +field _handle => undef; +field _constructor => undef; +field _partial_spec_class => undef; + +#=============================================================================== +# Public Accessors +#=============================================================================== +chain block_size => 1024; +chain errors => undef; +field io_handle => undef; +field is_open => 0; +chain mode => undef; +chain name => undef; +chain perms => undef; +chain separator => $/; +field type => ''; + +sub _spec_class { + my $self = shift; + + my $ret = 'File::Spec'; + if (my $partial = $self->_partial_spec_class(@_)) { + $ret .= '::' . $partial; + eval "require $ret"; + } + + return $ret +} + +sub pathname {my $self = shift; $self->name(@_) } + +#=============================================================================== +# Chainable option methods (write only) +#=============================================================================== +option 'assert'; +option 'autoclose' => 1; +option 'backwards'; +option 'chomp'; +option 'confess'; +option 'lock'; +option 'rdonly'; +option 'rdwr'; +option 'strict'; + +#=============================================================================== +# IO::Handle proxy methods +#=============================================================================== +proxy 'autoflush'; +proxy 'eof'; +proxy 'fileno'; +proxy 'stat'; +proxy 'tell'; +proxy 'truncate'; + +#=============================================================================== +# IO::Handle proxy methods that open the handle if needed +#=============================================================================== +proxy_open print => '>'; +proxy_open printf => '>'; +proxy_open sysread => O_RDONLY; +proxy_open syswrite => O_CREAT | O_WRONLY; +proxy_open seek => $^O eq 'MSWin32' ? '<' : '+<'; +proxy_open 'getc'; + +#=============================================================================== +# Tie Interface +#=============================================================================== +sub tie { my $self = shift; tie *$self, $self; } + +sub TIEHANDLE { + return $_[0] if ref $_[0]; + my $class = shift; + my $self = bless Symbol::gensym(), $class; + $self->init(@_); +} + +sub READLINE { + goto &getlines if wantarray; + goto &getline; +} + + +sub DESTROY { + my $self = shift; + no warnings; + unless ( $] < 5.008 ) { + untie *$self if tied *$self; + } + $self->close if $self->is_open; +} + +sub BINMODE { my $self = shift; CORE::binmode *$self->io_handle; } + +{ + no warnings; + *GETC = \&getc; + *PRINT = \&print; + *PRINTF = \&printf; + *READ = \&read; + *WRITE = \&write; + *SEEK = \&seek; + *TELL = \&getpos; + *EOF = \&eof; + *CLOSE = \&close; + *FILENO = \&fileno; +} + +#=============================================================================== +# File::Spec Interface +#=============================================================================== +sub canonpath { + my $self = shift; + eval { Cwd::abs_path($self->pathname); 0 } || + File::Spec->canonpath($self->pathname) +} + +sub catdir { + my $self = shift; + my @args = grep defined, $self->name, @_; + $self->_constructor->()->dir(File::Spec->catdir(@args)); +} +sub catfile { + my $self = shift; + my @args = grep defined, $self->name, @_; + $self->_constructor->()->file(File::Spec->catfile(@args)); +} +sub join { shift->catfile(@_); } +sub curdir { shift->_constructor->()->dir(File::Spec->curdir); } +sub devnull { shift->_constructor->()->file(File::Spec->devnull); } +sub rootdir { shift->_constructor->()->dir(File::Spec->rootdir); } +sub tmpdir { shift->_constructor->()->dir(File::Spec->tmpdir); } +sub updir { shift->_constructor->()->dir(File::Spec->updir); } +sub case_tolerant{File::Spec->case_tolerant; } +sub is_absolute { File::Spec->file_name_is_absolute(shift->pathname); } +sub path { my $self = shift; map { $self->_constructor->()->dir($_) } File::Spec->path; } +sub splitpath { File::Spec->splitpath(shift->pathname); } +sub splitdir { File::Spec->splitdir(shift->pathname); } +sub catpath { my $self=shift; $self->_constructor->(File::Spec->catpath(@_)); } +sub abs2rel { File::Spec->abs2rel(shift->pathname, @_); } +sub rel2abs { File::Spec->rel2abs(shift->pathname, @_); } + +#=============================================================================== +# Public IO Action Methods +#=============================================================================== +sub absolute { + my $self = shift; + $self->pathname(File::Spec->rel2abs($self->pathname)) + unless $self->is_absolute; + $self->is_absolute(1); + return $self; +} + +sub all { + my $self = shift; + $self->_assert_open('<'); + local $/; + my $all = $self->io_handle->getline; + $self->_error_check; + $self->_autoclose && $self->close; + return $all; +} + +sub append { + my $self = shift; + $self->_assert_open('>>'); + $self->print(@_); +} + +sub appendln { + my $self = shift; + $self->_assert_open('>>'); + $self->println(@_); +} + +sub binary { + my $self = shift; + CORE::binmode($self->io_handle) if $self->is_open; + push @{$self->_layers}, ":raw"; + return $self; +} + +sub binmode { + my $self = shift; + my $layer = shift; + $self->_sane_binmode($layer) if $self->is_open; + push @{$self->_layers}, $layer; + return $self; +} + +sub _sane_binmode { + my ($self, $layer) = @_; + $layer + ? CORE::binmode($self->io_handle, $layer) + : CORE::binmode($self->io_handle); +} + +sub buffer { + my $self = shift; + if (not @_) { + *$self->{buffer} = do {my $x = ''; \ $x} + unless exists *$self->{buffer}; + return *$self->{buffer}; + } + my $buffer_ref = ref($_[0]) ? $_[0] : \ $_[0]; + $$buffer_ref = '' unless defined $$buffer_ref; + *$self->{buffer} = $buffer_ref; + return $self; +} + +sub clear { + my $self = shift; + my $buffer = *$self->{buffer}; + $$buffer = ''; + return $self; +} + +sub close { + my $self = shift; + return unless $self->is_open; + $self->is_open(0); + my $io_handle = $self->io_handle; + $self->io_handle(undef); + $self->mode(undef); + $io_handle->close(@_) + if defined $io_handle; + return $self; +} + +sub empty { + my $self = shift; + my $message = + "Can't call empty on an object that is neither file nor directory"; + $self->throw($message); +} + +sub exists {my $self = shift; -e $self->pathname } + +sub getline { + my $self = shift; + return $self->getline_backwards + if $self->_backwards; + $self->_assert_open('<'); + my $line; + { + local $/ = @_ ? shift(@_) : $self->separator; + $line = $self->io_handle->getline; + chomp($line) if $self->_chomp and defined $line; + } + $self->_error_check; + return $line if defined $line; + $self->close if $self->_autoclose; + return undef; +} + +sub getlines { + my $self = shift; + return $self->getlines_backwards + if $self->_backwards; + $self->_assert_open('<'); + my @lines; + { + local $/ = @_ ? shift(@_) : $self->separator; + @lines = $self->io_handle->getlines; + if ($self->_chomp) { + chomp for @lines; + } + } + $self->_error_check; + return @lines if @lines; + $self->close if $self->_autoclose; + return (); +} + +sub is_dir { UNIVERSAL::isa(shift, 'IO::All::Dir'); } +sub is_dbm { UNIVERSAL::isa(shift, 'IO::All::DBM'); } +sub is_file { UNIVERSAL::isa(shift, 'IO::All::File'); } +sub is_link { UNIVERSAL::isa(shift, 'IO::All::Link'); } +sub is_mldbm { UNIVERSAL::isa(shift, 'IO::All::MLDBM'); } +sub is_socket { UNIVERSAL::isa(shift, 'IO::All::Socket'); } +sub is_stdio { UNIVERSAL::isa(shift, 'IO::All::STDIO'); } +sub is_string { UNIVERSAL::isa(shift, 'IO::All::String'); } +sub is_temp { UNIVERSAL::isa(shift, 'IO::All::Temp'); } +sub length { length ${shift->buffer}; } + +sub open { + my $self = shift; + return $self if $self->is_open; + $self->is_open(1); + my ($mode, $perms) = @_; + $self->mode($mode) if defined $mode; + $self->mode('<') unless defined $self->mode; + $self->perms($perms) if defined $perms; + my @args; + unless ($self->is_dir) { + push @args, $self->mode; + push @args, $self->perms if defined $self->perms; + } + if (defined $self->pathname and not $self->type) { + $self->file; + return $self->open(@args); + } + elsif (defined $self->_handle and + not $self->io_handle->opened + ) { + # XXX Not tested + $self->io_handle->fdopen($self->_handle, @args); + } + $self->_set_binmode; +} + +sub println { + my $self = shift; + $self->print(map {/\n\z/ ? ($_) : ($_, "\n")} @_); +} + +sub read { + my $self = shift; + $self->_assert_open('<'); + my $length = (@_ or $self->type eq 'dir') + ? $self->io_handle->read(@_) + : $self->io_handle->read( + ${$self->buffer}, + $self->block_size, + $self->length, + ); + $self->_error_check; + return $length || $self->_autoclose && $self->close && 0; +} + +{ + no warnings; + *readline = \&getline; +} + +# deprecated +sub scalar { + my $self = shift; + $self->all(@_); +} + +sub slurp { + my $self = shift; + my $slurp = $self->all; + return $slurp unless wantarray; + my $separator = $self->separator; + if ($self->_chomp) { + local $/ = $separator; + map {chomp; $_} split /(?<=\Q$separator\E)/, $slurp; + } + else { + split /(?<=\Q$separator\E)/, $slurp; + } +} + +sub utf8 { + my $self = shift; + if ($] < 5.008) { + die "IO::All -utf8 not supported on Perl older than 5.8"; + } + $self->encoding('UTF-8'); + return $self; +} + +sub _has_utf8 { + grep { $_ eq ':encoding(UTF-8)' } @{shift->_layers} +} + +sub encoding { + my $self = shift; + my $encoding = shift; + if ($] < 5.008) { + die "IO::All -encoding not supported on Perl older than 5.8"; + } + die "No valid encoding string sent" if !$encoding; + $self->_set_encoding($encoding) if $self->is_open and $encoding; + push @{$self->_layers}, ":encoding($encoding)"; + return $self; +} + +sub _set_encoding { + my ($self, $encoding) = @_; + return CORE::binmode($self->io_handle, ":encoding($encoding)"); +} + +sub write { + my $self = shift; + $self->_assert_open('>'); + my $length = @_ + ? $self->io_handle->write(@_) + : $self->io_handle->write(${$self->buffer}, $self->length); + $self->_error_check; + $self->clear unless @_; + return $length; +} + +#=============================================================================== +# Implementation methods. Subclassable. +#=============================================================================== +sub throw { + my $self = shift; + require Carp; + ; + return &{$self->errors}(@_) + if $self->errors; + return Carp::confess(@_) + if $self->_confess; + return Carp::croak(@_); +} + +#=============================================================================== +# Private instance methods +#=============================================================================== +sub _assert_dirpath { + my $self = shift; + my $dir_name = shift; + return $dir_name if ((! CORE::length($dir_name)) or + -d $dir_name or + CORE::mkdir($dir_name, $self->perms || 0755) or + do { + require File::Path; + File::Path::mkpath($dir_name, 0, $self->perms || 0755 ); + } or + $self->throw("Can't make $dir_name")); +} + +sub _assert_open { + my $self = shift; + return if $self->is_open; + $self->file unless $self->type; + return $self->open(@_); +} + +sub _error_check { + my $self = shift; + my $saved_error = $!; + return unless $self->io_handle->can('error'); + return unless $self->io_handle->error; + $self->throw($saved_error); +} + +sub _set_binmode { + my $self = shift; + $self->_sane_binmode($_) for @{$self->_layers}; + return $self; +} + +#=============================================================================== +# Stat Methods +#=============================================================================== +BEGIN { + no strict 'refs'; + my @stat_fields = qw( + device inode modes nlink uid gid device_id size atime mtime + ctime blksize blocks + ); + foreach my $stat_field_idx (0 .. $#stat_fields) + { + my $idx = $stat_field_idx; + my $name = $stat_fields[$idx]; + + *$name = sub { + my $self = shift; + return (stat($self->io_handle || $self->pathname))[$idx]; + }; + } +} + diff --git a/lib/lib/IO/All.pod b/lib/lib/IO/All.pod new file mode 100644 index 0000000..70ac13c --- /dev/null +++ b/lib/lib/IO/All.pod @@ -0,0 +1,1788 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All - IO::All to Larry Wall! + +=for html +io-all-pm + +=head1 VERSION + +This document describes L version B<0.87>. + +=head1 SYNOPSIS + +First, some safe examples: + + use IO::All; + + # Some of the many ways to read a whole file into a scalar + $contents = io->file('file.txt')->slurp; # Read an entire file + @files = io->dir('lib')->all; # Get a list of files + $tail = io->pipe('-| tail app.log'); # Open a pipe to a command + $line = $tail->getline; # Read from the pipe + +That said, there are a lot more things that are very convenient and will help +you write code very quickly, though they should be used judiciously: + + use IO::All; # Let the madness begin... + + # Some of the many ways to read a whole file into a scalar + io('file.txt') > $contents; # Overloaded "arrow" + $contents < io 'file.txt'; # Flipped but same operation + $io = io 'file.txt'; # Create a new IO::All object + $contents = $$io; # Overloaded scalar dereference + $contents = $io->all; # A method to read everything + $contents = $io->slurp; # Another method for that + $contents = join '', $io->getlines; # Join the separate lines + $contents = join '', map "$_\n", @$io; # Same. Overloaded array deref + $io->tie; # Tie the object as a handle + $contents = join '', <$io>; # And use it in builtins + # and the list goes on ... + + # Other file operations: + @lines = io('file.txt')->slurp; # List context slurp + $content > io('file.txt'); # Print to a file + io('file.txt')->print($content, $more); # (ditto) + $content >> io('file.txt'); # Append to a file + io('file.txt')->append($content); # (ditto) + $content << $io; # Append to a string + io('copy.txt') < io('file.txt'); $ Copy a file + io('file.txt') > io('copy.txt'); # Invokes File::Copy + io('more.txt') >> io('all.txt'); # Add on to a file + io('dir/') < io('file.txt'); $ Copy a file to a directory + io('file.txt') > io('dir/'); # Invokes File::Copy + io('more.txt') >> io('dir/'); # Add on to a file in the dir + + # UTF-8 Support + $contents = io('file.txt')->utf8->all; # Turn on utf8 + use IO::All -utf8; # Turn on utf8 for all io + $contents = io('file.txt')->all; # by default in this package. + + # General Encoding Support + $contents = io('file.txt')->encoding('big5')->all; + use IO::All -encoding => 'big5'; # Turn on big5 for all io + $contents = io('file.txt')->all; # by default in this package. + + # Print the path name of a file: + print $io->name; # The direct method + print "$io"; # Object stringifies to name + print $io; # Quotes not needed here + print $io->filename; # The file portion only + $io->os('win32'); # change the object to be a + # win32 path + print $io->ext; # The file extension only + print $io->mimetype; # The mimetype, requires a + # working File::MimeType + + + # Read all the files/directories in a directory: + $io = io('my/directory/'); # Create new directory object + @contents = $io->all; # Get all contents of dir + @contents = @$io; # Directory as an array + @contents = values %$io; # Directory as a hash + push @contents, $subdir # One at a time + while $subdir = $io->next; + + # Print the name and file type for all the contents above: + print "$_ is a " . $_->type . "\n" # Each element of @contents + for @contents; # is an IO::All object!! + + # Print first line of each file: + print $_->getline # getline gets one line + for io('dir')->all_files; # Files only + + # Print names of all files/dirs three directories deep: + print "$_\n" for $io->all(3); # Pass in the depth. Default=1 + + # Print names of all files/dirs recursively: + print "$_\n" for $io->all(0); # Zero means all the way down + print "$_\n" for $io->All; # Capitalized shortcut + print "$_\n" for $io->deep->all; # Another way + + # There are some special file names: + print io('-'); # Print STDIN to STDOUT + io('-') > io('-'); # Do it again + io('-') < io('-'); # Same. Context sensitive. + "Bad puppy" > io('='); # Message to STDERR + $string_file = io('$'); # Create string based filehandle + $temp_file = io('?'); # Create a temporary file + + # Socket operations: + $server = io('localhost:5555')->fork; # Create a daemon socket + $connection = $server->accept; # Get a connection socket + $input < $connection; # Get some data from it + "Thank you!" > $connection; # Thank the caller + $connection->close; # Hang up + io(':6666')->accept->slurp > io->devnull; # Take a complaint and file it + + # DBM database operations: + $dbm = io 'my/database'; # Create a database object + print $dbm->{grocery_list}; # Hash context makes it a DBM + $dbm->{todo} = $new_list; # Write to database + $dbm->dbm('GDBM_file'); # Demand specific DBM + io('mydb')->mldbm->{env} = \%ENV; # MLDBM support + + # Tie::File support: + $io = io 'file.txt'; + $io->[42] = 'Line Forty Three'; # Change a line + print $io->[@$io / 2]; # Print middle line + @$io = reverse @$io; # Reverse lines in a file + + # Stat functions: + printf "%s %s %s\n", # Print name, uid and size of + $_->name, $_->uid, $_->size # contents of current directory + for io('.')->all; + print "$_\n" for sort # Use mtime method to sort all + {$b->mtime <=> $a->mtime} # files under current directory + io('.')->All_Files; # by recent modification time. + + # File::Spec support: + $contents < io->catfile(qw(dir file.txt)); # Portable IO operation + + # Miscellaneous: + @lines = io('file.txt')->chomp->slurp; # Chomp as you slurp + @chunks = + io('file.txt')->separator('xxx')->slurp; # Use alternnate record sep + $binary = io('file.bin')->binary->all; # Read a binary file + io('a-symlink')->readlink->slurp; # Readlink returns an object + print io('foo')->absolute->pathname; # Print absolute path of foo + + # IO::All External Plugin Methods + io("myfile") > io->("ftp://store.org"); # Upload a file using ftp + $html < io->http("www.google.com"); # Grab a web page + io('mailto:worst@enemy.net')->print($spam); # Email a "friend" + + # This is just the beginning, read on... + +=head1 DESCRIPTION + +IO::All combines all of the best Perl IO modules into a single nifty object +oriented interface to greatly simplify your everyday Perl IO idioms. It +exports a single function called C, which returns a new IO::All object. +And that object can do it all! + +The IO::All object is a proxy for IO::File, IO::Dir, IO::Socket, Tie::File, +File::Spec, File::Path, File::MimeInfo and File::ReadBackwards; as well as all +the DBM and MLDBM modules. You can use most of the methods found in these +classes and in IO::Handle (which they inherit from). IO::All adds dozens of +other helpful idiomatic methods including file stat and manipulation +functions. + +IO::All is pluggable, and modules like L and L +add even more functionality. Optionally, every IO::All object can be tied to +itself. This means that you can use most perl IO builtins on it: readline, C<< +<> >>, getc, print, printf, syswrite, sysread, close. + +The distinguishing magic of IO::All is that it will automatically open (and +close) files, directories, sockets and other IO things for you. You never need +to specify the mode (C<< < >>, C<< >> >>, etc), since it is determined by the +usage context. That means you can replace this: + + open STUFF, '<', './mystuff' + or die "Can't open './mystuff' for input:\n$!"; + local $/; + my $stuff = ; + close STUFF; + +with this: + + my $stuff < io './mystuff'; + +And that is a B! + +=head1 USAGE + +Normally just say: + + use IO::All; + +and IO::All will export a single function called C, which constructs all +IO objects. + +=head2 Note on C + +The C function is a I. It is easy to use and will +usually do the right thing, but can also blow up easily. + +It takes a single optional argument and determines what type of IO::All +subclass object to return. With no arguments it returns an C object, +which has no I/O methods, but has methods to construct subclass objects like +C. + +In other words, these 2 statements are usually the same: + + $content = io('file.txt')->all; + $content = io->file('file.txt')->all; + +Use the first form when you are demonstrating your Perl virtues of laziness +and impatience, and use the second form when your job is on the line. + +=head1 METHOD ROLE CALL + +Here is an alphabetical list of all the public methods that you can call on an +IO::All object. + +L, L, L, L, L, L, +L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, +L, L, L, L, L, L, L, +L, L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, L, +L, L, L, L, L, L, L, +L, L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, +L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, L, +L, L, L L, L, L, L, +L, L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, +L, L, L, L, L, L, L, +L, L, L, L, L, L, L, +L and L. + +Each method is documented further below. + +=head1 OPERATOR OVERLOADING + +IO::All objects overload a small set of Perl operators to great effect. The +overloads are limited to C<< < >>, C<< << >>, C<< > >>, C<< >> >>, +dereferencing operations, and stringification. + +Even though relatively few operations are overloaded, there is actually a huge +matrix of possibilities for magic. That's because the overloading is sensitive +to the types, position and context of the arguments, and an IO::All object can +be one of many types. + +The most important overload to become familiar with is stringification. +IO::All objects stringify to their file or directory name. Here we print the +contents of the current directory: + + perl -MIO::All -le 'print for io(".")->all' + +is the same as: + + perl -MIO::All -le 'print $_->name for io(".")->all' + +Stringification is important because it allows IO::All operations to return +objects when they might otherwise return file names. Then the recipient can +use the result either as an object or a string. + +C<< > >> and C<< < >> move data between objects in the direction pointed to by +the operator. + + $content1 < io('file1'); + $content1 > io('file2'); + io('file2') > $content3; + io('file3') < $content3; + io('file3') > io('file4'); + io('file5') < io('file4'); + +C<< >> >> and C<< << >> do the same thing except the recipient string or file +is appended to. + +An IO::All file used as an array reference becomes tied using Tie::File: + + $file = io "file"; + # Print last line of file + print $file->[-1]; + # Insert new line in middle of file + $file->[$#$file / 2] = 'New line'; + +An IO::All file used as a hash reference becomes tied to a DBM class: + + io('mydbm')->{ingy} = 'YAML'; + +An IO::All directory used as an array reference, will expose each file or +subdirectory as an element of the array. + + print "$_\n" for @{io 'dir'}; + +IO::All directories used as hash references have file names as keys, and +IO::All objects as values: + + print io('dir')->{'foo.txt'}->slurp; + +Files used as scalar references get slurped: + + print ${io('dir')->{'foo.txt'}}; + +Not all combinations of operations and object types are supported. Some just +haven't been added yet, and some just don't make sense. If you use an invalid +combination, an error will be thrown. + +=head1 COOKBOOK + +This section describes some various things that you can easily cook up +with IO::All. + +=head2 File Locking + +IO::All makes it very easy to lock files. Just use the C method. Here's +a standalone program that demonstrates locking for both write and read: + + use IO::All; + my $io1 = io('myfile')->lock; + $io1->println('line 1'); + + fork or do { + my $io2 = io('myfile')->lock; + print $io2->slurp; + exit; + }; + + sleep 1; + $io1->println('line 2'); + $io1->println('line 3'); + $io1->unlock; + +There are a lot of subtle things going on here. An exclusive lock is issued +for C<$io1> on the first C. That's because the file isn't actually +opened until the first IO operation. + +When the child process tries to read the file using C<$io2>, there is a shared +lock put on it. Since C<$io1> has the exclusive lock, the slurp blocks. + +The parent process sleeps just to make sure the child process gets a chance. +The parent needs to call C or C to release the lock. If all +goes well the child will print 3 lines. + +=head2 In-place Editing + +Because an IO::All object can be used as an array reference, operations on +arrays are supported transparently (using Tie::File) so a file can be modified +in the same way you would modify an array. + + > cat > x.txt + The sexy saxophone, + + got the axe. + ^d + + > perl -MIO::All -e 'map { s/x/X/g; $_ } @{ io(shift) }' x.txt + > cat x.txt + The seXy saXophone, + + got the aXe. + + This one liner uses shift() to grab the file from STDIN and create an io + object that is dereferenced using @{ } and fed to map() like any perl array + reference. + +=head2 Round Robin + +This simple example will read lines from a file forever. When the last line is +read, it will reopen the file and read the first one again. + + my $io = io 'file1.txt'; + $io->autoclose(1); + while (my $line = $io->getline || $io->getline) { + print $line; + } + +=head2 Reading Backwards + +If you call the C method on an IO::All object, the C and +C will work in reverse. They will read the lines in the file from +the end to the beginning. + + my @reversed; + my $io = io('file1.txt'); + $io->backwards; + while (my $line = $io->getline) { + push @reversed, $line; + } + +or more simply: + + my @reversed = io('file1.txt')->backwards->getlines; + +The C method returns the IO::All object so that you can chain +the calls. + +NOTE: This operation requires that you have the L module + installed. + +=head2 Client/Server Sockets + +IO::All makes it really easy to write a forking socket server and a client to +talk to it. + +In this example, a server will return 3 lines of text, to every client that +calls it. Here is the server code: + + use IO::All; + + my $socket = io(':12345')->fork->accept; + $socket->print($_) while ; + $socket->close; + + __DATA__ + On your mark, + Get set, + Go! + +Here is the client code: + + use IO::All; + + my $io = io('localhost:12345'); + print while $_ = $io->getline; + +You can run the server once, and then run the client repeatedly (in another +terminal window). It should print the 3 data lines each time. + +Note that it is important to close the socket if the server is forking, or +else the socket won't go out of scope and close. + +=head2 A Tiny Web Server + +Here is how you could write a simplistic web server that works with static and +dynamic pages: + + perl -MIO::All -e 'io(":8080")->fork->accept->(sub { $_[0] < io(-x $1 ? "./$1 |" : $1) if /^GET \/(.*) / })' + +There is are a lot of subtle things going on here. First we accept a socket +and fork the server. Then we overload the new socket as a code ref. This code +ref takes one argument, another code ref, which is used as a callback. + +The callback is called once for every line read on the socket. The line is put +into C<$_> and the socket itself is passed in to the callback. + +Our callback is scanning the line in C<$_> for an HTTP GET request. If one is +found it parses the file name into C<$1>. Then we use C<$1> to create an new +IO::All file object... with a twist. If the file is executable (C<-x>), then +we create a piped command as our IO::All object. This somewhat approximates +CGI support. + +Whatever the resulting object is, we direct the contents back at our socket +which is in C<$_[0]>. Pretty simple, eh? + +=head2 DBM Files + +IO::All file objects used as a hash reference, treat the file as a DBM tied to +a hash. Here I write my DB record to STDERR: + + io("names.db")->{ingy} > io('='); + +Since their are several DBM formats available in Perl, IO::All picks the first +one of these that is installed on your system: + + DB_File GDBM_File NDBM_File ODBM_File SDBM_File + +You can override which DBM you want for each IO::All object: + + my @keys = keys %{io('mydbm')->dbm('SDBM_File')}; + +=head2 File Subclassing + +Subclassing is easy with IO::All. Just create a new module and use IO::All as +the base class, like this: + + package NewModule; + use IO::All -base; + +You need to do it this way so that IO::All will export the C function. +Here is a simple recipe for subclassing: + +IO::Dumper inherits everything from IO::All and adds an extra method called +C, which will dump a data structure to the file we specify in the +C function. Since it needs Data::Dumper to do the dumping, we override +the C method to C and then pass control to the +real C. + +First the code using the module: + + use IO::Dumper; + + io('./mydump')->dump($hash); + +And next the IO::Dumper module itself: + + package IO::Dumper; + use IO::All -base; + use Data::Dumper; + + sub dump { + my $self = shift; + Dumper(@_) > $self; + } + + 1; + +=head2 Inline Subclassing + +This recipe does the same thing as the previous one, but without needing to +write a separate module. The only real difference is the first line. Since you +don't "use" IO::Dumper, you need to still call its C method manually. + + IO::Dumper->import; + io('./mydump')->dump($hash); + + package IO::Dumper; + use IO::All -base; + use Data::Dumper; + + sub dump { + my $self = shift; + Dumper(@_) > $self; + } + +=head1 THE IO::ALL METHODS + +This section gives a full description of all of the methods that you can call +on IO::All objects. The methods have been grouped into subsections based on +object construction, option settings, configuration, action methods and +support for specific modules. + +=head2 Object Construction and Initialization Methods + +=over + +=item new + +There are three ways to create a new IO::All object. The first is with the +special function C which really just calls C<< IO::All->new >>. The second +is by calling C as a class method. The third is calling C as an +object instance method. In this final case, the new objects attributes are +copied from the instance object. + + io(file-descriptor); + IO::All->new(file-descriptor); + $io->new(file-descriptor); + +All three forms take a single argument, a file descriptor. A file descriptor +can be any of the following: + + - A file name + - A file handle + - A directory name + - A directory handle + - A typeglob reference + - A piped shell command. eg '| ls -al' + - A socket domain/port. eg 'perl.com:5678' + - '-' means STDIN or STDOUT (depending on usage) + - '=' means STDERR + - '$' means an in memory filehandle object + - '?' means a temporary file + - A URI including: http, https, ftp and mailto + - An IO::All object + +If you provide an IO::All object, you will simply get that I +returned from the constructor. + +If no file descriptor is provided, an object will still be created, but it +must be defined by one of the following methods before it can be used for I/O: + +=item file + + io->file("path/to/my/file.txt"); + +Using the C method sets the type of the object to I and sets the +pathname of the file if provided. + +It might be important to use this method if you had a file whose name was C<'- +'>, or if the name might otherwise be confused with a directory or a socket. +In this case, either of these statements would work the same: + + my $file = io('-')->file; + my $file = io->file('-'); + +=item dir + + io->dir($dir_name); + +Make the object be of type I. + +=item socket + + io->socket("${domain}:${port}"); + +Make the object be of type I. + +=item link + + io->link($link_name); + +Make the object be of type I. + +=item pipe + + io->pipe($pipe_command); + +Make the object be of type I. The following three statements are +equivalent: + + my $io = io('ls -l |'); + my $io = io('ls -l')->pipe; + my $io = io->pipe('ls -l'); + +=item dbm + +This method takes the names of zero or more DBM modules. The first one that is +available is used to process the dbm file. + + io('mydbm')->dbm('NDBM_File', 'SDBM_File')->{author} = 'ingy'; + +If no module names are provided, the first available of the following is used: + + DB_File GDBM_File NDBM_File ODBM_File SDBM_File + +=item mldbm + +Similar to the C method, except create a Multi Level DBM object using the +MLDBM module. + +This method takes the names of zero or more DBM modules and an optional +serialization module. The first DBM module that is available is used to +process the MLDBM file. The serialization module can be Data::Dumper, Storable +or FreezeThaw. + + io('mymldbm')->mldbm('GDBM_File', 'Storable')->{author} = + {nickname => 'ingy'}; + +=item string + +Make the object be an in memory filehandle. These are equivalent: + + my $io = io('$'); + my $io = io->string; + +=item temp + +Make the object represent a temporary file. It will automatically be open for +both read and write. + +=item stdio + +Make the object represent either STDIN or STDOUT depending on how it is used +subsequently. These are equivalent: + + my $io = io('-'); + my $io = io->stdin; + +=item stdin + +Make the object represent STDIN. + +=item stdout + +Make the object represent STDOUT. + +=item stderr + +Make the object represent STDERR. + +=item handle + + io->handle($io_handle); + +Forces the object to be created from an pre-existing IO handle. You can chain +calls together to indicate the type of handle: + + my $file_object = io->file->handle($file_handle); + my $dir_object = io->dir->handle($dir_handle); + +=item http + +Make the object represent an HTTP URI. Requires IO-All-LWP. + +=item https + +Make the object represent an HTTPS URI. Requires IO-All-LWP. + +=item ftp + +Make the object represent an FTP URI. Requires IO-All-LWP. + +=item mailto + +Make the object represent a C URI. Requires IO-All-Mailto. + +=back + +If you need to use the same options to create a lot of objects, and don't want +to duplicate the code, just create a dummy object with the options you want, +and use that object to spawn other objects. + + my $lt = io->lock->tie; + ... + my $io1 = $lt->new('file1'); + my $io2 = $lt->new('file2'); + +Since the new method copies attributes from the calling object, both C<$io1> +and C<$io2> will be locked and tied. + +=head2 Option Setting Methods + +The following methods don't do any actual IIO should be done. + +Each option can take a single argument of 0 or 1. If no argument is given, the +value 1 is assumed. Passing 0 turns the option off. + +All of these options return the object reference that was used to invoke them. +This is so that the option methods can be chained together. For example: + + my $io = io('path/file')->tie->assert->chomp->lock; + +=over + +=item absolute + +Indicates that the C for the object should be made absolute. + + # Print the full path of the current working directory + # (like pwd). + + use IO::All; + + print io->curdir->absolute; + +=item assert + +This method ensures that the path for a file or directory actually exists +before the file is open. If the path does not exist, it is created. + +For example, here is a program called "create-cat-to" that outputs to a file +that it creates. + + #!/usr/bin/perl + + # create-cat-to.pl + # cat to a file that can be created. + + use strict; + use warnings; + + use IO::All; + + my $filename = shift(@ARGV); + + # Create a file called $filename, including all leading components. + io('-') > io->file($filename)->assert; + +Here's an example use of it: + + $ ls -l + total 0 + $ echo "Hello World" | create-cat-to one/two/three/four.txt + $ ls -l + total 4 + drwxr-xr-x 3 shlomif shlomif 4096 2010-10-14 18:03 one/ + $ cat one/two/three/four.txt + Hello World + $ + +=item autoclose + +By default, IO::All will close an object opened for input when EOF is reached. +By closing the handle early, one can immediately do other operations on the +object without first having to close it. + +This option is on by default, so if you don't want this behaviour, say so +like this: + + $io->autoclose(0); + +The object will then be closed when C<$io> goes out of scope, or you manually +call C<< $io->close >>. + +=item autoflush + +Proxy for IO::Handle::autoflush + +=item backwards + +Sets the object to 'backwards' mode. All subsequent C operations will +read backwards from the end of the file. + +Requires the File::ReadBackwards CPAN module. + +=item binary + +Adds C<:raw> to the list of PerlIO layers applied after C, and applies +it immediately on an open handle. + +=item chdir + +chdir() to the pathname of a directory object. When object goes out of scope, +chdir back to starting directory. + +=item chomp + +Indicates that all operations that read lines should chomp the lines. If the +C method has been called, chomp will remove that value from the end +of each record. + +Note that C may cause the following idiom to halt prematurely (e.g., if +C is C<\n> (the default) and C is in effect, then this +command will stop reading at the first blank line): + + while ( my $line = $io->getline ) {...} + +Try the following instead: + + while ( defined(my $line = $io->getline) ) {...} + +=item confess + +Errors should be reported with the very detailed Carp::confess function. + +=item deep + +Indicates that calls to the C family of methods should search directories +as deep as possible. + +=item fork + +Indicates that the process should automatically be forked inside the C +socket method. + +=item lock + +Indicate that operations on an object should be locked using flock. + +=item rdonly + +This option indicates that certain operations like DBM and Tie::File access +should be done in read-only mode. + +=item rdwr + +This option indicates that DBM and MLDBM files should be opened in +read/write mode. + +=item relative + +Indicates that the C for the object should be made relative. If +passed an argument, path will be made relative to passed argument. + +=item sort + +Indicates whether objects returned from one of the C methods will be in +sorted order by name. True by default. + +=item tie + +Indicate that the object should be tied to itself, thus allowing it to be used +as a filehandle in any of Perl's builtin IO operations. + + my $io = io('foo')->tie; + @lines = <$io>; + +=item utf8 + +Adds C<:encoding(UTF-8)> to the list of PerlIO layers applied after C, +and applies it immediately on an open handle. + +=back + +=head2 Configuration Methods + +The following methods don't do any actual I/O, but they set specific values to +configure the IO::All object. + +If these methods are passed no argument, they will return their current value. +If arguments are passed they will be used to set the current value, and the +object reference will be returned for potential method chaining. + +=over + +=item bcc + +Set the Bcc field for a mailto object. + +=item binmode + +Adds the specified layer to the list of PerlIO layers applied after C, +and applies it immediately on an open handle. Does a bare C when +called without argument. + +=item block_size + +The default length to be used for C and C calls. +Defaults to 1024. + +=item buffer + +Returns a reference to the internal buffer, which is a scalar. You can use +this method to set the buffer to a scalar of your choice. (You can just pass +in the scalar, rather than a reference to it.) + +This is the buffer that C and C will use by default. + +You can easily have IO::All objects use the same buffer: + + my $input = io('abc'); + my $output = io('xyz'); + my $buffer; + $output->buffer($input->buffer($buffer)); + $output->write while $input->read; + +=item cc + +Set the Cc field for a mailto object. + +=item content + +Get or set the content for an LWP operation manually. + +=item domain + +Set the domain name or ip address that a socket should use. + +=item encoding + +Adds the specified encoding to the list of PerlIO layers applied after +C, and applies it immediately on an open handle. Requires an argument. + +=item errors + +Use this to set a subroutine reference that gets called when an internal error +is thrown. + +=item filter + +Use this to set a subroutine reference that will be used to grep which objects +get returned on a call to one of the C methods. For example: + + my @odd = io->curdir->filter(sub {$_->size % 2})->All_Files; + +C<@odd> will contain all the files under the current directory whose size is +an odd number of bytes. + +=item from + +Indicate the sender for a mailto object. + +=item mailer + +Set the mailer program for a mailto transaction. Defaults to 'sendmail'. + +=item mode + +Set the mode for which the file should be opened. Examples: + + $io->mode('>>')->open; + $io->mode(O_RDONLY); + + my $log_appender = io->file('/var/log/my-application.log') + ->mode('>>')->open(); + + $log_appender->print("Stardate 5987.6: Mission accomplished."); + +=item name + +Set or get the name of the file or directory represented by the IO::All +object. + +=item password + +Set the password for an LWP transaction. + +=item perms + +Sets the permissions to be used if the file/directory needs to be created. + +=item port + +Set the port number that a socket should use. + +=item request + +Manually specify the request object for an LWP transaction. + +=item response + +Returns the resulting response object from an LWP transaction. + +=item separator + +Sets the record (line) separator to whatever value you pass it. Default is +C<\n>. Affects the chomp setting too. + +=item string_ref + +Returns a reference to the internal string that is acting like a file. + +=item subject + +Set the subject for a mailto transaction. + +=item to + +Set the recipient address for a mailto request. + +=item uri + +Direct access to the URI used in LWP transactions. + +=item user + +Set the user name for an LWP transaction. + +=back + +=head2 IO Action Methods + +These are the methods that actually perform I/O operations on an IO::All +object. The stat methods and the File::Spec methods are documented in separate +sections below. + +=over + +=item accept + +For sockets. Opens a server socket (LISTEN => 1, REUSE => 1). Returns an +IO::All socket object that you are listening on. + +If the C method was called on the object, the process will automatically +be forked for every connection. + +=item all + +Read all contents into a single string. + + compare(io('file1')->all, io('file2')->all); + +=item all (For directories) + +Returns a list of IO::All objects for all files and subdirectories in a +directory. + +'.' and '..' are excluded. + +Takes an optional argument telling how many directories deep to search. The +default is 1. Zero (0) means search as deep as possible. + +The filter method can be used to limit the results. + +The items returned are sorted by name unless C<< ->sort(0) >> is used. + +=item All + +Same as C. + +=item all_dirs + +Same as C, but only return directories. + +=item All_Dirs + +Same as C. + +=item all_files + +Same as C, but only return files. + +=item All_Files + +Same as C. + +=item all_links + +Same as C, but only return links. + +=item All_Links + +Same as C. + +=item append + +Same as print, but sets the file mode to '>>'. + +=item appendf + +Same as printf, but sets the file mode to '>>'. + +=item appendln + +Same as println, but sets the file mode to '>>'. + +=item clear + +Clear the internal buffer. This method is called by C after it writes +the buffer. Returns the object reference for chaining. + +=item close + +Close will basically unopen the object, which has different meanings for +different objects. For files and directories it will close and release the +handle. For sockets it calls shutdown. For tied things it unties them, and it +unlocks locked things. + +=item copy + +Copies the object to the path passed. Works on both files and directories, but +directories require C to be installed. + +=item empty + +Returns true if a file exists but has no size, or if a directory exists but +has no contents. + +=item eof + +Proxy for IO::Handle::eof + +=item ext + +Returns the extension of the file. Can also be spelled as C + +=item exists + +Returns whether or not the file or directory exists. + +=item filename + +Return the name portion of the file path in the object. For example: + + io('my/path/file.txt')->filename; + +would return C. + +=item fileno + +Proxy for IO::Handle::fileno + +=item filepath + +Return the path portion of the file path in the object. For example: + + io('my/path/file.txt')->filepath; + +would return C. + +=item get + +Perform an LWP GET request manually. + +=item getc + +Proxy for IO::Handle::getc + +=item getline + +Calls IO::File::getline. You can pass in an optional record separator. + +=item getlines + +Calls IO::File::getlines. You can pass in an optional record separator. + +=item glob + +Creates IO::All objects for the files matching the glob in the IO::All::Dir. +For example: + + io->dir($ENV{HOME})->glob('*.txt') + +=item head + +Return the first 10 lines of a file. Takes an optional argument which is the +number of lines to return. Works as expected in list and scalar context. Is +subject to the current line separator. + +=item io_handle + +Direct access to the actual IO::Handle object being used on an opened +IO::All object. + +=item is_dir + +Returns boolean telling whether or not the IO::All object represents a +directory. + +=item is_executable + +Returns true if file or directory is executable. + +=item is_dbm + +Returns boolean telling whether or not the IO::All object represents a dbm +file. + +=item is_file + +Returns boolean telling whether or not the IO::All object represents a file. + +=item is_link + +Returns boolean telling whether or not the IO::All object represents a +symlink. + +=item is_mldbm + +Returns boolean telling whether or not the IO::All object represents a +mldbm file. + +=item is_open + +Indicates whether the IO::All is currently open for input/output. + +=item is_pipe + +Returns boolean telling whether or not the IO::All object represents a pipe +operation. + +=item is_readable + +Returns true if file or directory is readable. + +=item is_socket + +Returns boolean telling whether or not the IO::All object represents a socket. + +=item is_stdio + +Returns boolean telling whether or not the IO::All object represents a STDIO +file handle. + +=item is_string + +Returns boolean telling whether or not the IO::All object represents an in +memory filehandle. + +=item is_temp + +Returns boolean telling whether or not the IO::All object represents a +temporary file. + +=item is_writable + +Returns true if file or directory is writable. Can also be spelled as +C. + +=item length + +Return the length of the internal buffer. + +=item mimetype + +Return the mimetype of the file. + +Requires a working installation of the L CPAN module. + +=item mkdir + +Create the directory represented by the object. + +=item mkpath + +Create the directory represented by the object, when the path contains more +than one directory that doesn't exist. Proxy for File::Path::mkpath. + +=item next + +For a directory, this will return a new IO::All object for each file or +subdirectory in the directory. Return undef on EOD. + +=item open + +Open the IO::All object. Takes two optional arguments C and C, +which can also be set ahead of time using the C and C methods. + +NOTE: Normally you won't need to call open (or mode/perms), since this happens + automatically for most operations. + +=item os + +Change the object's os representation. Valid options are: C, C, +C, C, C. + +=item pathname + +Return the absolute or relative pathname for a file or directory, depending on +whether object is in C or C mode. + +=item print + +Proxy for IO::Handle::print + +=item printf + +Proxy for IO::Handle::printf + +=item println + +Same as print, but adds newline to each argument unless it already ends with +one. + +=item put + +Perform an LWP PUT request manually. + +=item read + +This method varies depending on its context. Read carefully (no pun intended). + +For a file, this will proxy IO::File::read. This means you must pass it a +buffer, a length to read, and optionally a buffer offset for where to put the +data that is read. The function returns the length actually read (which is +zero at EOF). + +If you don't pass any arguments for a file, IO::All will use its own internal +buffer, a default length, and the offset will always point at the end of the +buffer. The buffer can be accessed with the C method. The length can +be set with the C method. The default length is 1024 bytes. The +C method can be called to clear the buffer. + +For a directory, this will proxy IO::Dir::read. + +=item readdir + +Similar to the Perl C builtin. In scalar context, return the next +directory entry (ie file or directory name), or undef on end of directory. In +list context, return all directory entries. + +Note that C does not return the special C<.> and C<..> entries. + +=item readline + +Same as C. + +=item readlink + +Calls Perl's readlink function on the link represented by the object. +Instead of returning the file path, it returns a new IO::All object using +the file path. + +=item recv + +Proxy for IO::Socket::recv + +=item rename + + my $new = $io->rename('new-name'); + +Calls Perl's rename function and returns an IO::All object for the renamed +file. Returns false if the rename failed. + +=item rewind + +Proxy for IO::Dir::rewind + +=item rmdir + +Delete the directory represented by the IO::All object. + +=item rmtree + +Delete the directory represented by the IO::All object and all the files and +directories beneath it. Proxy for File::Path::rmtree. + +=item scalar + +Deprecated. Same as C. + +=item seek + +Proxy for IO::Handle::seek. If you use seek on an unopened file, it will be +opened for both read and write. + +=item send + +Proxy for IO::Socket::send + +=item shutdown + +Proxy for IO::Socket::shutdown + +=item slurp + +Read all file content in one operation. Returns the file content as a string. +In list context returns every line in the file. + +=item stat + +Proxy for IO::Handle::stat + +=item sysread + +Proxy for IO::Handle::sysread + +=item syswrite + +Proxy for IO::Handle::syswrite + +=item tail + +Return the last 10 lines of a file. Takes an optional argument which is the +number of lines to return. Works as expected in list and scalar context. Is +subject to the current line separator. + +=item tell + +Proxy for IO::Handle::tell + +=item throw + +This is an internal method that gets called whenever there is an error. It +could be useful to override it in a subclass, to provide more control in +error handling. + +=item touch + +Update the atime and mtime values for a file or directory. Creates an empty +file if the file does not exist. + +=item truncate + +Proxy for IO::Handle::truncate + +=item type + +Returns a string indicated the type of io object. Possible values are: + + file + dir + link + socket + string + pipe + +Returns undef if type is not determinable. + +=item unlink + +Unlink (delete) the file represented by the IO::All object. + +NOTE: You can unlink a file after it is open, and continue using it until it + is closed. + +=item unlock + +Release a lock from an object that used the C method. + +=item utime + +Proxy for the utime Perl function. + +=item write + +Opposite of C for file operations only. + +NOTE: When used with the automatic internal buffer, C will clear the + buffer after writing it. + +=back + +=head2 Stat Methods + +This methods get individual values from a stat call on the file, directory or +handle represented by the IO::All object. + +=over + +=item atime + +Last access time in seconds since the epoch + +=item blksize + +Preferred block size for file system I/O + +=item blocks + +Actual number of blocks allocated + +=item ctime + +Inode change time in seconds since the epoch + +=item device + +Device number of filesystem + +=item device_id + +Device identifier for special files only + +=item gid + +Numeric group id of file's owner + +=item inode + +Inode number + +=item modes + +File mode - type and permissions + +=item mtime + +Last modify time in seconds since the epoch + +=item nlink + +Number of hard links to the file + +=item size + +Total size of file in bytes + +=item uid + +Numeric user id of file's owner + +=back + +=head2 File::Spec Methods + +These methods are all adaptations from File::Spec. Each method actually does +call the matching File::Spec method, but the arguments and return values +differ slightly. Instead of being file and directory B, they are +IO::All B. Since IO::All objects stringify to their names, you can +generally use the methods just like File::Spec. + +=over + +=item abs2rel + +Returns the relative path for the absolute path in the IO::All object. Can +take an optional argument indicating the base path. + +=item canonpath + +Returns the canonical path for the IO::All object. The canonical path is the +fully resolved path if the file exists, so any symlinks will be resolved. + +=item case_tolerant + +Returns 0 or 1 indicating whether the file system is case tolerant. Since an +active IO::All object is not needed for this function, you can code it like: + + IO::All->case_tolerant; + +or more simply: + + io->case_tolerant; + +=item catdir + +Concatenate the directory components together, and return a new IO::All object +representing the resulting directory. + +=item catfile + +Concatenate the directory and file components together, and return a new +IO::All object representing the resulting file. + + my $contents = io->catfile(qw(dir subdir file))->slurp; + +This is a very portable way to read C. + +=item catpath + +Concatenate the volume, directory and file components together, and return a +new IO::All object representing the resulting file. + +=item curdir + +Returns an IO::All object representing the current directory. + +=item devnull + +Returns an IO::All object representing the C file. + +=item is_absolute + +Returns 0 or 1 indicating whether the C field of the IO::All object is +an absolute path. + +=item join + +Same as C. + +=item path + +Returns a list of IO::All directory objects for each directory in your path. + +=item rel2abs + +Returns the absolute path for the relative path in the IO::All object. Can +take an optional argument indicating the base path. + +=item rootdir + +Returns an IO::All object representing the root directory on your file system. + +=item splitdir + +Returns a list of the directory components of a path in an IO::All object. + +=item splitpath + +Returns a volume directory and file component of a path in an IO::All object. + +=item tmpdir + +Returns an IO::All object representing a temporary directory on your +file system. + +=item updir + +Returns an IO::All object representing the current parent directory. + +=back + +=head1 OPERATIONAL NOTES + +=over + +=item Reblessing + +Each IO::All object gets reblessed into an IO::All::* object as soon as +IO::All can determine what type of object it should be. Sometimes it gets +reblessed more than once: + + my $io = io('mydbm.db'); + $io->dbm('DB_File'); + $io->{foo} = 'bar'; + +In the first statement, $io has a reference value of 'IO::All::File', if +C exists. In the second statement, the object is reblessed into +class 'IO::All::DBM'. + +=item Auto-Open + +An IO::All object will automatically be opened as soon as there is enough +contextual information to know what type of object it is, and what mode it +should be opened for. This is usually when the first read or write operation +is invoked but might be sooner. + +=item Auto-Mode + +The mode for an object to be opened with is determined heuristically unless +specified explicitly. + +=item Auto-Close + +For input, IO::All objects will automatically be closed after EOF (or EOD). +For output, the object closes when it goes out of scope. + +To keep input objects from closing at EOF, do this: + + $io->autoclose(0); + +=item Explicit open and close + +You can always call C and C explicitly, if you need that level of +control. To test if an object is currently open, use the C method. + +=item Overload + +Overloaded operations return the target object, if one exists. + +This would set C<$xxx> to the IO::All object: + + my $xxx = $contents > io('file.txt'); + +While this would set C<$xxx> to the content string: + + my $xxx = $contents < io('file.txt'); + +=back + +=head1 STABILITY + +The goal of the IO::All project is to continually refine the module to be as +simple and consistent to use as possible. Therefore, in the early stages of +the project, I will not hesitate to break backwards compatibility with other +versions of IO::All if I can find an easier and clearer way to do a +particular thing. + +IO is tricky stuff. There is definitely more work to be done. On the other +hand, this module relies heavily on very stable existing IO modules; so it may +work fairly well. + +I am sure you will find many unexpected "features". Please send all problems, +ideas and suggestions to ingy@cpan.org. + +=head2 Known Bugs and Deficiencies + +Not all possible combinations of objects and methods have been tested. There +are many many combinations. All of the examples have been tested. If you find +a bug with a particular combination of calls, let me know. + +If you call a method that does not make sense for a particular object, the +result probably won't make sense. Little attempt is made to check for +improper usage. + +=head1 CREDITS + +A lot of people have sent in suggestions, that have become a part of IO::All. +Thank you. + +Special thanks to Ian Langworth for continued testing and patching. + +Thank you Simon Cozens for tipping me off to the overloading possibilities. + +Finally, thanks to Autrijus Tang, for always having one more good idea. + +(It seems IO::All of it to a lot of people!) + +=head1 REPOSITORY AND COMMUNITY + +The IO::All module can be found on CPAN and on GitHub: +L. + +Please join the IO::All discussion on #io-all on irc.perl.org. + +=head1 SEE ALSO + +=over + +=item * L + +=item * L + +=item * L + +=item * L + +=item * L + +=item * L + +=item * L + +=item * L + +=item * L + +=back + +=head1 AUTHOR + +Ingy döt Net + +=head1 COPYRIGHT AND LICENSE + +Copyright 2004-2017. Ingy döt Net. + +This program is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +See L + +=cut diff --git a/lib/lib/IO/All/Base.pm b/lib/lib/IO/All/Base.pm new file mode 100644 index 0000000..43a3252 --- /dev/null +++ b/lib/lib/IO/All/Base.pm @@ -0,0 +1,196 @@ +use strict; use warnings; +package IO::All::Base; + +use Fcntl; + +sub import { + my $class = shift; + my $flag = $_[0] || ''; + my $package = caller; + no strict 'refs'; + if ($flag eq '-base') { + push @{$package . "::ISA"}, $class; + *{$package . "::$_"} = \&$_ + for qw'field const option chain proxy proxy_open'; + } + elsif ($flag eq -mixin) { + mixin_import(scalar(caller(0)), $class, @_); + } + else { + my @flags = @_; + for my $export (@{$class . '::EXPORT'}) { + *{$package . "::$export"} = $export eq 'io' + ? $class->_generate_constructor(@flags) + : \&{$class . "::$export"}; + } + } +} + +sub _generate_constructor { + my $class = shift; + my (@flags, %flags, $key); + for (@_) { + if (s/^-//) { + push @flags, $_; + $flags{$_} = 1; + $key = $_; + } + else { + $flags{$key} = $_ if $key; + } + } + my $constructor; + $constructor = sub { + my $self = $class->new(@_); + for (@flags) { + $self->$_($flags{$_}); + } + $self->_constructor($constructor); + return $self; + } +} + +sub _init { + my $self = shift; + $self->io_handle(undef); + $self->is_open(0); + return $self; +} + +#=============================================================================== +# Closure generating functions +#=============================================================================== +sub option { + my $package = caller; + my ($field, $default) = @_; + $default ||= 0; + field("_$field", $default); + no strict 'refs'; + *{"${package}::$field"} = + sub { + my $self = shift; + *$self->{"_$field"} = @_ ? shift(@_) : 1; + return $self; + }; +} + +sub chain { + my $package = caller; + my ($field, $default) = @_; + no strict 'refs'; + *{"${package}::$field"} = + sub { + my $self = shift; + if (@_) { + *$self->{$field} = shift; + return $self; + } + return $default unless exists *$self->{$field}; + return *$self->{$field}; + }; +} + +sub field { + my $package = caller; + my ($field, $default) = @_; + no strict 'refs'; + return if defined &{"${package}::$field"}; + *{"${package}::$field"} = + sub { + my $self = shift; + unless (exists *$self->{$field}) { + *$self->{$field} = + ref($default) eq 'ARRAY' ? [] : + ref($default) eq 'HASH' ? {} : + $default; + } + return *$self->{$field} unless @_; + *$self->{$field} = shift; + }; +} + +sub const { + my $package = caller; + my ($field, $default) = @_; + no strict 'refs'; + return if defined &{"${package}::$field"}; + *{"${package}::$field"} = sub { $default }; +} + +sub proxy { + my $package = caller; + my ($proxy) = @_; + no strict 'refs'; + return if defined &{"${package}::$proxy"}; + *{"${package}::$proxy"} = + sub { + my $self = shift; + my @return = $self->io_handle->$proxy(@_); + $self->_error_check; + wantarray ? @return : $return[0]; + }; +} + +sub proxy_open { + my $package = caller; + my ($proxy, @args) = @_; + no strict 'refs'; + return if defined &{"${package}::$proxy"}; + my $method = sub { + my $self = shift; + $self->_assert_open(@args); + my @return = $self->io_handle->$proxy(@_); + $self->_error_check; + wantarray ? @return : $return[0]; + }; + *{"$package\::$proxy"} = + (@args and $args[0] eq '>') ? + sub { + my $self = shift; + $self->$method(@_); + return $self; + } + : $method; +} + +sub mixin_import { + my $target_class = shift; + $target_class = caller(0) + if $target_class eq 'mixin'; + my $mixin_class = shift + or die "Nothing to mixin"; + eval "require $mixin_class"; + my $pseudo_class = CORE::join '-', $target_class, $mixin_class; + my %methods = mixin_methods($mixin_class); + no strict 'refs'; + no warnings; + @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"}; + @{"$target_class\::ISA"} = ($pseudo_class); + for (keys %methods) { + *{"$pseudo_class\::$_"} = $methods{$_}; + } +} + +sub mixin_methods { + my $mixin_class = shift; + no strict 'refs'; + my %methods = all_methods($mixin_class); + map { + $methods{$_} + ? ($_, \ &{"$methods{$_}\::$_"}) + : ($_, \ &{"$mixin_class\::$_"}) + } (keys %methods); +} + +sub all_methods { + no strict 'refs'; + my $class = shift; + my %methods = map { + ($_, $class) + } grep { + defined &{"$class\::$_"} and not /^_/ + } keys %{"$class\::"}; + return (%methods); +} + +1; diff --git a/lib/lib/IO/All/DBM.pm b/lib/lib/IO/All/DBM.pm new file mode 100644 index 0000000..a2f5a58 --- /dev/null +++ b/lib/lib/IO/All/DBM.pm @@ -0,0 +1,92 @@ +use strict; use warnings; +package IO::All::DBM; + +use IO::All::File -base; +use Fcntl; + +field _dbm_list => []; +field '_dbm_class'; +field _dbm_extra => []; + +sub dbm { + my $self = shift; + bless $self, __PACKAGE__; + $self->_dbm_list([@_]); + return $self; +} + +sub _assert_open { + my $self = shift; + return $self->tied_file + if $self->tied_file; + $self->open; +} + +sub assert_filepath { + my $self = shift; + $self->SUPER::assert_filepath(@_); + if ($self->_rdonly and not -e $self->pathname) { + my $rdwr = $self->_rdwr; + $self->assert(0)->rdwr(1)->rdonly(0)->open; + $self->close; + $self->assert(1)->rdwr($rdwr)->rdonly(1); + } +} + +sub open { + my $self = shift; + $self->is_open(1); + return $self->tied_file if $self->tied_file; + $self->assert_filepath if $self->_assert; + my $dbm_list = $self->_dbm_list; + my @dbm_list = @$dbm_list ? @$dbm_list : + (qw(DB_File GDBM_File NDBM_File ODBM_File SDBM_File)); + my $dbm_class; + for my $module (@dbm_list) { + (my $file = "$module.pm") =~ s{::}{/}g; + if (defined $INC{$file} || eval "eval 'use $module; 1'") { + $self->_dbm_class($module); + last; + } + } + $self->throw("No module available for IO::All DBM operation") + unless defined $self->_dbm_class; + my $mode = $self->_rdonly ? O_RDONLY : O_RDWR; + if ($self->_dbm_class eq 'DB_File::Lock') { + $self->_dbm_class->import; + my $type = eval '$DB_HASH'; die $@ if $@; + # XXX Not sure about this warning + warn "Using DB_File::Lock in IO::All without the rdonly or rdwr method\n" + if not ($self->_rdwr or $self->_rdonly); + my $flag = $self->_rdwr ? 'write' : 'read'; + $mode = $self->_rdwr ? O_RDWR : O_RDONLY; + $self->_dbm_extra([$type, $flag]); + } + $mode |= O_CREAT if $mode & O_RDWR; + $self->mode($mode); + $self->perms(0666) unless defined $self->perms; + return $self->tie_dbm; +} + +sub tie_dbm { + my $self = shift; + my $hash; + my $filename = $self->name; + my $db = tie %$hash, $self->_dbm_class, $filename, $self->mode, $self->perms, + @{$self->_dbm_extra} + or $self->throw("Can't open '$filename' as DBM file:\n$!"); + $self->add_utf8_dbm_filter($db) + if $self->_has_utf8; + $self->tied_file($hash); +} + +sub add_utf8_dbm_filter { + my $self = shift; + my $db = shift; + $db->filter_store_key(sub { utf8::encode($_) }); + $db->filter_store_value(sub { utf8::encode($_) }); + $db->filter_fetch_key(sub { utf8::decode($_) }); + $db->filter_fetch_value(sub { utf8::decode($_) }); +} + +1; diff --git a/lib/lib/IO/All/DBM.pod b/lib/lib/IO/All/DBM.pod new file mode 100644 index 0000000..e65898c --- /dev/null +++ b/lib/lib/IO/All/DBM.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::DBM - DBM Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/Dir.pm b/lib/lib/IO/All/Dir.pm new file mode 100644 index 0000000..4a23976 --- /dev/null +++ b/lib/lib/IO/All/Dir.pm @@ -0,0 +1,260 @@ +use strict; use warnings; +package IO::All::Dir; + +use Scalar::Util 'blessed'; +use File::Glob 'bsd_glob'; +use IO::All::Filesys -base; +use IO::All -base; +use IO::Dir; + +#=============================================================================== +const type => 'dir'; +option 'sort' => 1; +chain filter => undef; +option 'deep'; +field 'chdir_from'; + +#=============================================================================== +sub dir { + my $self = shift; + my $had_prev = blessed($self) && $self->pathname; + + bless $self, __PACKAGE__ unless $had_prev; + if (@_ && @_ > 1 || @_ && $had_prev) { + $self->name( + $self->_spec_class->catdir( + ($self->pathname ? ($self->pathname) : () ), + @_, + ) + ) + } elsif (@_) { + $self->name($_[0]) + } + return $self->_init; +} + +sub dir_handle { + my $self = shift; + bless $self, __PACKAGE__; + $self->_handle(shift) if @_; + return $self->_init; +} + +#=============================================================================== +sub _assert_open { + my $self = shift; + return if $self->is_open; + $self->open; +} + +sub open { + my $self = shift; + $self->is_open(1); + $self->_assert_dirpath($self->pathname) + if $self->pathname and $self->_assert; + my $handle = IO::Dir->new; + $self->io_handle($handle); + $handle->open($self->pathname) + or $self->throw($self->open_msg); + return $self; +} + +sub open_msg { + my $self = shift; + my $name = defined $self->pathname + ? " '" . $self->pathname . "'" + : ''; + return qq{Can't open directory$name:\n$!}; +} + +sub exists { -d shift->pathname } + +#=============================================================================== +sub All { + my $self = shift; + $self->all(0); +} + +sub all { + my $self = shift; + my $depth = @_ ? shift(@_) : $self->_deep ? 0 : 1; + my $first = not @_; + my @all; + while (my $io = $self->next) { + push @all, $io; + push(@all, $io->all($depth - 1, 1)) + if $depth != 1 and $io->is_dir; + } + @all = grep {&{$self->filter}} @all + if $self->filter; + return @all unless $first and $self->_sort; + return sort {$a->pathname cmp $b->pathname} @all; +} + +sub All_Dirs { + my $self = shift; + $self->all_dirs(0); +} + +sub all_dirs { + my $self = shift; + grep {$_->is_dir} $self->all(@_); +} + +sub All_Files { + my $self = shift; + $self->all_files(0); +} + +sub all_files { + my $self = shift; + grep {$_->is_file} $self->all(@_); +} + +sub All_Links { + my $self = shift; + $self->all_links(0); +} + +sub all_links { + my $self = shift; + grep {$_->is_link} $self->all(@_); +} + +sub chdir { + my $self = shift; + require Cwd; + $self->chdir_from(Cwd::cwd()); + CORE::chdir($self->pathname); + return $self; +} + +sub empty { + my $self = shift; + my $dh; + opendir($dh, $self->pathname) or die; + while (my $dir = readdir($dh)) { + return 0 unless $dir =~ /^\.{1,2}$/; + } + return 1; +} + +sub mkdir { + my $self = shift; + defined($self->perms) + ? (CORE::mkdir($self->pathname, $self->perms) or die "mkdir failed: $!") + : (CORE::mkdir($self->pathname) or die "mkdir failed: $!"); + return $self; +} + +sub mkpath { + my $self = shift; + require File::Path; + File::Path::mkpath($self->pathname, @_); + return $self; +} + +sub file { + my ($self, @rest) = @_; + + return $self->_constructor->()->file($self->pathname, @rest) +} + +sub next { + my $self = shift; + $self->_assert_open; + my $name = $self->readdir; + return unless defined $name; + my $io = $self->_constructor->(File::Spec->catfile($self->pathname, $name)); + $io->absolute if $self->is_absolute; + return $io; +} + +sub readdir { + my $self = shift; + $self->_assert_open; + if (wantarray) { + my @return = grep { + not /^\.{1,2}$/ + } $self->io_handle->read; + $self->close; + if ($self->_has_utf8) { utf8::decode($_) for (@return) } + return @return; + } + my $name = '.'; + while ($name =~ /^\.{1,2}$/) { + $name = $self->io_handle->read; + unless (defined $name) { + $self->close; + return; + } + } + if ($self->_has_utf8) { utf8::decode($name) } + return $name; +} + +sub rmdir { + my $self = shift; + rmdir $self->pathname; +} + +sub rmtree { + my $self = shift; + require File::Path; + File::Path::rmtree($self->pathname, @_); +} + +sub glob { + my ($self, @rest) = @_; + + map {; + my $ret = $self->_constructor->($_); + $ret->absolute if $self->is_absolute; + $ret + } bsd_glob $self->_spec_class->catdir( $self->pathname, @rest ); +} + +sub copy { + my ($self, $new) = @_; + + require File::Copy::Recursive; + + File::Copy::Recursive::dircopy($self->name, $new) + or die "failed to copy $self to $new: $!"; + $self->_constructor->($new) +} + +sub DESTROY { + my $self = shift; + CORE::chdir($self->chdir_from) + if $self->chdir_from; + # $self->SUPER::DESTROY(@_); +} + +#=============================================================================== +sub _overload_table { + ( + '${} dir' => '_overload_as_scalar', + '@{} dir' => '_overload_as_array', + '%{} dir' => '_overload_as_hash', + ) +} + +sub _overload_as_scalar { + \ $_[1]; +} + +sub _overload_as_array { + [ $_[1]->all ]; +} + +sub _overload_as_hash { + +{ + map { + (my $name = $_->pathname) =~ s/.*[\/\\]//; + ($name, $_); + } $_[1]->all + }; +} + +1; diff --git a/lib/lib/IO/All/Dir.pod b/lib/lib/IO/All/Dir.pod new file mode 100644 index 0000000..05c8280 --- /dev/null +++ b/lib/lib/IO/All/Dir.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::Dir - Directory Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/File.pm b/lib/lib/IO/All/File.pm new file mode 100644 index 0000000..917bb53 --- /dev/null +++ b/lib/lib/IO/All/File.pm @@ -0,0 +1,267 @@ +use strict; use warnings; +package IO::All::File; + +use IO::All::Filesys -base; +use IO::All -base; +use IO::File; +use File::Copy (); + +#=============================================================================== +const type => 'file'; +field tied_file => undef; + +#=============================================================================== +sub file { + my $self = shift; + bless $self, __PACKAGE__; + # should we die here if $self->name is already set and there are args? + if (@_ && @_ > 1) { + $self->name( $self->_spec_class->catfile( @_ ) ) + } elsif (@_) { + $self->name($_[0]) + } + return $self->_init; +} + +sub file_handle { + my $self = shift; + bless $self, __PACKAGE__; + $self->_handle(shift) if @_; + return $self->_init; +} + +#=============================================================================== +sub assert_filepath { + my $self = shift; + my $name = $self->pathname + or return; + my $directory; + (undef, $directory) = File::Spec->splitpath($self->pathname); + $self->_assert_dirpath($directory); +} + +sub assert_open_backwards { + my $self = shift; + return if $self->is_open; + require File::ReadBackwards; + my $file_name = $self->pathname; + my $io_handle = File::ReadBackwards->new($file_name) + or $self->throw("Can't open $file_name for backwards:\n$!"); + $self->io_handle($io_handle); + $self->is_open(1); +} + +sub _assert_open { + my $self = shift; + return if $self->is_open; + $self->mode(shift) unless $self->mode; + $self->open; +} + +sub assert_tied_file { + my $self = shift; + return $self->tied_file || do { + eval {require Tie::File}; + $self->throw("Tie::File required for file array operations:\n$@") + if $@; + my $array_ref = do { my @array; \@array }; + my $name = $self->pathname; + my @options = $self->_rdonly ? (mode => O_RDONLY) : (); + push @options, (recsep => $self->separator); + tie @$array_ref, 'Tie::File', $name, @options; + $self->throw("Can't tie 'Tie::File' to '$name':\n$!") + unless tied @$array_ref; + $self->tied_file($array_ref); + }; +} + +sub open { + my $self = shift; + $self->is_open(1); + $self->assert_filepath if $self->_assert; + my ($mode, $perms) = @_; + $self->mode($mode) if defined $mode; + $self->mode('<') unless defined $self->mode; + $self->perms($perms) if defined $perms; + my @args = ($self->mode); + push @args, $self->perms if defined $self->perms; + if (defined $self->pathname) { + $self->io_handle(IO::File->new); + $self->io_handle->open($self->pathname, @args) + or $self->throw($self->open_msg); + } + elsif (defined $self->_handle and + not $self->io_handle->opened + ) { + # XXX Not tested + $self->io_handle->fdopen($self->_handle, @args); + } + $self->set_lock; + $self->_set_binmode; +} + +sub exists { -f shift->pathname } + +my %mode_msg = ( + '>' => 'output', + '<' => 'input', + '>>' => 'append', +); +sub open_msg { + my $self = shift; + my $name = defined $self->pathname + ? " '" . $self->pathname . "'" + : ''; + my $direction = defined $mode_msg{$self->mode} + ? ' for ' . $mode_msg{$self->mode} + : ''; + return qq{Can't open file$name$direction:\n$!}; +} + +#=============================================================================== +sub copy { + my ($self, $new) = @_; + + File::Copy::copy($self->name, $new) + or die "failed to copy $self to $new: $!"; + $self->file($new) +} + +sub close { + my $self = shift; + return unless $self->is_open; + $self->is_open(0); + my $io_handle = $self->io_handle; + $self->unlock; + $self->io_handle(undef); + $self->mode(undef); + if (my $tied_file = $self->tied_file) { + if (ref($tied_file) eq 'ARRAY') { + untie @$tied_file; + } + else { + untie %$tied_file; + } + $self->tied_file(undef); + return 1; + } + $io_handle->close(@_) + if defined $io_handle; + return $self; +} + +sub empty { + my $self = shift; + -z $self->pathname; +} + +sub filepath { + my $self = shift; + my ($volume, $path) = $self->splitpath; + return File::Spec->catpath($volume, $path, ''); +} + +sub getline_backwards { + my $self = shift; + $self->assert_open_backwards; + return $self->io_handle->readline; +} + +sub getlines_backwards { + my $self = shift; + my @lines; + while (defined (my $line = $self->getline_backwards)) { + push @lines, $line; + } + return @lines; +} + +sub head { + my $self = shift; + my $lines = shift || 10; + my @return; + $self->close; + + LINES: + while ($lines--) { + if (defined (my $l = $self->getline)) { + push @return, $l; + } + else { + last LINES; + } + } + + $self->close; + return wantarray ? @return : join '', @return; +} + +sub tail { + my $self = shift; + my $lines = shift || 10; + my @return; + $self->close; + while ($lines--) { + unshift @return, ($self->getline_backwards or last); + } + $self->close; + return wantarray ? @return : join '', @return; +} + +sub touch { + my $self = shift; + return $self->SUPER::touch(@_) + if -e $self->pathname; + return $self if $self->is_open; + my $mode = $self->mode; + $self->mode('>>')->open->close; + $self->mode($mode); + return $self; +} + +sub unlink { + my $self = shift; + unlink $self->pathname; +} + +#=============================================================================== +sub _overload_table { + my $self = shift; + ( + $self->SUPER::_overload_table(@_), + 'file > file' => '_overload_file_to_file', + 'file < file' => '_overload_file_from_file', + '${} file' => '_overload_file_as_scalar', + '@{} file' => '_overload_file_as_array', + '%{} file' => '_overload_file_as_dbm', + ) +} + +sub _overload_file_to_file { + require File::Copy; + File::Copy::copy($_[1]->pathname, $_[2]->pathname); + $_[2]; +} + +sub _overload_file_from_file { + require File::Copy; + File::Copy::copy($_[2]->pathname, $_[1]->pathname); + $_[1]; +} + +sub _overload_file_as_array { + $_[1]->assert_tied_file; +} + +sub _overload_file_as_dbm { + $_[1]->dbm + unless $_[1]->isa('IO::All::DBM'); + $_[1]->_assert_open; +} + +sub _overload_file_as_scalar { + my $scalar = $_[1]->scalar; + return \$scalar; +} + +1; diff --git a/lib/lib/IO/All/File.pod b/lib/lib/IO/All/File.pod new file mode 100644 index 0000000..f75b902 --- /dev/null +++ b/lib/lib/IO/All/File.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::File - File Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/Filesys.pm b/lib/lib/IO/All/Filesys.pm new file mode 100644 index 0000000..ed49384 --- /dev/null +++ b/lib/lib/IO/All/Filesys.pm @@ -0,0 +1,133 @@ +use strict; use warnings; +package IO::All::Filesys; + +use IO::All::Base -base; +use Fcntl qw(:flock); + +my %spec_map = ( + unix => 'Unix', + win32 => 'Win32', + vms => 'VMS', + mac => 'Mac', + os2 => 'OS2', +); +sub os { + my ($self, $type) = @_; + + my ($v, $d, $f) = $self->_spec_class->splitpath($self->name); + my @d = $self->_spec_class->splitdir($d); + + $self->_spec_class($spec_map{$type}); + + $self->name( $self->_spec_class->catfile( @d, $f ) ); + + return $self +} + +sub exists { my $self = shift; -e $self->name } + +sub filename { + my $self = shift; + my $filename; + (undef, undef, $filename) = $self->splitpath; + return $filename; +} + +sub ext { + my $self = shift; + + return $1 if $self->filename =~ m/\.([^\.]+)$/ +} +{ + no warnings 'once'; + *extension = \&ext; +} + +sub mimetype { + require File::MimeInfo; + return File::MimeInfo::mimetype($_[0]->filename) +} + +sub is_absolute { + my $self = shift; + return *$self->{is_absolute} = shift if @_; + return *$self->{is_absolute} + if defined *$self->{is_absolute}; + *$self->{is_absolute} = IO::All::is_absolute($self) ? 1 : 0; +} + +sub is_executable { my $self = shift; -x $self->name } +sub is_readable { my $self = shift; -r $self->name } +sub is_writable { my $self = shift; -w $self->name } +{ + no warnings 'once'; + *is_writeable = \&is_writable; +} + +sub pathname { + my $self = shift; + return *$self->{pathname} = shift if @_; + return *$self->{pathname} if defined *$self->{pathname}; + return $self->name; +} + +sub relative { + my $self = shift; + if (my $base = $_[0]) { + $self->pathname(File::Spec->abs2rel($self->pathname, $base)) + } elsif ($self->is_absolute) { + $self->pathname(File::Spec->abs2rel($self->pathname)) + } + $self->is_absolute(0); + return $self; +} + +sub rename { + my $self = shift; + my $new = shift; + rename($self->name, "$new") + ? UNIVERSAL::isa($new, 'IO::All') + ? $new + : $self->_constructor->($new) + : undef; +} + +sub set_lock { + my $self = shift; + return unless $self->_lock; + my $io_handle = $self->io_handle; + my $flag = $self->mode =~ /^>>?$/ + ? LOCK_EX + : LOCK_SH; + flock $io_handle, $flag; +} + +sub stat { + my $self = shift; + return IO::All::stat($self, @_) + if $self->is_open; + CORE::stat($self->pathname); +} + +sub touch { + my $self = shift; + $self->utime; +} + +sub unlock { + my $self = shift; + flock $self->io_handle, LOCK_UN + if $self->_lock; +} + +sub utime { + my $self = shift; + my $atime = shift; + my $mtime = shift; + $atime = time unless defined $atime; + $mtime = $atime unless defined $mtime; + utime($atime, $mtime, $self->name); + return $self; +} + +1; diff --git a/lib/lib/IO/All/Filesys.pod b/lib/lib/IO/All/Filesys.pod new file mode 100644 index 0000000..553f3d6 --- /dev/null +++ b/lib/lib/IO/All/Filesys.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::Filesys - File System Methods Mixin for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/Link.pm b/lib/lib/IO/All/Link.pm new file mode 100644 index 0000000..c6dc71b --- /dev/null +++ b/lib/lib/IO/All/Link.pm @@ -0,0 +1,58 @@ +use strict; use warnings; +package IO::All::Link; + +use IO::All::File -base; + +const type => 'link'; + +sub link { + my $self = shift; + bless $self, __PACKAGE__; + $self->name(shift) if @_; + $self->_init; +} + +sub readlink { + my $self = shift; + $self->_constructor->(CORE::readlink($self->name)); +} + +sub symlink { + my $self = shift; + my $target = shift; + $self->assert_filepath if $self->_assert; + CORE::symlink($target, $self->pathname); +} + +sub AUTOLOAD { + my $self = shift; + our $AUTOLOAD; + (my $method = $AUTOLOAD) =~ s/.*:://; + my $target = $self->target; + unless ($target) { + $self->throw("Can't call $method on symlink"); + return; + } + $target->$method(@_); +} + +sub target { + my $self = shift; + return *$self->{target} if *$self->{target}; + my %seen; + my $link = $self; + my $new; + while ($new = $link->readlink) { + my $type = $new->type or return; + last if $type eq 'file'; + last if $type eq 'dir'; + return unless $type eq 'link'; + return if $seen{$new->name}++; + $link = $new; + } + *$self->{target} = $new; +} + +sub exists { -l shift->pathname } + +1; diff --git a/lib/lib/IO/All/Link.pod b/lib/lib/IO/All/Link.pod new file mode 100644 index 0000000..f22ef9c --- /dev/null +++ b/lib/lib/IO/All/Link.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::Link - Link Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/MLDBM.pm b/lib/lib/IO/All/MLDBM.pm new file mode 100644 index 0000000..73c39bd --- /dev/null +++ b/lib/lib/IO/All/MLDBM.pm @@ -0,0 +1,34 @@ +use strict; use warnings; +package IO::All::MLDBM; + +use IO::All::DBM -base; + +field _serializer => 'Data::Dumper'; + +sub mldbm { + my $self = shift; + bless $self, __PACKAGE__; + my ($serializer) = grep { /^(Storable|Data::Dumper|FreezeThaw)$/ } @_; + $self->_serializer($serializer) if defined $serializer; + my @dbm_list = grep { not /^(Storable|Data::Dumper|FreezeThaw)$/ } @_; + $self->_dbm_list([@dbm_list]); + return $self; +} + +sub tie_dbm { + my $self = shift; + my $filename = $self->name; + my $dbm_class = $self->_dbm_class; + my $serializer = $self->_serializer; + eval "use MLDBM qw($dbm_class $serializer)"; + $self->throw("Can't open '$filename' as MLDBM:\n$@") if $@; + my $hash; + my $db = tie %$hash, 'MLDBM', $filename, $self->mode, $self->perms, + @{$self->_dbm_extra} + or $self->throw("Can't open '$filename' as MLDBM file:\n$!"); + $self->add_utf8_dbm_filter($db) + if $self->_has_utf8; + $self->tied_file($hash); +} + +1; diff --git a/lib/lib/IO/All/MLDBM.pod b/lib/lib/IO/All/MLDBM.pod new file mode 100644 index 0000000..c3bcb7c --- /dev/null +++ b/lib/lib/IO/All/MLDBM.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::MLDBM - MLDBM Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/Pipe.pm b/lib/lib/IO/All/Pipe.pm new file mode 100644 index 0000000..0775626 --- /dev/null +++ b/lib/lib/IO/All/Pipe.pm @@ -0,0 +1,56 @@ +use strict; use warnings; +package IO::All::Pipe; + +use IO::All -base; +use IO::File; + +const type => 'pipe'; + +sub pipe { + my $self = shift; + bless $self, __PACKAGE__; + $self->name(shift) if @_; + return $self->_init; +} + +sub _assert_open { + my $self = shift; + return if $self->is_open; + $self->mode(shift) unless $self->mode; + $self->open; +} + +sub open { + my $self = shift; + $self->is_open(1); + require IO::Handle; + $self->io_handle(IO::Handle->new) + unless defined $self->io_handle; + my $command = $self->name; + $command =~ s/(^\||\|$)//; + my $mode = shift || $self->mode || '<'; + my $pipe_mode = + $mode eq '>' ? '|-' : + $mode eq '<' ? '-|' : + $self->throw("Invalid usage mode '$mode' for pipe"); + CORE::open($self->io_handle, $pipe_mode, $command); + $self->_set_binmode; +} + +my %mode_msg = ( + '>' => 'output', + '<' => 'input', + '>>' => 'append', +); +sub open_msg { + my $self = shift; + my $name = defined $self->name + ? " '" . $self->name . "'" + : ''; + my $direction = defined $mode_msg{$self->mode} + ? ' for ' . $mode_msg{$self->mode} + : ''; + return qq{Can't open pipe$name$direction:\n$!}; +} + +1; diff --git a/lib/lib/IO/All/Pipe.pod b/lib/lib/IO/All/Pipe.pod new file mode 100644 index 0000000..94341c8 --- /dev/null +++ b/lib/lib/IO/All/Pipe.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::Pipe - Pipe Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/STDIO.pm b/lib/lib/IO/All/STDIO.pm new file mode 100644 index 0000000..2d63b27 --- /dev/null +++ b/lib/lib/IO/All/STDIO.pm @@ -0,0 +1,54 @@ +use strict; use warnings; +package IO::All::STDIO; + +use IO::All -base; +use IO::File; + +const type => 'stdio'; + +sub stdio { + my $self = shift; + bless $self, __PACKAGE__; + return $self->_init; +} + +sub stdin { + my $self = shift; + $self->open('<'); + return $self; +} + +sub stdout { + my $self = shift; + $self->open('>'); + return $self; +} + +sub stderr { + my $self = shift; + $self->open_stderr; + return $self; +} + +sub open { + my $self = shift; + $self->is_open(1); + my $mode = shift || $self->mode || '<'; + my $fileno = $mode eq '>' + ? fileno(STDOUT) + : fileno(STDIN); + $self->io_handle(IO::File->new); + $self->io_handle->fdopen($fileno, $mode); + $self->_set_binmode; +} + +sub open_stderr { + my $self = shift; + $self->is_open(1); + $self->io_handle(IO::File->new); + $self->io_handle->fdopen(fileno(STDERR), '>') ? $self : 0; +} + +# XXX Add overload support + +1; diff --git a/lib/lib/IO/All/STDIO.pod b/lib/lib/IO/All/STDIO.pod new file mode 100644 index 0000000..29e0f7e --- /dev/null +++ b/lib/lib/IO/All/STDIO.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::STDIO - STDIO Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/Socket.pm b/lib/lib/IO/All/Socket.pm new file mode 100644 index 0000000..52b8917 --- /dev/null +++ b/lib/lib/IO/All/Socket.pm @@ -0,0 +1,142 @@ +use strict; use warnings; +package IO::All::Socket; + +use IO::All -base; +use IO::Socket; + +const type => 'socket'; +field _listen => undef; +option 'fork'; +const domain_default => 'localhost'; +chain domain => undef; +chain port => undef; +proxy_open 'recv'; +proxy_open 'send'; + +sub socket { + my $self = shift; + bless $self, __PACKAGE__; + $self->name(shift) if @_; + return $self->_init; +} + +sub socket_handle { + my $self = shift; + bless $self, __PACKAGE__; + $self->_handle(shift) if @_; + return $self->_init; +} + +sub accept { + my $self = shift; + use POSIX ":sys_wait_h"; + sub REAPER { + while (waitpid(-1, WNOHANG) > 0) {} + $SIG{CHLD} = \&REAPER; + } + local $SIG{CHLD}; + $self->_listen(1); + $self->_assert_open; + my $server = $self->io_handle; + my $socket; + while (1) { + $socket = $server->accept; + last unless $self->_fork; + next unless defined $socket; + $SIG{CHLD} = \&REAPER; + my $pid = CORE::fork; + $self->throw("Unable to fork for IO::All::accept") + unless defined $pid; + last unless $pid; + close $socket; + undef $socket; + } + close $server if $self->_fork; + my $io = ref($self)->new->socket_handle($socket); + $io->io_handle($socket); + $io->is_open(1); + return $io; +} + +sub shutdown { + my $self = shift; + my $how = @_ ? shift : 2; + my $handle = $self->io_handle; + $handle->shutdown(2) + if defined $handle; +} + +sub _assert_open { + my $self = shift; + return if $self->is_open; + $self->mode(shift) unless $self->mode; + $self->open; +} + +sub open { + my $self = shift; + return if $self->is_open; + $self->is_open(1); + $self->get_socket_domain_port; + my @args = $self->_listen + ? ( + LocalAddr => $self->domain, + LocalPort => $self->port, + Proto => 'tcp', + Listen => 1, + Reuse => 1, + ) + : ( + PeerAddr => $self->domain, + PeerPort => $self->port, + Proto => 'tcp', + ); + my $socket = IO::Socket::INET->new(@args) + or $self->throw("Can't open socket"); + $self->io_handle($socket); + $self->_set_binmode; +} + +sub get_socket_domain_port { + my $self = shift; + my ($domain, $port); + ($domain, $port) = split /:/, $self->name + if defined $self->name; + $self->domain($domain) unless defined $self->domain; + $self->domain($self->domain_default) unless $self->domain; + $self->port($port) unless defined $self->port; + return $self; +} + +sub _overload_table { + my $self = shift; + ( + $self->SUPER::_overload_table(@_), + '&{} socket' => '_overload_socket_as_code', + ) +} + +sub _overload_socket_as_code { + my $self = shift; + sub { + my $coderef = shift; + while ($self->is_open) { + $_ = $self->getline; + &$coderef($self); + } + } +} + +sub _overload_any_from_any { + my $self = shift; + $self->SUPER::_overload_any_from_any(@_); + $self->close; +} + +sub _overload_any_to_any { + my $self = shift; + $self->SUPER::_overload_any_to_any(@_); + $self->close; +} + +1; diff --git a/lib/lib/IO/All/Socket.pod b/lib/lib/IO/All/Socket.pod new file mode 100644 index 0000000..00cb1ec --- /dev/null +++ b/lib/lib/IO/All/Socket.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::Socket - Socket Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/String.pm b/lib/lib/IO/All/String.pm new file mode 100644 index 0000000..8543ec7 --- /dev/null +++ b/lib/lib/IO/All/String.pm @@ -0,0 +1,34 @@ +use strict; use warnings; +package IO::All::String; + +use IO::All -base; + +const type => 'string'; + +sub string_ref { + my ($self, $ref) = @_; + + no strict 'refs'; + *$self->{ref} = $ref if exists $_[1]; + + return *$self->{ref} +} + +sub string { + my $self = shift; + bless $self, __PACKAGE__; + $self->_init; +} + +sub open { + my $self = shift; + my $str = ''; + my $ref = \$str; + $self->string_ref($ref); + open my $fh, '+<', $ref; + $self->io_handle($fh); + $self->_set_binmode; + $self->is_open(1); +} + +1; diff --git a/lib/lib/IO/All/String.pod b/lib/lib/IO/All/String.pod new file mode 100644 index 0000000..79628b6 --- /dev/null +++ b/lib/lib/IO/All/String.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::String - String Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/All/Temp.pm b/lib/lib/IO/All/Temp.pm new file mode 100644 index 0000000..57aac5f --- /dev/null +++ b/lib/lib/IO/All/Temp.pm @@ -0,0 +1,18 @@ +use strict; use warnings; +package IO::All::Temp; + +use IO::All::File -base; + +sub temp { + my $self = shift; + bless $self, __PACKAGE__; + my $temp_file = IO::File::new_tmpfile() + or $self->throw("Can't create temporary file"); + $self->io_handle($temp_file); + $self->_error_check; + $self->autoclose(0); + $self->is_open(1); + return $self; +} + +1; diff --git a/lib/lib/IO/All/Temp.pod b/lib/lib/IO/All/Temp.pod new file mode 100644 index 0000000..c5edf37 --- /dev/null +++ b/lib/lib/IO/All/Temp.pod @@ -0,0 +1,21 @@ +=pod + +=for comment +DO NOT EDIT. This Pod was generated by Swim v0.1.46. +See http://github.com/ingydotnet/swim-pm#readme + +=encoding utf8 + +=head1 NAME + +IO::All::Temp - Temporary File Support for IO::All + +=head1 SYNOPSIS + +See L. + +=head1 DESCRIPTION + +<<>> + +=cut diff --git a/lib/lib/IO/AtomicFile.pm b/lib/lib/IO/AtomicFile.pm new file mode 100644 index 0000000..1a6f33e --- /dev/null +++ b/lib/lib/IO/AtomicFile.pm @@ -0,0 +1,199 @@ +package IO::AtomicFile; + +### DOCUMENTATION AT BOTTOM OF FILE + +# Be strict: +use strict; + +# External modules: +use IO::File; + + +#------------------------------ +# +# GLOBALS... +# +#------------------------------ +use vars qw($VERSION @ISA); + +# The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.111"; + +# Inheritance: +@ISA = qw(IO::File); + + +#------------------------------ +# new ARGS... +#------------------------------ +# Class method, constructor. +# Any arguments are sent to open(). +# +sub new { + my $class = shift; + my $self = $class->SUPER::new(); + ${*$self}{'io_atomicfile_suffix'} = ''; + $self->open(@_) if @_; + $self; +} + +#------------------------------ +# DESTROY +#------------------------------ +# Destructor. +# +sub DESTROY { + shift->close(1); ### like close, but raises fatal exception on failure +} + +#------------------------------ +# open PATH, MODE +#------------------------------ +# Class/instance method. +# +sub open { + my ($self, $path, $mode) = @_; + ref($self) or $self = $self->new; ### now we have an instance! + + ### Create tmp path, and remember this info: + my $temp = "${path}..TMP" . ${*$self}{'io_atomicfile_suffix'}; + ${*$self}{'io_atomicfile_temp'} = $temp; + ${*$self}{'io_atomicfile_path'} = $path; + + ### Open the file! Returns filehandle on success, for use as a constructor: + $self->SUPER::open($temp, $mode) ? $self : undef; +} + +#------------------------------ +# _closed [YESNO] +#------------------------------ +# Instance method, private. +# Are we already closed? Argument sets new value, returns previous one. +# +sub _closed { + my $self = shift; + my $oldval = ${*$self}{'io_atomicfile_closed'}; + ${*$self}{'io_atomicfile_closed'} = shift if @_; + $oldval; +} + +#------------------------------ +# close +#------------------------------ +# Instance method. +# Close the handle, and rename the temp file to its final name. +# +sub close { + my ($self, $die) = @_; + unless ($self->_closed(1)) { ### sentinel... + if ($self->SUPER::close()) { + rename(${*$self}{'io_atomicfile_temp'}, + ${*$self}{'io_atomicfile_path'}) + or ($die ? die "close (rename) atomic file: $!\n" : return undef); + } else { + ($die ? die "close atomic file: $!\n" : return undef); + } + } + 1; +} + +#------------------------------ +# delete +#------------------------------ +# Instance method. +# Close the handle, and delete the temp file. +# +sub delete { + my $self = shift; + unless ($self->_closed(1)) { ### sentinel... + $self->SUPER::close(); + return unlink(${*$self}{'io_atomicfile_temp'}); + } + 1; +} + +#------------------------------ +# detach +#------------------------------ +# Instance method. +# Close the handle, but DO NOT delete the temp file. +# +sub detach { + my $self = shift; + $self->SUPER::close() unless ($self->_closed(1)); + 1; +} + +#------------------------------ +1; +__END__ + + +=head1 NAME + +IO::AtomicFile - write a file which is updated atomically + + +=head1 SYNOPSIS + + use IO::AtomicFile; + + ### Write a temp file, and have it install itself when closed: + my $FH = IO::AtomicFile->open("bar.dat", "w"); + print $FH "Hello!\n"; + $FH->close || die "couldn't install atomic file: $!"; + + ### Write a temp file, but delete it before it gets installed: + my $FH = IO::AtomicFile->open("bar.dat", "w"); + print $FH "Hello!\n"; + $FH->delete; + + ### Write a temp file, but neither install it nor delete it: + my $FH = IO::AtomicFile->open("bar.dat", "w"); + print $FH "Hello!\n"; + $FH->detach; + + +=head1 DESCRIPTION + +This module is intended for people who need to update files +reliably in the face of unexpected program termination. + +For example, you generally don't want to be halfway in the middle of +writing I and have your program terminate! Even +the act of writing a single scalar to a filehandle is I atomic. + +But this module gives you true atomic updates, via rename(). +When you open a file I via this module, you are I +opening a temporary file I, and writing your +output there. The act of closing this file (either explicitly +via close(), or implicitly via the destruction of the object) +will cause rename() to be called... therefore, from the point +of view of the outside world, the file's contents are updated +in a single time quantum. + +To ensure that problems do not go undetected, the "close" method +done by the destructor will raise a fatal exception if the rename() +fails. The explicit close() just returns undef. + +You can also decide at any point to trash the file you've been +building. + + +=head1 AUTHOR + +=head2 Primary Maintainer + +Dianne Skoll (F). + +=head2 Original Author + +Eryq (F). +President, ZeeGee Software Inc (F). + + +=head1 REVISION + +$Revision: 1.2 $ + +=cut diff --git a/lib/lib/IO/CaptureOutput.pm b/lib/lib/IO/CaptureOutput.pm new file mode 100644 index 0000000..d569ae9 --- /dev/null +++ b/lib/lib/IO/CaptureOutput.pm @@ -0,0 +1,490 @@ +use strict; +use warnings; + +package IO::CaptureOutput; +# ABSTRACT: capture STDOUT and STDERR from Perl code, subprocesses or XS + +our $VERSION = '1.1104'; + +use vars qw/@ISA @EXPORT_OK %EXPORT_TAGS $CarpLevel/; +use Exporter; +use Carp qw/croak/; +@ISA = 'Exporter'; +@EXPORT_OK = qw/capture capture_exec qxx capture_exec_combined qxy/; +%EXPORT_TAGS = (all => \@EXPORT_OK); +$CarpLevel = 0; # help capture report errors at the right level + +sub _capture (&@) { ## no critic + my ($code, $output, $error, $output_file, $error_file) = @_; + + # check for valid combinations of input + { + local $Carp::CarpLevel = 1; + my $error = _validate($output, $error, $output_file, $error_file); + croak $error if $error; + } + + # if either $output or $error are defined, then we need a variable for + # results; otherwise we only capture to files and don't waste memory + if ( defined $output || defined $error ) { + for ($output, $error) { + $_ = \do { my $s; $s = ''} unless ref $_; + $$_ = '' if $_ != \undef && !defined($$_); + } + } + + # merge if same refs for $output and $error or if both are undef -- + # i.e. capture \&foo, undef, undef, $merged_file + # this means capturing into separate files *requires* at least one + # capture variable + my $should_merge = + (defined $error && defined $output && $output == $error) || + ( !defined $output && !defined $error ) || + 0; + + my ($capture_out, $capture_err); + + # undef means capture anonymously; anything other than \undef means + # capture to that ref; \undef means skip capture + if ( !defined $output || $output != \undef ) { + $capture_out = IO::CaptureOutput::_proxy->new( + 'STDOUT', $output, undef, $output_file + ); + } + if ( !defined $error || $error != \undef ) { + $capture_err = IO::CaptureOutput::_proxy->new( + 'STDERR', $error, ($should_merge ? 'STDOUT' : undef), $error_file + ); + } + + # now that output capture is setup, call the subroutine + # results get read when IO::CaptureOutput::_proxy objects go out of scope + &$code(); +} + +# Extra indirection for symmetry with capture_exec, etc. Gets error reporting +# to the right level +sub capture (&@) { ## no critic + return &_capture; +} + +sub capture_exec { + my @args = @_; + my ($output, $error); + my $exit = _capture sub { system _shell_quote(@args) }, \$output, \$error; + my $success = ($exit == 0 ) ? 1 : 0 ; + $? = $exit; + return wantarray ? ($output, $error, $success, $exit) : $output; +} + +*qxx = \&capture_exec; + +sub capture_exec_combined { + my @args = @_; + my $output; + my $exit = _capture sub { system _shell_quote(@args) }, \$output, \$output; + my $success = ($exit == 0 ) ? 1 : 0 ; + $? = $exit; + return wantarray ? ($output, $success, $exit) : $output; +} + +*qxy = \&capture_exec_combined; + +# extra quoting required on Win32 systems +*_shell_quote = ($^O =~ /MSWin32/) ? \&_shell_quote_win32 : sub {@_}; +sub _shell_quote_win32 { + my @args; + for (@_) { + if (/[ \"]/) { # TODO: check if ^ requires escaping + (my $escaped = $_) =~ s/([\"])/\\$1/g; + push @args, '"' . $escaped . '"'; + next; + } + push @args, $_ + } + return @args; +} + +# detect errors and return an error message or empty string; +sub _validate { + my ($output, $error, $output_file, $error_file) = @_; + + # default to "ok" + my $msg = q{}; + + # \$out, \$out, $outfile, $errfile + if ( defined $output && defined $error + && defined $output_file && defined $error_file + && $output == $error + && $output != \undef + && $output_file ne $error_file + ) { + $msg = "Merged STDOUT and STDERR, but specified different output and error files"; + } + # undef, undef, $outfile, $errfile + elsif ( !defined $output && !defined $error + && defined $output_file && defined $error_file + && $output_file ne $error_file + ) { + $msg = "Merged STDOUT and STDERR, but specified different output and error files"; + } + + return $msg; +} + +# Captures everything printed to a filehandle for the lifetime of the object +# and then transfers it to a scalar reference +package IO::CaptureOutput::_proxy; +use File::Temp 0.16 'tempfile'; +use File::Basename qw/basename/; +use Symbol qw/gensym qualify qualify_to_ref/; +use Carp; + +sub _is_wperl { $^O eq 'MSWin32' && basename($^X) eq 'wperl.exe' } + +sub new { + my $class = shift; + my ($orig_fh, $capture_var, $merge_fh, $capture_file) = @_; + $orig_fh = qualify($orig_fh); # e.g. main::STDOUT + my $fhref = qualify_to_ref($orig_fh); # e.g. \*STDOUT + + # Duplicate the filehandle + my $saved_fh; + { + no strict 'refs'; ## no critic - needed for 5.005 + if ( defined fileno($orig_fh) && ! _is_wperl() ) { + $saved_fh = gensym; + open $saved_fh, ">&$orig_fh" or croak "Can't redirect <$orig_fh> - $!"; + } + } + + # Create replacement filehandle if not merging + my ($newio_fh, $newio_file); + if ( ! $merge_fh ) { + $newio_fh = gensym; + if ($capture_file) { + $newio_file = $capture_file; + } else { + (undef, $newio_file) = tempfile; + } + open $newio_fh, "+>$newio_file" or croak "Can't write temp file for $orig_fh - $!"; + } + else { + $newio_fh = qualify($merge_fh); + } + + # Redirect (or merge) + { + no strict 'refs'; ## no critic -- needed for 5.005 + open $fhref, ">&".fileno($newio_fh) or croak "Can't redirect $orig_fh - $!"; + } + + bless [$$, $orig_fh, $saved_fh, $capture_var, $newio_fh, $newio_file, $capture_file], $class; +} + +sub DESTROY { + my $self = shift; + + my ($pid, $orig_fh, $saved_fh, $capture_var, $newio_fh, + $newio_file, $capture_file) = @$self; + return unless $pid eq $$; # only cleanup in the process that is capturing + + # restore the original filehandle + my $fh_ref = Symbol::qualify_to_ref($orig_fh); + select((select ($fh_ref), $|=1)[0]); + if (defined $saved_fh) { + open $fh_ref, ">&". fileno($saved_fh) or croak "Can't restore $orig_fh - $!"; + } + else { + close $fh_ref; + } + + # transfer captured data to the scalar reference if we didn't merge + # $newio_file is undef if this file handle is merged to another + if (ref $capture_var && $newio_file) { + # some versions of perl complain about reading from fd 1 or 2 + # which could happen if STDOUT and STDERR were closed when $newio + # was opened, so we just squelch warnings here and continue + local $^W; + seek $newio_fh, 0, 0; + $$capture_var = do {local $/; <$newio_fh>}; + } + close $newio_fh if $newio_file; + + # Cleanup + return unless defined $newio_file && -e $newio_file; + return if $capture_file; # the "temp" file was explicitly named + unlink $newio_file or carp "Couldn't remove temp file '$newio_file' - $!"; +} + +1; + +__END__ + +=pod + +=encoding UTF-8 + +=head1 NAME + +IO::CaptureOutput - capture STDOUT and STDERR from Perl code, subprocesses or XS + +=head1 VERSION + +version 1.1104 + +=head1 SYNOPSIS + + use IO::CaptureOutput qw(capture qxx qxy); + + # STDOUT and STDERR separately + capture { noisy_sub(@args) } \$stdout, \$stderr; + + # STDOUT and STDERR together + capture { noisy_sub(@args) } \$combined, \$combined; + + # STDOUT and STDERR from external command + ($stdout, $stderr, $success) = qxx( @cmd ); + + # STDOUT and STDERR together from external command + ($combined, $success) = qxy( @cmd ); + +=head1 DESCRIPTION + +B - see +L instead. + +This module provides routines for capturing STDOUT and STDERR from perl +subroutines, forked system calls (e.g. C, C) and from XS +or C modules. + +=head1 NAME + +=head1 FUNCTIONS + +The following functions will be exported on demand. + +=head2 capture() + + capture \&subroutine, \$stdout, \$stderr; + +Captures everything printed to C and C for the duration of +C<&subroutine>. C<$stdout> and C<$stderr> are optional scalars that will +contain C and C respectively. + +C uses a code prototype so the first argument can be specified +directly within brackets if desired. + + # shorthand with prototype + capture C< print __PACKAGE__ > \$stdout, \$stderr; + +Returns the return value(s) of C<&subroutine>. The sub is called in the +same context as C was called e.g.: + + @rv = capture C< wantarray > ; # returns true + $rv = capture C< wantarray > ; # returns defined, but not true + capture C< wantarray >; # void, returns undef + +C is able to capture output from subprocesses and C code, which +traditional C methods of output capture are unable to do. + +B C will only capture output that has been written or +flushed to the filehandle. + +If the two scalar references refer to the same scalar, then C will +be merged to C before capturing and the scalar will hold the +combined output of both. + + capture \&subroutine, \$combined, \$combined; + +Normally, C uses anonymous, temporary files for capturing +output. If desired, specific file names may be provided instead as +additional options. + + capture \&subroutine, \$stdout, \$stderr, $out_file, $err_file; + +Files provided will be clobbered, overwriting any previous data, but will +persist after the call to C for inspection or other +manipulation. + +By default, when no references are provided to hold STDOUT or STDERR, +output is captured and silently discarded. + + # Capture STDOUT, discard STDERR + capture \&subroutine, \$stdout; + + # Discard STDOUT, capture STDERR + capture \&subroutine, undef, \$stderr; + +However, even when using C, output can be captured to specific +files. + + # Capture STDOUT to a specific file, discard STDERR + capture \&subroutine, \$stdout, undef, $outfile; + + # Discard STDOUT, capture STDERR to a specific file + capture \&subroutine, undef, \$stderr, undef, $err_file; + + # Discard both, capture merged output to a specific file + capture \&subroutine, undef, undef, $mergedfile; + +It is a fatal error to merge STDOUT and STDERR and request separate, +specific files for capture. + + # ERROR: + capture \&subroutine, \$stdout, \$stdout, $out_file, $err_file; + capture \&subroutine, undef, undef, $out_file, $err_file; + +If either STDOUT or STDERR should be passed through to the terminal instead +of captured, provide a reference to undef -- C<\undef> -- instead of a +capture variable. + + # Capture STDOUT, display STDERR + capture \&subroutine, \$stdout, \undef; + + # Display STDOUT, capture STDERR + capture \&subroutine, \undef, \$stderr; + +=head2 capture_exec() + + ($stdout, $stderr, $success, $exit_code) = capture_exec(@args); + +Captures and returns the output from C. In scalar context, +C will return what was printed to C. In list +context, it returns what was printed to C and C as well as +a success flag and the exit value. + + $stdout = capture_exec('perl', '-e', 'print "hello world"'); + + ($stdout, $stderr, $success, $exit_code) = + capture_exec('perl', '-e', 'warn "Test"'); + +C passes its arguments to C and on MSWin32 will +protect arguments with shell quotes if necessary. This makes it a handy +and slightly more portable alternative to backticks, piped C and +C. + +The C<$success> flag returned will be true if the command ran successfully +and false if it did not (if the command could not be run or if it ran and +returned a non-zero exit value). On failure, the raw exit value of the +C call is available both in the C<$exit_code> returned and in the +C<$?> variable. + + ($stdout, $stderr, $success, $exit_code) = + capture_exec('perl', '-e', 'warn "Test" and exit 1'); + + if ( ! $success ) { + print "The exit code was " . ($exit_code >> 8) . "\n"; + } + +See L for more information on interpreting a child process exit +code. + +=head2 capture_exec_combined() + + ($combined, $success, $exit_code) = capture_exec_combined( + 'perl', '-e', 'print "hello\n"', 'warn "Test\n" + ); + +This is just like C, except that it merges C with +C before capturing output. + +B there is no guarantee that text printed to C and C +in the subprocess will be appear in order. The actual order will depend on +how IO buffering is handled in the subprocess. + +=head2 qxx() + +This is an alias for C. + +=head2 qxy() + +This is an alias for C. + +=head1 SEE ALSO + +=over 4 + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=item * + +L + +=back + +=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + +=head1 SUPPORT + +=head2 Bugs / Feature Requests + +Please report any bugs or feature requests through the issue tracker +at L. +You will be notified automatically of any progress on your issue. + +=head2 Source Code + +This is open source software. The code repository is available for +public review and contribution under the terms of the license. + +L + + git clone https://github.com/dagolden/IO-CaptureOutput.git + +=head1 AUTHORS + +=over 4 + +=item * + +Simon Flack + +=item * + +David Golden + +=back + +=head1 CONTRIBUTORS + +=for stopwords Mike Latimer Olivier Mengué Tony Cook + +=over 4 + +=item * + +Mike Latimer + +=item * + +Olivier Mengué + +=item * + +Tony Cook + +=back + +=head1 COPYRIGHT AND LICENSE + +This software is copyright (c) 2015 by Simon Flack and David Golden. + +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 diff --git a/lib/lib/IO/Compress/Adapter/Lzma.pm b/lib/lib/IO/Compress/Adapter/Lzma.pm new file mode 100644 index 0000000..b41eaa8 --- /dev/null +++ b/lib/lib/IO/Compress/Adapter/Lzma.pm @@ -0,0 +1,185 @@ +package IO::Compress::Adapter::Lzma ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.081 qw(:Status); + +use Compress::Raw::Lzma 2.081 qw(LZMA_OK LZMA_STREAM_END) ; + +our ($VERSION); +$VERSION = '2.081'; + +sub mkCompObject +{ + my $Filter = shift ; + + my ($def, $status) = + Compress::Raw::Lzma::AloneEncoder->new(AppendOutput => 1, + Filter => $Filter); + + return (undef, "Could not create AloneEncoder object: $status", $status) + if $status != LZMA_OK ; + + return bless {'Def' => $def, + 'Error' => '', + 'ErrorNo' => 0, + } ; +} + +sub mkRawZipCompObject +{ + my $preset = shift ; + my $extreme = shift; + my $filter; + + + if (defined $preset) { + $preset |= Compress::Raw::Lzma::LZMA_PRESET_EXTREME() + if $extreme; + $filter = Lzma::Filter::Lzma1::Preset($preset) ; + } + else + { $filter = Lzma::Filter::Lzma1 } + + my ($def, $status) = + Compress::Raw::Lzma::RawEncoder->new(AppendOutput => 1, + ForZip => 1, + Filter => $filter, + #Filter => Lzma::Filter::Lzma1m + ); + + return (undef, "Could not create RawEncoder object: $status", $status) + if $status != LZMA_OK ; + + return bless {'Def' => $def, + 'Error' => '', + 'ErrorNo' => 0, + } ; +} + +sub compr +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->code($_[0], $_[1]) ; + $self->{ErrorNo} = $status; + + if ($status != LZMA_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[1] } .= $out if defined $out; + + return STATUS_OK; +} + +sub flush +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->flush($_[0]); + $self->{ErrorNo} = $status; + + if ($status != LZMA_STREAM_END) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[0] } .= $out if defined $out ; + return STATUS_OK; + +} + +sub close +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->flush($_[0]); + $self->{ErrorNo} = $status; + + if ($status != LZMA_STREAM_END) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[0] } .= $out if defined $out ; + return STATUS_OK; + +} + + +sub reset +{ + my $self = shift ; + + my $outer = $self->{Outer}; + + my ($def, $status) = + Compress::Raw::Lzma::AloneEncoder->new(AppendOutput => 1); + $self->{ErrorNo} = ($status == LZMA_OK) ? 0 : $status ; + + if ($status != LZMA_OK) + { + $self->{Error} = "Cannot create Deflate object: $status"; + return STATUS_ERROR; + } + + $self->{Def} = $def; + + return STATUS_OK; +} + +sub compressedBytes +{ + my $self = shift ; + $self->{Def}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Def}->uncompressedBytes(); +} + +#sub total_out +#{ +# my $self = shift ; +# 0; +#} +# + +#sub total_in +#{ +# my $self = shift ; +# $self->{Def}->total_in(); +#} +# +#sub crc32 +#{ +# my $self = shift ; +# $self->{Def}->crc32(); +#} +# +#sub adler32 +#{ +# my $self = shift ; +# $self->{Def}->adler32(); +#} + + +1; + +__END__ + diff --git a/lib/lib/IO/Compress/Adapter/Xz.pm b/lib/lib/IO/Compress/Adapter/Xz.pm new file mode 100644 index 0000000..5ffee03 --- /dev/null +++ b/lib/lib/IO/Compress/Adapter/Xz.pm @@ -0,0 +1,156 @@ +package IO::Compress::Adapter::Xz ; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.081 qw(:Status); + +use Compress::Raw::Lzma 2.081 qw(LZMA_OK LZMA_STREAM_END LZMA_PRESET_DEFAULT LZMA_CHECK_CRC32) ; + +our ($VERSION); +$VERSION = '2.081'; + +sub mkCompObject +{ + my $Preset = shift ; + my $Extreme = shift ; + my $Check = shift ; + + my ($def, $status) = Compress::Raw::Lzma::EasyEncoder->new(AppendOutput => 1, + Preset => $Preset, + Extreme => $Extreme, + Check => $Check); + + return (undef, "Could not create EasyEncoder object: $status", $status) + if $status != LZMA_OK ; + + return bless {'Def' => $def, + 'Error' => '', + 'ErrorNo' => 0, + } ; +} + +sub compr +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->code($_[0], $_[1]) ; + $self->{ErrorNo} = $status; + + if ($status != LZMA_OK) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[1] } .= $out if defined $out; + + return STATUS_OK; +} + +sub flush +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->flush($_[0]); + $self->{ErrorNo} = $status; + + if ($status != LZMA_STREAM_END) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[0] } .= $out if defined $out ; + return STATUS_OK; + +} + +sub close +{ + my $self = shift ; + + my $def = $self->{Def}; + + my $status = $def->flush($_[0]); + $self->{ErrorNo} = $status; + + if ($status != LZMA_STREAM_END) + { + $self->{Error} = "Deflate Error: $status"; + return STATUS_ERROR; + } + + #${ $_[0] } .= $out if defined $out ; + return STATUS_OK; + +} + + +sub reset +{ + my $self = shift ; + + my $outer = $self->{Outer}; + + my ($def, $status) = Compress::Raw::Lzma->lzma_easy_encoder(); + $self->{ErrorNo} = ($status == LZMA_OK) ? 0 : $status ; + + if ($status != LZMA_OK) + { + $self->{Error} = "Cannot create Deflate object: $status"; + return STATUS_ERROR; + } + + $self->{Def} = $def; + + return STATUS_OK; +} + +sub compressedBytes +{ + my $self = shift ; + $self->{Def}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Def}->uncompressedBytes(); +} + +#sub total_out +#{ +# my $self = shift ; +# 0; +#} +# + +#sub total_in +#{ +# my $self = shift ; +# $self->{Def}->total_in(); +#} +# +#sub crc32 +#{ +# my $self = shift ; +# $self->{Def}->crc32(); +#} +# +#sub adler32 +#{ +# my $self = shift ; +# $self->{Def}->adler32(); +#} + + +1; + +__END__ + diff --git a/lib/lib/IO/Compress/Lzma.pm b/lib/lib/IO/Compress/Lzma.pm new file mode 100644 index 0000000..fa4f45c --- /dev/null +++ b/lib/lib/IO/Compress/Lzma.pm @@ -0,0 +1,768 @@ +package IO::Compress::Lzma ; + +use strict ; +use warnings; +use bytes; +require Exporter ; + +use IO::Compress::Base 2.081 ; + +use IO::Compress::Base::Common 2.081 qw(createSelfTiedObject); +use IO::Compress::Adapter::Lzma 2.081 ; + + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $LzmaError); + +$VERSION = '2.081'; +$LzmaError = ''; + +@ISA = qw(IO::Compress::Base Exporter); +@EXPORT_OK = qw( $LzmaError lzma ) ; +%EXPORT_TAGS = %IO::Compress::Base::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + + +sub new +{ + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$LzmaError); + return $obj->_create(undef, @_); +} + +sub lzma +{ + my $obj = createSelfTiedObject(undef, \$LzmaError); + $obj->_def(@_); +} + + +sub mkHeader +{ + my $self = shift ; + return ''; + +} + +our %PARAMS = ('filter' => [IO::Compress::Base::Common::Parse_any, [] ], + ); +sub getExtraParams +{ + return %PARAMS ; +} + + + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + # TODO - test that Filter ISA Lzma::Filter::Lzma1 + + return 1 ; +} + + +sub mkComp +{ + my $self = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) = + IO::Compress::Adapter::Lzma::mkCompObject($got->getValue('filter')); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + return $obj; +} + + +sub mkTrailer +{ + my $self = shift ; + return ''; +} + +sub mkFinalTrailer +{ + return ''; +} + +#sub newHeader +#{ +# my $self = shift ; +# return ''; +#} + +sub getInverseClass +{ + return ('IO::Uncompress::UnLzma'); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + +1; + +__END__ + +=head1 NAME + +IO::Compress::Lzma - Write lzma files/buffers + +=head1 SYNOPSIS + + use IO::Compress::Lzma qw(lzma $LzmaError) ; + + my $status = lzma $input => $output [,OPTS] + or die "lzma failed: $LzmaError\n"; + + my $z = new IO::Compress::Lzma $output [,OPTS] + or die "lzma failed: $LzmaError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->close() ; + + $LzmaError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + +B. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + +This module provides a Perl interface that allows writing lzma +compressed data to files or buffer. + +For reading lzma files/buffers, see the companion module +L. + +=head1 Functional Interface + +A top-level function, C, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L +section. + + use IO::Compress::Lzma qw(lzma $LzmaError) ; + + lzma $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "lzma failed: $LzmaError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 lzma $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The input is the list of files that match the +fileglob. + +See L for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the compressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +compressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +compressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +compressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the compressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple files/buffers and +C<$output_filename_or_reference> is a single +file/buffer the input files/buffers will be stored +in C<$output_filename_or_reference> as a concatenated series of compressed data streams. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C, +C, are the same as those used with the OO interface defined in the +L section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C that are filehandles. + +If C is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C has +completed. + +This parameter defaults to 0. + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C before reading. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C is enabled, all compressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +compressed data is written to it. + +=item * A Filename + +If C is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any compressed +data is written to it. + +=item * A Filehandle + +If C is enabled, the filehandle will be positioned to the end of +the file via a call to C before any compressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C is specified, and set to true, it will I all compressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any compressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all compressed data will be +appended to the existing buffer. + +Conversely when C is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any compressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any compressed data is output. + +Defaults to 0. + +=back + +=head2 Examples + +To read the contents of the file C and write the compressed +data to the file C. + + use strict ; + use warnings ; + use IO::Compress::Lzma qw(lzma $LzmaError) ; + + my $input = "file1.txt"; + lzma $input => "$input.lzma" + or die "lzma failed: $LzmaError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Lzma qw(lzma $LzmaError) ; + use IO::File ; + + my $input = new IO::File " \$buffer + or die "lzma failed: $LzmaError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Lzma qw(lzma $LzmaError) ; + + lzma '' => '<*.lzma>' + or die "lzma failed: $LzmaError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Lzma qw(lzma $LzmaError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.lzma" ; + lzma $input => $output + or die "Error compressing '$input': $LzmaError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C is shown below + + my $z = new IO::Compress::Lzma $output [,OPTS] + or die "IO::Compress::Lzma failed: $LzmaError\n"; + +It returns an C object on success and undef on failure. +The variable C<$LzmaError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Lzma can be used exactly like an L filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C::new will +return undef. + +=head2 Constructor Options + +C is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C method is called or the C +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C is enabled, all compressed data +will be append to the end of C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item C<< Filter => $filter >> + +When present C< $filter > option must be an object of type C. +See L for a definition of C. + +If this option is not present an C object with default +values will be used. + +=item C<< Strict => 0|1 >> + +This is a placeholder option. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + +Flushes any pending compressed data to the output file/buffer. + +Returns true on success. + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the C method has been called. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C. + +B that the special variable C<$|> B be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +This method always returns C when compressing. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C +will return the underlying file descriptor. Once the C method is +called C will return C. + +If the C<$z> object is associated with a buffer, this method will return +C. + +=head2 close + + $z->close() ; + close $z ; + +Flushes any pending compressed data and then closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Lzma object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C option has been enabled when the IO::Compress::Lzma +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the options that are available when creating +the C<$z> object. + +See the L section for more details. + +=head1 Importing + +No symbolic constants are required by this IO::Compress::Lzma at present. + +=over 5 + +=item :all + +Imports C and C<$LzmaError>. +Same as doing this + + use IO::Compress::Lzma qw(lzma $LzmaError) ; + +=back + +=head1 EXAMPLES + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + +=head1 AUTHOR + +This module was written by Paul Marquess, C. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2018 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/lib/lib/IO/Compress/Xz.pm b/lib/lib/IO/Compress/Xz.pm new file mode 100644 index 0000000..f48169c --- /dev/null +++ b/lib/lib/IO/Compress/Xz.pm @@ -0,0 +1,796 @@ +package IO::Compress::Xz ; + +use strict ; +use warnings; +use bytes; +require Exporter ; + +use IO::Compress::Base 2.081 ; +use IO::Compress::Base::Common 2.081 qw(createSelfTiedObject); +use IO::Compress::Adapter::Xz 2.081 ; +use Compress::Raw::Lzma 2.081 ; + + +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $XzError); + +$VERSION = '2.081'; +$XzError = ''; + +@ISA = qw(IO::Compress::Base Exporter); +@EXPORT_OK = qw( $XzError xz ) ; +%EXPORT_TAGS = %IO::Compress::Base::EXPORT_TAGS ; + +push @{ $EXPORT_TAGS{constants} }, @Compress::Raw::Lzma::EXPORT; +$EXPORT_TAGS{all} = $EXPORT_TAGS{constants} ; + +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + + my $obj = createSelfTiedObject($class, \$XzError); + return $obj->_create(undef, @_); +} + +sub xz +{ + my $obj = createSelfTiedObject(undef, \$XzError); + $obj->_def(@_); +} + + +sub mkHeader +{ + my $self = shift ; + return ''; + +} +our %PARAMS = ( + 'preset' => [IO::Compress::Base::Common::Parse_unsigned, LZMA_PRESET_DEFAULT], + 'extreme'=> [IO::Compress::Base::Common::Parse_boolean, 0], + 'check' => [IO::Compress::Base::Common::Parse_unsigned, LZMA_CHECK_CRC32], + ); + +sub getExtraParams +{ + return %PARAMS ; +} + + + +sub ckParams +{ + my $self = shift ; + my $got = shift; + + # TODO - validate the parameters + + return 1 ; +} + + +sub mkComp +{ + my $self = shift ; + my $got = shift ; + + my ($obj, $errstr, $errno) + = IO::Compress::Adapter::Xz::mkCompObject($got->getValue('preset'), + $got->getValue('extreme'), + $got->getValue('check') + ); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + return $obj; +} + + +sub mkTrailer +{ + my $self = shift ; + return ''; +} + +sub mkFinalTrailer +{ + return ''; +} + +#sub newHeader +#{ +# my $self = shift ; +# return ''; +#} + +sub getInverseClass +{ + return ('IO::Uncompress::UnXz'); +} + +sub getFileInfo +{ + my $self = shift ; + my $params = shift; + my $file = shift ; + +} + +1; + +__END__ + +=head1 NAME + +IO::Compress::Xz - Write xz files/buffers + +=head1 SYNOPSIS + + use IO::Compress::Xz qw(xz $XzError) ; + + my $status = xz $input => $output [,OPTS] + or die "xz failed: $XzError\n"; + + my $z = new IO::Compress::Xz $output [,OPTS] + or die "xz failed: $XzError\n"; + + $z->print($string); + $z->printf($format, $string); + $z->write($string); + $z->syswrite($string [, $length, $offset]); + $z->flush(); + $z->tell(); + $z->eof(); + $z->seek($position, $whence); + $z->binmode(); + $z->fileno(); + $z->opened(); + $z->autoflush(); + $z->input_line_number(); + $z->newStream( [OPTS] ); + + $z->close() ; + + $XzError ; + + # IO::File mode + + print $z $string; + printf $z $format, $string; + tell $z + eof $z + seek $z, $position, $whence + binmode $z + fileno $z + close $z ; + + +=head1 DESCRIPTION + +B. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + +This module provides a Perl interface that allows writing xz +compressed data to files or buffer. + +For reading xz files/buffers, see the companion module +L. + +=head1 Functional Interface + +A top-level function, C, is provided to carry out +"one-shot" compression between buffers and/or files. For finer +control over the compression process, see the L +section. + + use IO::Compress::Xz qw(xz $XzError) ; + + xz $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "xz failed: $XzError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 xz $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the uncompressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is compressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The input is the list of files that match the +fileglob. + +See L for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the compressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +compressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +compressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +compressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the compressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple files/buffers and +C<$output_filename_or_reference> is a single +file/buffer the input files/buffers will be stored +in C<$output_filename_or_reference> as a concatenated series of compressed data streams. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C, +C, are the same as those used with the OO interface defined in the +L section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C that are filehandles. + +If C is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C has +completed. + +This parameter defaults to 0. + +=item C<< BinModeIn => 0|1 >> + +When reading from a file or filehandle, set C before reading. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C is enabled, all compressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +compressed data is written to it. + +=item * A Filename + +If C is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any compressed +data is written to it. + +=item * A Filehandle + +If C is enabled, the filehandle will be positioned to the end of +the file via a call to C before any compressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C is specified, and set to true, it will I all compressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any compressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all compressed data will be +appended to the existing buffer. + +Conversely when C is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any compressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any compressed data is output. + +Defaults to 0. + +=back + +=head2 Examples + +To read the contents of the file C and write the compressed +data to the file C. + + use strict ; + use warnings ; + use IO::Compress::Xz qw(xz $XzError) ; + + my $input = "file1.txt"; + xz $input => "$input.xz" + or die "xz failed: $XzError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +compressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Compress::Xz qw(xz $XzError) ; + use IO::File ; + + my $input = new IO::File " \$buffer + or die "xz failed: $XzError\n"; + +To compress all files in the directory "/my/home" that match "*.txt" +and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Compress::Xz qw(xz $XzError) ; + + xz '' => '<*.xz>' + or die "xz failed: $XzError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Compress::Xz qw(xz $XzError) ; + + for my $input ( glob "/my/home/*.txt" ) + { + my $output = "$input.xz" ; + xz $input => $output + or die "Error compressing '$input': $XzError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for C is shown below + + my $z = new IO::Compress::Xz $output [,OPTS] + or die "IO::Compress::Xz failed: $XzError\n"; + +It returns an C object on success and undef on failure. +The variable C<$XzError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Compress::Xz can be used exactly like an L filehandle. +This means that all normal output file operations can be carried out +with C<$z>. +For example, to write to a compressed file/buffer you can use either of +these forms + + $z->print("hello world\n"); + print $z "hello world\n"; + +The mandatory parameter C<$output> is used to control the destination +of the compressed data. This parameter can take one of these forms. + +=over 5 + +=item A filename + +If the C<$output> parameter is a simple scalar, it is assumed to be a +filename. This file will be opened for writing and the compressed data +will be written to it. + +=item A filehandle + +If the C<$output> parameter is a filehandle, the compressed data will be +written to it. +The string '-' can be used as an alias for standard output. + +=item A scalar reference + +If C<$output> is a scalar reference, the compressed data will be stored +in C<$$output>. + +=back + +If the C<$output> parameter is any other type, C::new will +return undef. + +=head2 Constructor Options + +C is any combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$output> parameter is a filehandle. If +specified, and the value is true, it will result in the C<$output> being +closed once either the C method is called or the C +object is destroyed. + +This parameter defaults to 0. + +=item C<< Append => 0|1 >> + +Opens C<$output> in append mode. + +The behaviour of this option is dependent on the type of C<$output>. + +=over 5 + +=item * A Buffer + +If C<$output> is a buffer and C is enabled, all compressed data +will be append to the end of C<$output>. Otherwise C<$output> will be +cleared before any data is written to it. + +=item * A Filename + +If C<$output> is a filename and C is enabled, the file will be +opened in append mode. Otherwise the contents of the file, if any, will be +truncated before any compressed data is written to it. + +=item * A Filehandle + +If C<$output> is a filehandle, the file pointer will be positioned to the +end of the file via a call to C before any compressed data is written +to it. Otherwise the file pointer will not be moved. + +=back + +This parameter defaults to 0. + +=item C<< Preset => $preset >> + +Used to choose the compression preset. + +Valid values are 0-9 and C. + +0 is the fastest compression with the lowest memory usage and the lowest +compression. + +9 is the slowest compression with the highest memory usage but with the best +compression. + +Defaults to C (6). + +=item C<< Extreme => 0|1 >> + +Makes the compression a lot slower, but a small compression gain. + +Defaults to 0. + +=item C<< Check => $check >> + +Used to specify the integrrity check used in the xz data stream. +Valid values are C, C, +C, C. + +Defaults to C. + +=item C<< Strict => 0|1 >> + +This is a placeholder option. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 print + +Usage is + + $z->print($data) + print $z $data + +Compresses and outputs the contents of the C<$data> parameter. This +has the same behaviour as the C built-in. + +Returns true if successful. + +=head2 printf + +Usage is + + $z->printf($format, $data) + printf $z $format, $data + +Compresses and outputs the contents of the C<$data> parameter. + +Returns true if successful. + +=head2 syswrite + +Usage is + + $z->syswrite $data + $z->syswrite $data, $length + $z->syswrite $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C if +unsuccessful. + +=head2 write + +Usage is + + $z->write $data + $z->write $data, $length + $z->write $data, $length, $offset + +Compresses and outputs the contents of the C<$data> parameter. + +Returns the number of uncompressed bytes written, or C if +unsuccessful. + +=head2 flush + +Usage is + + $z->flush; + +Flushes any pending compressed data to the output file/buffer. + +Returns true on success. + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the C method has been called. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C functionality, with the restriction +that it is only legal to seek forward in the output file/buffer. +It is a fatal error to attempt to seek backward. + +Empty parts of the file/buffer will have NULL (0x00) bytes written to them. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C. + +B that the special variable C<$|> B be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +This method always returns C when compressing. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C +will return the underlying file descriptor. Once the C method is +called C will return C. + +If the C<$z> object is associated with a buffer, this method will return +C. + +=head2 close + + $z->close() ; + close $z ; + +Flushes any pending compressed data and then closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Compress::Xz object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C option has been enabled when the IO::Compress::Xz +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 newStream([OPTS]) + +Usage is + + $z->newStream( [OPTS] ) + +Closes the current compressed data stream and starts a new one. + +OPTS consists of any of the options that are available when creating +the C<$z> object. + +See the L section for more details. + +=head1 Importing + +No symbolic constants are required by this IO::Compress::Xz at present. + +=over 5 + +=item :all + +Imports C and C<$XzError>. +Same as doing this + + use IO::Compress::Xz qw(xz $XzError) ; + +=back + +=head1 EXAMPLES + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + +=head1 AUTHOR + +This module was written by Paul Marquess, C. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2018 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/lib/lib/IO/HTML.pm b/lib/lib/IO/HTML.pm new file mode 100644 index 0000000..5fdad22 --- /dev/null +++ b/lib/lib/IO/HTML.pm @@ -0,0 +1,575 @@ +#--------------------------------------------------------------------- +package IO::HTML; +# +# Copyright 2014 Christopher J. Madsen +# +# Author: Christopher J. Madsen +# Created: 14 Jan 2012 +# +# This program is free software; you can redistribute it and/or modify +# it under the same terms as Perl itself. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See either the +# GNU General Public License or the Artistic License for more details. +# +# ABSTRACT: Open an HTML file with automatic charset detection +#--------------------------------------------------------------------- + +use 5.008; +use strict; +use warnings; + +use Carp 'croak'; +use Encode 2.10 qw(decode find_encoding); # need utf-8-strict encoding +use Exporter 5.57 'import'; + +our $VERSION = '1.001'; +# This file is part of IO-HTML 1.001 (June 28, 2014) + +our $default_encoding ||= 'cp1252'; + +our @EXPORT = qw(html_file); +our @EXPORT_OK = qw(find_charset_in html_file_and_encoding html_outfile + sniff_encoding); + +our %EXPORT_TAGS = ( + rw => [qw( html_file html_file_and_encoding html_outfile )], + all => [ @EXPORT, @EXPORT_OK ], +); + +#===================================================================== + + +sub html_file +{ + (&html_file_and_encoding)[0]; # return just the filehandle +} # end html_file + + +# Note: I made html_file and html_file_and_encoding separate functions +# (instead of making html_file context-sensitive) because I wanted to +# use html_file in function calls (i.e. list context) without having +# to write "scalar html_file" all the time. + +sub html_file_and_encoding +{ + my ($filename, $options) = @_; + + $options ||= {}; + + open(my $in, '<:raw', $filename) or croak "Failed to open $filename: $!"; + + + my ($encoding, $bom) = sniff_encoding($in, $filename, $options); + + if (not defined $encoding) { + croak "No default encoding specified" + unless defined($encoding = $default_encoding); + $encoding = find_encoding($encoding) if $options->{encoding}; + } # end if we didn't find an encoding + + binmode $in, sprintf(":encoding(%s):crlf", + $options->{encoding} ? $encoding->name : $encoding); + + return ($in, $encoding, $bom); +} # end html_file_and_encoding +#--------------------------------------------------------------------- + + +sub html_outfile +{ + my ($filename, $encoding, $bom) = @_; + + if (not defined $encoding) { + croak "No default encoding specified" + unless defined($encoding = $default_encoding); + } # end if we didn't find an encoding + elsif (ref $encoding) { + $encoding = $encoding->name; + } + + open(my $out, ">:encoding($encoding)", $filename) + or croak "Failed to open $filename: $!"; + + print $out "\x{FeFF}" if $bom; + + return $out; +} # end html_outfile +#--------------------------------------------------------------------- + + +sub sniff_encoding +{ + my ($in, $filename, $options) = @_; + + $filename = 'file' unless defined $filename; + $options ||= {}; + + my $pos = tell $in; + croak "Could not seek $filename: $!" if $pos < 0; + + croak "Could not read $filename: $!" unless defined read $in, my $buf, 1024; + + seek $in, $pos, 0 or croak "Could not seek $filename: $!"; + + + # Check for BOM: + my $bom; + my $encoding = do { + if ($buf =~ /^\xFe\xFF/) { + $bom = 2; + 'UTF-16BE'; + } elsif ($buf =~ /^\xFF\xFe/) { + $bom = 2; + 'UTF-16LE'; + } elsif ($buf =~ /^\xEF\xBB\xBF/) { + $bom = 3; + 'utf-8-strict'; + } else { + find_charset_in($buf, $options); # check for + } + }; # end $encoding + + if ($bom) { + seek $in, $bom, 1 or croak "Could not seek $filename: $!"; + $bom = 1; + } + elsif (not defined $encoding) { # try decoding as UTF-8 + my $test = decode('utf-8-strict', $buf, Encode::FB_QUIET); + if ($buf =~ /^(?: # nothing left over + | [\xC2-\xDF] # incomplete 2-byte char + | [\xE0-\xEF] [\x80-\xBF]? # incomplete 3-byte char + | [\xF0-\xF4] [\x80-\xBF]{0,2} # incomplete 4-byte char + )\z/x and $test =~ /[^\x00-\x7F]/) { + $encoding = 'utf-8-strict'; + } # end if valid UTF-8 with at least one multi-byte character: + } # end if testing for UTF-8 + + if (defined $encoding and $options->{encoding} and not ref $encoding) { + $encoding = find_encoding($encoding); + } # end if $encoding is a string and we want an object + + return wantarray ? ($encoding, $bom) : $encoding; +} # end sniff_encoding + +#===================================================================== +# Based on HTML5 8.2.2.2 Determining the character encoding: + +# Get attribute from current position of $_ +sub _get_attribute +{ + m!\G[\x09\x0A\x0C\x0D /]+!gc; # skip whitespace or / + + return if /\G>/gc or not /\G(=?[^\x09\x0A\x0C\x0D =]*)/gc; + + my ($name, $value) = (lc $1, ''); + + if (/\G[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/gc + and (/\G"([^"]*)"?/gc or + /\G'([^']*)'?/gc or + /\G([^\x09\x0A\x0C\x0D >]*)/gc)) { + $value = lc $1; + } # end if attribute has value + + return wantarray ? ($name, $value) : 1; +} # end _get_attribute + +# Examine a meta value for a charset: +sub _get_charset_from_meta +{ + for (shift) { + while (/charset[\x09\x0A\x0C\x0D ]*=[\x09\x0A\x0C\x0D ]*/ig) { + return $1 if (/\G"([^"]*)"/gc or + /\G'([^']*)'/gc or + /\G(?!['"])([^\x09\x0A\x0C\x0D ;]+)/gc); + } + } # end for value + + return undef; +} # end _get_charset_from_meta +#--------------------------------------------------------------------- + + +sub find_charset_in +{ + for (shift) { + my $options = shift || {}; + my $stop = length > 1024 ? 1024 : length; # search first 1024 bytes + + my $expect_pragma = (defined $options->{need_pragma} + ? $options->{need_pragma} : 1); + + pos() = 0; + while (pos() < $stop) { + if (/\G) or unicode. In the latter case an IDNA handling library like +L, L or recent versions of L need to be +installed. + +=item ($self|class)->can_idn + +Returns true if IDN support is available. + +=back + +=head1 FILES + +http://publicsuffix.org/list/effective_tld_names.dat + +=head1 SEE ALSO + +Domain::PublicSuffix, Mozilla::PublicSuffix + +=head1 BUGS + + Q: Why yet another module, we already have L and + L. + A: Because the public suffix data change more often than these modules do, + IO::Socket::SSL needs this list and it is more easy this way to keep it + up-to-date. + + +=head1 AUTHOR + +Steffen Ullrich + +=cut + + +BEGIN { + if ( eval { + require URI::_idna; + defined &URI::_idna::encode && defined &URI::_idna::decode + }) { + *idn_to_ascii = \&URI::_idna::encode; + *idn_to_unicode = \&URI::_idna::decode; + *can_idn = sub { 1 }; + } elsif ( eval { require Net::IDN::Encode } ) { + *idn_to_ascii = \&Net::IDN::Encode::domain_to_ascii; + *idn_to_unicode = \&Net::IDN::Encode::domain_to_unicode; + *can_idn = sub { 1 }; + } elsif ( eval { require Net::LibIDN; require Encode } ) { + # Net::LibIDN does not use utf-8 flag and expects raw data + *idn_to_ascii = sub { + Net::LibIDN::idn_to_ascii(Encode::encode('utf-8',$_[0]),'utf-8'); + }, + *idn_to_unicode = sub { + Encode::decode('utf-8',Net::LibIDN::idn_to_unicode($_[0],'utf-8')); + }, + *can_idn = sub { 1 }; + } else { + *idn_to_ascii = sub { croak "idn_to_ascii(@_) - no IDNA library installed" }; + *idn_to_unicode = sub { croak "idn_to_unicode(@_) - no IDNA library installed" }; + *can_idn = sub { 0 }; + } +} + +{ + my %default; + sub default { + my (undef,%args) = @_; + my $min_suffix = delete $args{min_suffix}; + $min_suffix = 1 if ! defined $min_suffix; + %args and die "unknown args: ".join(" ",sort keys %args); + return $default{$min_suffix} ||= shift->from_string(_default_data(), + min_suffix => $min_suffix); + } +} + +sub from_string { + my $class = shift; + my $data = shift; + open( my $fh,'<', \$data ); + return $class->from_file($fh,@_); +} + +sub from_file { + my ($class,$file,%args) = @_; + my $min_suffix = delete $args{min_suffix}; + $min_suffix = 1 if ! defined $min_suffix; + %args and die "unknown args: ".join(" ",sort keys %args); + + my $fh; + if ( ref($file)) { + $fh = $file + } elsif ( ! open($fh,'<',$file)) { + die "failed to open $file: $!"; + } + my %tree; + local $/ = "\n"; + while ( my $line = <$fh>) { + $line =~s{//.*}{}; + $line =~s{\s+$}{}; + $line eq '' and next; + my $p = \%tree; + $line = idn_to_ascii($line) if $line !~m{\A[\x00-\x7f]*\Z}; + my $not = $line =~s{^!}{}; + my @path = split(m{\.},$line); + for(reverse @path) { + $p = $p->{$_} ||= {} + } + $p->{'\0'} = $not ? -1:1; + } + return bless { + tree => \%tree, + min_suffix => $min_suffix + },$class; +} + + +sub public_suffix { + my ($self,$name,$add) = @_; + my $want; # [a]rray, [s]tring, [u]nicode-string + if ( ref($name)) { + $want = 'a'; + $name = [ @$name ]; # don't change input + } else { + return if ! defined $name; + if ( $name !~m{\A[\x00-\x7f]*\Z} ) { + $name = idn_to_ascii($name); + $want = 'u'; + } else { + $want = 's'; + } + $name = lc($name); + $name =~s{\.$}{}; + $name = [ $name =~m{([^.]+)}g ]; + } + @$name or return; + $_ = lc($_) for(@$name); + + my (%wild,%host,%xcept,@stack,$choices); + my $p = $self->{tree}; + for( my $i=0; $i<@$name; $i++ ) { + $choices = []; + if ( my $px = $p->{ $name->[$#$name-$i] } ) { + # name match, continue with next path element + push @$choices,$px; + if ( my $end = $px->{'\0'} ) { + ( $end>0 ? \%host : \%xcept )->{$i+1} = $end; + } + } + if ( my $px = $p->{'*'} ) { + # wildcard match, continue with next path element + push @$choices,$px; + if ( my $end = $px->{'\0'} ) { + ( $end>0 ? \%wild : \%xcept )->{$i+1} = $end; + } + } + + + next_choice: + if ( @$choices ) { + $p = shift(@$choices); + push @stack, [ $choices, $i ] if @$choices; + next; # go deeper + } + + # backtrack + @stack or last; + ($choices,$i) = @{ pop(@stack) }; + goto next_choice; + } + + #warn Dumper([\%wild,\%host,\%xcept]); use Data::Dumper; + + + # remove all exceptions from wildcards + delete @wild{ keys %xcept } if %xcept; + # get longest match + my ($len) = sort { $b <=> $a } ( + keys(%wild), keys(%host), map { $_-1 } keys(%xcept)); + # if we have no matches use a minimum of min_suffix + $len = $self->{min_suffix} if ! defined $len; + $len += $add if $add; + my $suffix; + if ( $len < @$name ) { + $suffix = [ splice( @$name, -$len, $len ) ]; + } elsif ( $len > 0 ) { + $suffix = $name; + $name = [] + } else { + $suffix = [] + } + + if ( $want ne 'a' ) { + $suffix = join('.',@$suffix); + $name = join('.',@$name); + if ( $want eq 'u' ) { + $suffix = idn_to_unicode($suffix); + $name = idn_to_unicode($name); + } + } + + return wantarray ? ($name,$suffix):$suffix; +} + + +{ + my $data; + sub _default_data { + if ( ! defined $data ) { + $data = _builtin_data(); + $data =~s{^// ===END ICANN DOMAINS.*}{}ms + or die "cannot find END ICANN DOMAINS"; + } + return $data; + } +} + +sub update_self_from_url { + my $url = shift || URL(); + my $dst = __FILE__; + -w $dst or die "cannot write $dst"; + open( my $fh,'<',$dst ) or die "open $dst: $!"; + my $code = ''; + local $/ = "\n"; + while (<$fh>) { + $code .= $_; + m{<<\'END_BUILTIN_DATA\'} and last; + } + my $tail; + while (<$fh>) { + m{\AEND_BUILTIN_DATA\r?\n} or next; + $tail = $_; + last; + } + $tail .= do { local $/; <$fh> }; + close($fh); + + require LWP::UserAgent; + my $resp = LWP::UserAgent->new->get($url) + or die "no response from $url"; + die "no success url=$url code=".$resp->code." ".$resp->message + if ! $resp->is_success; + my $content = $resp->decoded_content; + while ( $content =~m{(.*\n)}g ) { + my $line = $1; + if ( $line =~m{\S} && $line !~m{\A\s*//} ) { + $line =~s{//.*}{}; + $line =~s{\s+$}{}; + $line eq '' and next; + if ( $line !~m{\A[\x00-\x7f]+\Z} ) { + $line = idn_to_ascii($line); + } + $code .= "$line\n"; + } else { + $code .= "$line"; + } + } + + open( $fh,'>:utf8',$dst ) or die "open $dst: $!"; + print $fh $code.$tail; +} + +sub _builtin_data { return <<'END_BUILTIN_DATA' } +// This Source Code Form is subject to the terms of the Mozilla Public +// License, v. 2.0. If a copy of the MPL was not distributed with this +// file, You can obtain one at https://mozilla.org/MPL/2.0/. + +// Please pull this list from, and only from https://publicsuffix.org/list/public_suffix_list.dat, +// rather than any other VCS sites. Pulling from any other URL is not guaranteed to be supported. + +// Instructions on pulling and using this list can be found at https://publicsuffix.org/list/. + +// ===BEGIN ICANN DOMAINS=== + +// ac : https://en.wikipedia.org/wiki/.ac +ac +com.ac +edu.ac +gov.ac +net.ac +mil.ac +org.ac + +// ad : https://en.wikipedia.org/wiki/.ad +ad +nom.ad + +// ae : https://en.wikipedia.org/wiki/.ae +// see also: "Domain Name Eligibility Policy" at http://www.aeda.ae/eng/aepolicy.php +ae +co.ae +net.ae +org.ae +sch.ae +ac.ae +gov.ae +mil.ae + +// aero : see https://www.information.aero/index.php?id=66 +aero +accident-investigation.aero +accident-prevention.aero +aerobatic.aero +aeroclub.aero +aerodrome.aero +agents.aero +aircraft.aero +airline.aero +airport.aero +air-surveillance.aero +airtraffic.aero +air-traffic-control.aero +ambulance.aero +amusement.aero +association.aero +author.aero +ballooning.aero +broker.aero +caa.aero +cargo.aero +catering.aero +certification.aero +championship.aero +charter.aero +civilaviation.aero +club.aero +conference.aero +consultant.aero +consulting.aero +control.aero +council.aero +crew.aero +design.aero +dgca.aero +educator.aero +emergency.aero +engine.aero +engineer.aero +entertainment.aero +equipment.aero +exchange.aero +express.aero +federation.aero +flight.aero +freight.aero +fuel.aero +gliding.aero +government.aero +groundhandling.aero +group.aero +hanggliding.aero +homebuilt.aero +insurance.aero +journal.aero +journalist.aero +leasing.aero +logistics.aero +magazine.aero +maintenance.aero +media.aero +microlight.aero +modelling.aero +navigation.aero +parachuting.aero +paragliding.aero +passenger-association.aero +pilot.aero +press.aero +production.aero +recreation.aero +repbody.aero +res.aero +research.aero +rotorcraft.aero +safety.aero +scientist.aero +services.aero +show.aero +skydiving.aero +software.aero +student.aero +trader.aero +trading.aero +trainer.aero +union.aero +workinggroup.aero +works.aero + +// af : http://www.nic.af/help.jsp +af +gov.af +com.af +org.af +net.af +edu.af + +// ag : http://www.nic.ag/prices.htm +ag +com.ag +org.ag +net.ag +co.ag +nom.ag + +// ai : http://nic.com.ai/ +ai +off.ai +com.ai +net.ai +org.ai + +// al : http://www.ert.gov.al/ert_alb/faq_det.html?Id=31 +al +com.al +edu.al +gov.al +mil.al +net.al +org.al + +// am : https://en.wikipedia.org/wiki/.am +am + +// ao : https://en.wikipedia.org/wiki/.ao +// http://www.dns.ao/REGISTR.DOC +ao +ed.ao +gv.ao +og.ao +co.ao +pb.ao +it.ao + +// aq : https://en.wikipedia.org/wiki/.aq +aq + +// ar : https://nic.ar/nic-argentina/normativa-vigente +ar +com.ar +edu.ar +gob.ar +gov.ar +int.ar +mil.ar +musica.ar +net.ar +org.ar +tur.ar + +// arpa : https://en.wikipedia.org/wiki/.arpa +// Confirmed by registry 2008-06-18 +arpa +e164.arpa +in-addr.arpa +ip6.arpa +iris.arpa +uri.arpa +urn.arpa + +// as : https://en.wikipedia.org/wiki/.as +as +gov.as + +// asia : https://en.wikipedia.org/wiki/.asia +asia + +// at : https://en.wikipedia.org/wiki/.at +// Confirmed by registry 2008-06-17 +at +ac.at +co.at +gv.at +or.at + +// au : https://en.wikipedia.org/wiki/.au +// http://www.auda.org.au/ +au +// 2LDs +com.au +net.au +org.au +edu.au +gov.au +asn.au +id.au +// Historic 2LDs (closed to new registration, but sites still exist) +info.au +conf.au +oz.au +// CGDNs - http://www.cgdn.org.au/ +act.au +nsw.au +nt.au +qld.au +sa.au +tas.au +vic.au +wa.au +// 3LDs +act.edu.au +nsw.edu.au +nt.edu.au +qld.edu.au +sa.edu.au +tas.edu.au +vic.edu.au +wa.edu.au +// act.gov.au Bug 984824 - Removed at request of Greg Tankard +// nsw.gov.au Bug 547985 - Removed at request of +// nt.gov.au Bug 940478 - Removed at request of Greg Connors +qld.gov.au +sa.gov.au +tas.gov.au +vic.gov.au +wa.gov.au + +// aw : https://en.wikipedia.org/wiki/.aw +aw +com.aw + +// ax : https://en.wikipedia.org/wiki/.ax +ax + +// az : https://en.wikipedia.org/wiki/.az +az +com.az +net.az +int.az +gov.az +org.az +edu.az +info.az +pp.az +mil.az +name.az +pro.az +biz.az + +// ba : http://nic.ba/users_data/files/pravilnik_o_registraciji.pdf +ba +com.ba +edu.ba +gov.ba +mil.ba +net.ba +org.ba + +// bb : https://en.wikipedia.org/wiki/.bb +bb +biz.bb +co.bb +com.bb +edu.bb +gov.bb +info.bb +net.bb +org.bb +store.bb +tv.bb + +// bd : https://en.wikipedia.org/wiki/.bd +*.bd + +// be : https://en.wikipedia.org/wiki/.be +// Confirmed by registry 2008-06-08 +be +ac.be + +// bf : https://en.wikipedia.org/wiki/.bf +bf +gov.bf + +// bg : https://en.wikipedia.org/wiki/.bg +// https://www.register.bg/user/static/rules/en/index.html +bg +a.bg +b.bg +c.bg +d.bg +e.bg +f.bg +g.bg +h.bg +i.bg +j.bg +k.bg +l.bg +m.bg +n.bg +o.bg +p.bg +q.bg +r.bg +s.bg +t.bg +u.bg +v.bg +w.bg +x.bg +y.bg +z.bg +0.bg +1.bg +2.bg +3.bg +4.bg +5.bg +6.bg +7.bg +8.bg +9.bg + +// bh : https://en.wikipedia.org/wiki/.bh +bh +com.bh +edu.bh +net.bh +org.bh +gov.bh + +// bi : https://en.wikipedia.org/wiki/.bi +// http://whois.nic.bi/ +bi +co.bi +com.bi +edu.bi +or.bi +org.bi + +// biz : https://en.wikipedia.org/wiki/.biz +biz + +// bj : https://en.wikipedia.org/wiki/.bj +bj +asso.bj +barreau.bj +gouv.bj + +// bm : http://www.bermudanic.bm/dnr-text.txt +bm +com.bm +edu.bm +gov.bm +net.bm +org.bm + +// bn : https://en.wikipedia.org/wiki/.bn +*.bn + +// bo : https://nic.bo/delegacion2015.php#h-1.10 +bo +com.bo +edu.bo +gob.bo +int.bo +org.bo +net.bo +mil.bo +tv.bo +web.bo +// Social Domains +academia.bo +agro.bo +arte.bo +blog.bo +bolivia.bo +ciencia.bo +cooperativa.bo +democracia.bo +deporte.bo +ecologia.bo +economia.bo +empresa.bo +indigena.bo +industria.bo +info.bo +medicina.bo +movimiento.bo +musica.bo +natural.bo +nombre.bo +noticias.bo +patria.bo +politica.bo +profesional.bo +plurinacional.bo +pueblo.bo +revista.bo +salud.bo +tecnologia.bo +tksat.bo +transporte.bo +wiki.bo + +// br : http://registro.br/dominio/categoria.html +// Submitted by registry +br +9guacu.br +abc.br +adm.br +adv.br +agr.br +aju.br +am.br +anani.br +aparecida.br +arq.br +art.br +ato.br +b.br +belem.br +bhz.br +bio.br +blog.br +bmd.br +boavista.br +bsb.br +campinagrande.br +campinas.br +caxias.br +cim.br +cng.br +cnt.br +com.br +contagem.br +coop.br +cri.br +cuiaba.br +curitiba.br +def.br +ecn.br +eco.br +edu.br +emp.br +eng.br +esp.br +etc.br +eti.br +far.br +feira.br +flog.br +floripa.br +fm.br +fnd.br +fortal.br +fot.br +foz.br +fst.br +g12.br +ggf.br +goiania.br +gov.br +// gov.br 26 states + df https://en.wikipedia.org/wiki/States_of_Brazil +ac.gov.br +al.gov.br +am.gov.br +ap.gov.br +ba.gov.br +ce.gov.br +df.gov.br +es.gov.br +go.gov.br +ma.gov.br +mg.gov.br +ms.gov.br +mt.gov.br +pa.gov.br +pb.gov.br +pe.gov.br +pi.gov.br +pr.gov.br +rj.gov.br +rn.gov.br +ro.gov.br +rr.gov.br +rs.gov.br +sc.gov.br +se.gov.br +sp.gov.br +to.gov.br +gru.br +imb.br +ind.br +inf.br +jab.br +jampa.br +jdf.br +joinville.br +jor.br +jus.br +leg.br +lel.br +londrina.br +macapa.br +maceio.br +manaus.br +maringa.br +mat.br +med.br +mil.br +morena.br +mp.br +mus.br +natal.br +net.br +niteroi.br +*.nom.br +not.br +ntr.br +odo.br +org.br +osasco.br +palmas.br +poa.br +ppg.br +pro.br +psc.br +psi.br +pvh.br +qsl.br +radio.br +rec.br +recife.br +ribeirao.br +rio.br +riobranco.br +riopreto.br +salvador.br +sampa.br +santamaria.br +santoandre.br +saobernardo.br +saogonca.br +sjc.br +slg.br +slz.br +sorocaba.br +srv.br +taxi.br +teo.br +the.br +tmp.br +trd.br +tur.br +tv.br +udi.br +vet.br +vix.br +vlog.br +wiki.br +zlg.br + +// bs : http://www.nic.bs/rules.html +bs +com.bs +net.bs +org.bs +edu.bs +gov.bs + +// bt : https://en.wikipedia.org/wiki/.bt +bt +com.bt +edu.bt +gov.bt +net.bt +org.bt + +// bv : No registrations at this time. +// Submitted by registry +bv + +// bw : https://en.wikipedia.org/wiki/.bw +// http://www.gobin.info/domainname/bw.doc +// list of other 2nd level tlds ? +bw +co.bw +org.bw + +// by : https://en.wikipedia.org/wiki/.by +// http://tld.by/rules_2006_en.html +// list of other 2nd level tlds ? +by +gov.by +mil.by +// Official information does not indicate that com.by is a reserved +// second-level domain, but it's being used as one (see www.google.com.by and +// www.yahoo.com.by, for example), so we list it here for safety's sake. +com.by + +// http://hoster.by/ +of.by + +// bz : https://en.wikipedia.org/wiki/.bz +// http://www.belizenic.bz/ +bz +com.bz +net.bz +org.bz +edu.bz +gov.bz + +// ca : https://en.wikipedia.org/wiki/.ca +ca +// ca geographical names +ab.ca +bc.ca +mb.ca +nb.ca +nf.ca +nl.ca +ns.ca +nt.ca +nu.ca +on.ca +pe.ca +qc.ca +sk.ca +yk.ca +// gc.ca: https://en.wikipedia.org/wiki/.gc.ca +// see also: http://registry.gc.ca/en/SubdomainFAQ +gc.ca + +// cat : https://en.wikipedia.org/wiki/.cat +cat + +// cc : https://en.wikipedia.org/wiki/.cc +cc + +// cd : https://en.wikipedia.org/wiki/.cd +// see also: https://www.nic.cd/domain/insertDomain_2.jsp?act=1 +cd +gov.cd + +// cf : https://en.wikipedia.org/wiki/.cf +cf + +// cg : https://en.wikipedia.org/wiki/.cg +cg + +// ch : https://en.wikipedia.org/wiki/.ch +ch + +// ci : https://en.wikipedia.org/wiki/.ci +// http://www.nic.ci/index.php?page=charte +ci +org.ci +or.ci +com.ci +co.ci +edu.ci +ed.ci +ac.ci +net.ci +go.ci +asso.ci +xn--aroport-bya.ci +int.ci +presse.ci +md.ci +gouv.ci + +// ck : https://en.wikipedia.org/wiki/.ck +*.ck +!www.ck + +// cl : https://en.wikipedia.org/wiki/.cl +cl +gov.cl +gob.cl +co.cl +mil.cl + +// cm : https://en.wikipedia.org/wiki/.cm plus bug 981927 +cm +co.cm +com.cm +gov.cm +net.cm + +// cn : https://en.wikipedia.org/wiki/.cn +// Submitted by registry +cn +ac.cn +com.cn +edu.cn +gov.cn +net.cn +org.cn +mil.cn +xn--55qx5d.cn +xn--io0a7i.cn +xn--od0alg.cn +// cn geographic names +ah.cn +bj.cn +cq.cn +fj.cn +gd.cn +gs.cn +gz.cn +gx.cn +ha.cn +hb.cn +he.cn +hi.cn +hl.cn +hn.cn +jl.cn +js.cn +jx.cn +ln.cn +nm.cn +nx.cn +qh.cn +sc.cn +sd.cn +sh.cn +sn.cn +sx.cn +tj.cn +xj.cn +xz.cn +yn.cn +zj.cn +hk.cn +mo.cn +tw.cn + +// co : https://en.wikipedia.org/wiki/.co +// Submitted by registry +co +arts.co +com.co +edu.co +firm.co +gov.co +info.co +int.co +mil.co +net.co +nom.co +org.co +rec.co +web.co + +// com : https://en.wikipedia.org/wiki/.com +com + +// coop : https://en.wikipedia.org/wiki/.coop +coop + +// cr : http://www.nic.cr/niccr_publico/showRegistroDominiosScreen.do +cr +ac.cr +co.cr +ed.cr +fi.cr +go.cr +or.cr +sa.cr + +// cu : https://en.wikipedia.org/wiki/.cu +cu +com.cu +edu.cu +org.cu +net.cu +gov.cu +inf.cu + +// cv : https://en.wikipedia.org/wiki/.cv +cv + +// cw : http://www.una.cw/cw_registry/ +// Confirmed by registry 2013-03-26 +cw +com.cw +edu.cw +net.cw +org.cw + +// cx : https://en.wikipedia.org/wiki/.cx +// list of other 2nd level tlds ? +cx +gov.cx + +// cy : http://www.nic.cy/ +// Submitted by registry Panayiotou Fotia +cy +ac.cy +biz.cy +com.cy +ekloges.cy +gov.cy +ltd.cy +name.cy +net.cy +org.cy +parliament.cy +press.cy +pro.cy +tm.cy + +// cz : https://en.wikipedia.org/wiki/.cz +cz + +// de : https://en.wikipedia.org/wiki/.de +// Confirmed by registry (with technical +// reservations) 2008-07-01 +de + +// dj : https://en.wikipedia.org/wiki/.dj +dj + +// dk : https://en.wikipedia.org/wiki/.dk +// Confirmed by registry 2008-06-17 +dk + +// dm : https://en.wikipedia.org/wiki/.dm +dm +com.dm +net.dm +org.dm +edu.dm +gov.dm + +// do : https://en.wikipedia.org/wiki/.do +do +art.do +com.do +edu.do +gob.do +gov.do +mil.do +net.do +org.do +sld.do +web.do + +// dz : https://en.wikipedia.org/wiki/.dz +dz +com.dz +org.dz +net.dz +gov.dz +edu.dz +asso.dz +pol.dz +art.dz + +// ec : http://www.nic.ec/reg/paso1.asp +// Submitted by registry +ec +com.ec +info.ec +net.ec +fin.ec +k12.ec +med.ec +pro.ec +org.ec +edu.ec +gov.ec +gob.ec +mil.ec + +// edu : https://en.wikipedia.org/wiki/.edu +edu + +// ee : http://www.eenet.ee/EENet/dom_reeglid.html#lisa_B +ee +edu.ee +gov.ee +riik.ee +lib.ee +med.ee +com.ee +pri.ee +aip.ee +org.ee +fie.ee + +// eg : https://en.wikipedia.org/wiki/.eg +eg +com.eg +edu.eg +eun.eg +gov.eg +mil.eg +name.eg +net.eg +org.eg +sci.eg + +// er : https://en.wikipedia.org/wiki/.er +*.er + +// es : https://www.nic.es/site_ingles/ingles/dominios/index.html +es +com.es +nom.es +org.es +gob.es +edu.es + +// et : https://en.wikipedia.org/wiki/.et +et +com.et +gov.et +org.et +edu.et +biz.et +name.et +info.et +net.et + +// eu : https://en.wikipedia.org/wiki/.eu +eu + +// fi : https://en.wikipedia.org/wiki/.fi +fi +// aland.fi : https://en.wikipedia.org/wiki/.ax +// This domain is being phased out in favor of .ax. As there are still many +// domains under aland.fi, we still keep it on the list until aland.fi is +// completely removed. +// TODO: Check for updates (expected to be phased out around Q1/2009) +aland.fi + +// fj : https://en.wikipedia.org/wiki/.fj +*.fj + +// fk : https://en.wikipedia.org/wiki/.fk +*.fk + +// fm : https://en.wikipedia.org/wiki/.fm +fm + +// fo : https://en.wikipedia.org/wiki/.fo +fo + +// fr : http://www.afnic.fr/ +// domaines descriptifs : http://www.afnic.fr/obtenir/chartes/nommage-fr/annexe-descriptifs +fr +com.fr +asso.fr +nom.fr +prd.fr +presse.fr +tm.fr +// domaines sectoriels : http://www.afnic.fr/obtenir/chartes/nommage-fr/annexe-sectoriels +aeroport.fr +assedic.fr +avocat.fr +avoues.fr +cci.fr +chambagri.fr +chirurgiens-dentistes.fr +experts-comptables.fr +geometre-expert.fr +gouv.fr +greta.fr +huissier-justice.fr +medecin.fr +notaires.fr +pharmacien.fr +port.fr +veterinaire.fr + +// ga : https://en.wikipedia.org/wiki/.ga +ga + +// gb : This registry is effectively dormant +// Submitted by registry +gb + +// gd : https://en.wikipedia.org/wiki/.gd +gd + +// ge : http://www.nic.net.ge/policy_en.pdf +ge +com.ge +edu.ge +gov.ge +org.ge +mil.ge +net.ge +pvt.ge + +// gf : https://en.wikipedia.org/wiki/.gf +gf + +// gg : http://www.channelisles.net/register-domains/ +// Confirmed by registry 2013-11-28 +gg +co.gg +net.gg +org.gg + +// gh : https://en.wikipedia.org/wiki/.gh +// see also: http://www.nic.gh/reg_now.php +// Although domains directly at second level are not possible at the moment, +// they have been possible for some time and may come back. +gh +com.gh +edu.gh +gov.gh +org.gh +mil.gh + +// gi : http://www.nic.gi/rules.html +gi +com.gi +ltd.gi +gov.gi +mod.gi +edu.gi +org.gi + +// gl : https://en.wikipedia.org/wiki/.gl +// http://nic.gl +gl +co.gl +com.gl +edu.gl +net.gl +org.gl + +// gm : http://www.nic.gm/htmlpages%5Cgm-policy.htm +gm + +// gn : http://psg.com/dns/gn/gn.txt +// Submitted by registry +gn +ac.gn +com.gn +edu.gn +gov.gn +org.gn +net.gn + +// gov : https://en.wikipedia.org/wiki/.gov +gov + +// gp : http://www.nic.gp/index.php?lang=en +gp +com.gp +net.gp +mobi.gp +edu.gp +org.gp +asso.gp + +// gq : https://en.wikipedia.org/wiki/.gq +gq + +// gr : https://grweb.ics.forth.gr/english/1617-B-2005.html +// Submitted by registry +gr +com.gr +edu.gr +net.gr +org.gr +gov.gr + +// gs : https://en.wikipedia.org/wiki/.gs +gs + +// gt : http://www.gt/politicas_de_registro.html +gt +com.gt +edu.gt +gob.gt +ind.gt +mil.gt +net.gt +org.gt + +// gu : http://gadao.gov.gu/registration.txt +*.gu + +// gw : https://en.wikipedia.org/wiki/.gw +gw + +// gy : https://en.wikipedia.org/wiki/.gy +// http://registry.gy/ +gy +co.gy +com.gy +edu.gy +gov.gy +net.gy +org.gy + +// hk : https://www.hkdnr.hk +// Submitted by registry +hk +com.hk +edu.hk +gov.hk +idv.hk +net.hk +org.hk +xn--55qx5d.hk +xn--wcvs22d.hk +xn--lcvr32d.hk +xn--mxtq1m.hk +xn--gmqw5a.hk +xn--ciqpn.hk +xn--gmq050i.hk +xn--zf0avx.hk +xn--io0a7i.hk +xn--mk0axi.hk +xn--od0alg.hk +xn--od0aq3b.hk +xn--tn0ag.hk +xn--uc0atv.hk +xn--uc0ay4a.hk + +// hm : https://en.wikipedia.org/wiki/.hm +hm + +// hn : http://www.nic.hn/politicas/ps02,,05.html +hn +com.hn +edu.hn +org.hn +net.hn +mil.hn +gob.hn + +// hr : http://www.dns.hr/documents/pdf/HRTLD-regulations.pdf +hr +iz.hr +from.hr +name.hr +com.hr + +// ht : http://www.nic.ht/info/charte.cfm +ht +com.ht +shop.ht +firm.ht +info.ht +adult.ht +net.ht +pro.ht +org.ht +med.ht +art.ht +coop.ht +pol.ht +asso.ht +edu.ht +rel.ht +gouv.ht +perso.ht + +// hu : http://www.domain.hu/domain/English/sld.html +// Confirmed by registry 2008-06-12 +hu +co.hu +info.hu +org.hu +priv.hu +sport.hu +tm.hu +2000.hu +agrar.hu +bolt.hu +casino.hu +city.hu +erotica.hu +erotika.hu +film.hu +forum.hu +games.hu +hotel.hu +ingatlan.hu +jogasz.hu +konyvelo.hu +lakas.hu +media.hu +news.hu +reklam.hu +sex.hu +shop.hu +suli.hu +szex.hu +tozsde.hu +utazas.hu +video.hu + +// id : https://register.pandi.or.id/ +id +ac.id +biz.id +co.id +desa.id +go.id +mil.id +my.id +net.id +or.id +sch.id +web.id + +// ie : https://en.wikipedia.org/wiki/.ie +ie +gov.ie + +// il : http://www.isoc.org.il/domains/ +il +ac.il +co.il +gov.il +idf.il +k12.il +muni.il +net.il +org.il + +// im : https://www.nic.im/ +// Submitted by registry +im +ac.im +co.im +com.im +ltd.co.im +net.im +org.im +plc.co.im +tt.im +tv.im + +// in : https://en.wikipedia.org/wiki/.in +// see also: https://registry.in/Policies +// Please note, that nic.in is not an official eTLD, but used by most +// government institutions. +in +co.in +firm.in +net.in +org.in +gen.in +ind.in +nic.in +ac.in +edu.in +res.in +gov.in +mil.in + +// info : https://en.wikipedia.org/wiki/.info +info + +// int : https://en.wikipedia.org/wiki/.int +// Confirmed by registry 2008-06-18 +int +eu.int + +// io : http://www.nic.io/rules.html +// list of other 2nd level tlds ? +io +com.io + +// iq : http://www.cmc.iq/english/iq/iqregister1.htm +iq +gov.iq +edu.iq +mil.iq +com.iq +org.iq +net.iq + +// ir : http://www.nic.ir/Terms_and_Conditions_ir,_Appendix_1_Domain_Rules +// Also see http://www.nic.ir/Internationalized_Domain_Names +// Two .ir entries added at request of , 2010-04-16 +ir +ac.ir +co.ir +gov.ir +id.ir +net.ir +org.ir +sch.ir +// xn--mgba3a4f16a.ir (.ir, Persian YEH) +xn--mgba3a4f16a.ir +// xn--mgba3a4fra.ir (.ir, Arabic YEH) +xn--mgba3a4fra.ir + +// is : http://www.isnic.is/domain/rules.php +// Confirmed by registry 2008-12-06 +is +net.is +com.is +edu.is +gov.is +org.is +int.is + +// it : https://en.wikipedia.org/wiki/.it +it +gov.it +edu.it +// Reserved geo-names: +// http://www.nic.it/documenti/regolamenti-e-linee-guida/regolamento-assegnazione-versione-6.0.pdf +// There is also a list of reserved geo-names corresponding to Italian municipalities +// http://www.nic.it/documenti/appendice-c.pdf, but it is not included here. +// Regions +abr.it +abruzzo.it +aosta-valley.it +aostavalley.it +bas.it +basilicata.it +cal.it +calabria.it +cam.it +campania.it +emilia-romagna.it +emiliaromagna.it +emr.it +friuli-v-giulia.it +friuli-ve-giulia.it +friuli-vegiulia.it +friuli-venezia-giulia.it +friuli-veneziagiulia.it +friuli-vgiulia.it +friuliv-giulia.it +friulive-giulia.it +friulivegiulia.it +friulivenezia-giulia.it +friuliveneziagiulia.it +friulivgiulia.it +fvg.it +laz.it +lazio.it +lig.it +liguria.it +lom.it +lombardia.it +lombardy.it +lucania.it +mar.it +marche.it +mol.it +molise.it +piedmont.it +piemonte.it +pmn.it +pug.it +puglia.it +sar.it +sardegna.it +sardinia.it +sic.it +sicilia.it +sicily.it +taa.it +tos.it +toscana.it +trentino-a-adige.it +trentino-aadige.it +trentino-alto-adige.it +trentino-altoadige.it +trentino-s-tirol.it +trentino-stirol.it +trentino-sud-tirol.it +trentino-sudtirol.it +trentino-sued-tirol.it +trentino-suedtirol.it +trentinoa-adige.it +trentinoaadige.it +trentinoalto-adige.it +trentinoaltoadige.it +trentinos-tirol.it +trentinostirol.it +trentinosud-tirol.it +trentinosudtirol.it +trentinosued-tirol.it +trentinosuedtirol.it +tuscany.it +umb.it +umbria.it +val-d-aosta.it +val-daosta.it +vald-aosta.it +valdaosta.it +valle-aosta.it +valle-d-aosta.it +valle-daosta.it +valleaosta.it +valled-aosta.it +valledaosta.it +vallee-aoste.it +valleeaoste.it +vao.it +vda.it +ven.it +veneto.it +// Provinces +ag.it +agrigento.it +al.it +alessandria.it +alto-adige.it +altoadige.it +an.it +ancona.it +andria-barletta-trani.it +andria-trani-barletta.it +andriabarlettatrani.it +andriatranibarletta.it +ao.it +aosta.it +aoste.it +ap.it +aq.it +aquila.it +ar.it +arezzo.it +ascoli-piceno.it +ascolipiceno.it +asti.it +at.it +av.it +avellino.it +ba.it +balsan.it +bari.it +barletta-trani-andria.it +barlettatraniandria.it +belluno.it +benevento.it +bergamo.it +bg.it +bi.it +biella.it +bl.it +bn.it +bo.it +bologna.it +bolzano.it +bozen.it +br.it +brescia.it +brindisi.it +bs.it +bt.it +bz.it +ca.it +cagliari.it +caltanissetta.it +campidano-medio.it +campidanomedio.it +campobasso.it +carbonia-iglesias.it +carboniaiglesias.it +carrara-massa.it +carraramassa.it +caserta.it +catania.it +catanzaro.it +cb.it +ce.it +cesena-forli.it +cesenaforli.it +ch.it +chieti.it +ci.it +cl.it +cn.it +co.it +como.it +cosenza.it +cr.it +cremona.it +crotone.it +cs.it +ct.it +cuneo.it +cz.it +dell-ogliastra.it +dellogliastra.it +en.it +enna.it +fc.it +fe.it +fermo.it +ferrara.it +fg.it +fi.it +firenze.it +florence.it +fm.it +foggia.it +forli-cesena.it +forlicesena.it +fr.it +frosinone.it +ge.it +genoa.it +genova.it +go.it +gorizia.it +gr.it +grosseto.it +iglesias-carbonia.it +iglesiascarbonia.it +im.it +imperia.it +is.it +isernia.it +kr.it +la-spezia.it +laquila.it +laspezia.it +latina.it +lc.it +le.it +lecce.it +lecco.it +li.it +livorno.it +lo.it +lodi.it +lt.it +lu.it +lucca.it +macerata.it +mantova.it +massa-carrara.it +massacarrara.it +matera.it +mb.it +mc.it +me.it +medio-campidano.it +mediocampidano.it +messina.it +mi.it +milan.it +milano.it +mn.it +mo.it +modena.it +monza-brianza.it +monza-e-della-brianza.it +monza.it +monzabrianza.it +monzaebrianza.it +monzaedellabrianza.it +ms.it +mt.it +na.it +naples.it +napoli.it +no.it +novara.it +nu.it +nuoro.it +og.it +ogliastra.it +olbia-tempio.it +olbiatempio.it +or.it +oristano.it +ot.it +pa.it +padova.it +padua.it +palermo.it +parma.it +pavia.it +pc.it +pd.it +pe.it +perugia.it +pesaro-urbino.it +pesarourbino.it +pescara.it +pg.it +pi.it +piacenza.it +pisa.it +pistoia.it +pn.it +po.it +pordenone.it +potenza.it +pr.it +prato.it +pt.it +pu.it +pv.it +pz.it +ra.it +ragusa.it +ravenna.it +rc.it +re.it +reggio-calabria.it +reggio-emilia.it +reggiocalabria.it +reggioemilia.it +rg.it +ri.it +rieti.it +rimini.it +rm.it +rn.it +ro.it +roma.it +rome.it +rovigo.it +sa.it +salerno.it +sassari.it +savona.it +si.it +siena.it +siracusa.it +so.it +sondrio.it +sp.it +sr.it +ss.it +suedtirol.it +sv.it +ta.it +taranto.it +te.it +tempio-olbia.it +tempioolbia.it +teramo.it +terni.it +tn.it +to.it +torino.it +tp.it +tr.it +trani-andria-barletta.it +trani-barletta-andria.it +traniandriabarletta.it +tranibarlettaandria.it +trapani.it +trentino.it +trento.it +treviso.it +trieste.it +ts.it +turin.it +tv.it +ud.it +udine.it +urbino-pesaro.it +urbinopesaro.it +va.it +varese.it +vb.it +vc.it +ve.it +venezia.it +venice.it +verbania.it +vercelli.it +verona.it +vi.it +vibo-valentia.it +vibovalentia.it +vicenza.it +viterbo.it +vr.it +vs.it +vt.it +vv.it + +// je : http://www.channelisles.net/register-domains/ +// Confirmed by registry 2013-11-28 +je +co.je +net.je +org.je + +// jm : http://www.com.jm/register.html +*.jm + +// jo : http://www.dns.jo/Registration_policy.aspx +jo +com.jo +org.jo +net.jo +edu.jo +sch.jo +gov.jo +mil.jo +name.jo + +// jobs : https://en.wikipedia.org/wiki/.jobs +jobs + +// jp : https://en.wikipedia.org/wiki/.jp +// http://jprs.co.jp/en/jpdomain.html +// Submitted by registry +jp +// jp organizational type names +ac.jp +ad.jp +co.jp +ed.jp +go.jp +gr.jp +lg.jp +ne.jp +or.jp +// jp prefecture type names +aichi.jp +akita.jp +aomori.jp +chiba.jp +ehime.jp +fukui.jp +fukuoka.jp +fukushima.jp +gifu.jp +gunma.jp +hiroshima.jp +hokkaido.jp +hyogo.jp +ibaraki.jp +ishikawa.jp +iwate.jp +kagawa.jp +kagoshima.jp +kanagawa.jp +kochi.jp +kumamoto.jp +kyoto.jp +mie.jp +miyagi.jp +miyazaki.jp +nagano.jp +nagasaki.jp +nara.jp +niigata.jp +oita.jp +okayama.jp +okinawa.jp +osaka.jp +saga.jp +saitama.jp +shiga.jp +shimane.jp +shizuoka.jp +tochigi.jp +tokushima.jp +tokyo.jp +tottori.jp +toyama.jp +wakayama.jp +yamagata.jp +yamaguchi.jp +yamanashi.jp +xn--4pvxs.jp +xn--vgu402c.jp +xn--c3s14m.jp +xn--f6qx53a.jp +xn--8pvr4u.jp +xn--uist22h.jp +xn--djrs72d6uy.jp +xn--mkru45i.jp +xn--0trq7p7nn.jp +xn--8ltr62k.jp +xn--2m4a15e.jp +xn--efvn9s.jp +xn--32vp30h.jp +xn--4it797k.jp +xn--1lqs71d.jp +xn--5rtp49c.jp +xn--5js045d.jp +xn--ehqz56n.jp +xn--1lqs03n.jp +xn--qqqt11m.jp +xn--kbrq7o.jp +xn--pssu33l.jp +xn--ntsq17g.jp +xn--uisz3g.jp +xn--6btw5a.jp +xn--1ctwo.jp +xn--6orx2r.jp +xn--rht61e.jp +xn--rht27z.jp +xn--djty4k.jp +xn--nit225k.jp +xn--rht3d.jp +xn--klty5x.jp +xn--kltx9a.jp +xn--kltp7d.jp +xn--uuwu58a.jp +xn--zbx025d.jp +xn--ntso0iqx3a.jp +xn--elqq16h.jp +xn--4it168d.jp +xn--klt787d.jp +xn--rny31h.jp +xn--7t0a264c.jp +xn--5rtq34k.jp +xn--k7yn95e.jp +xn--tor131o.jp +xn--d5qv7z876c.jp +// jp geographic type names +// http://jprs.jp/doc/rule/saisoku-1.html +*.kawasaki.jp +*.kitakyushu.jp +*.kobe.jp +*.nagoya.jp +*.sapporo.jp +*.sendai.jp +*.yokohama.jp +!city.kawasaki.jp +!city.kitakyushu.jp +!city.kobe.jp +!city.nagoya.jp +!city.sapporo.jp +!city.sendai.jp +!city.yokohama.jp +// 4th level registration +aisai.aichi.jp +ama.aichi.jp +anjo.aichi.jp +asuke.aichi.jp +chiryu.aichi.jp +chita.aichi.jp +fuso.aichi.jp +gamagori.aichi.jp +handa.aichi.jp +hazu.aichi.jp +hekinan.aichi.jp +higashiura.aichi.jp +ichinomiya.aichi.jp +inazawa.aichi.jp +inuyama.aichi.jp +isshiki.aichi.jp +iwakura.aichi.jp +kanie.aichi.jp +kariya.aichi.jp +kasugai.aichi.jp +kira.aichi.jp +kiyosu.aichi.jp +komaki.aichi.jp +konan.aichi.jp +kota.aichi.jp +mihama.aichi.jp +miyoshi.aichi.jp +nishio.aichi.jp +nisshin.aichi.jp +obu.aichi.jp +oguchi.aichi.jp +oharu.aichi.jp +okazaki.aichi.jp +owariasahi.aichi.jp +seto.aichi.jp +shikatsu.aichi.jp +shinshiro.aichi.jp +shitara.aichi.jp +tahara.aichi.jp +takahama.aichi.jp +tobishima.aichi.jp +toei.aichi.jp +togo.aichi.jp +tokai.aichi.jp +tokoname.aichi.jp +toyoake.aichi.jp +toyohashi.aichi.jp +toyokawa.aichi.jp +toyone.aichi.jp +toyota.aichi.jp +tsushima.aichi.jp +yatomi.aichi.jp +akita.akita.jp +daisen.akita.jp +fujisato.akita.jp +gojome.akita.jp +hachirogata.akita.jp +happou.akita.jp +higashinaruse.akita.jp +honjo.akita.jp +honjyo.akita.jp +ikawa.akita.jp +kamikoani.akita.jp +kamioka.akita.jp +katagami.akita.jp +kazuno.akita.jp +kitaakita.akita.jp +kosaka.akita.jp +kyowa.akita.jp +misato.akita.jp +mitane.akita.jp +moriyoshi.akita.jp +nikaho.akita.jp +noshiro.akita.jp +odate.akita.jp +oga.akita.jp +ogata.akita.jp +semboku.akita.jp +yokote.akita.jp +yurihonjo.akita.jp +aomori.aomori.jp +gonohe.aomori.jp +hachinohe.aomori.jp +hashikami.aomori.jp +hiranai.aomori.jp +hirosaki.aomori.jp +itayanagi.aomori.jp +kuroishi.aomori.jp +misawa.aomori.jp +mutsu.aomori.jp +nakadomari.aomori.jp +noheji.aomori.jp +oirase.aomori.jp +owani.aomori.jp +rokunohe.aomori.jp +sannohe.aomori.jp +shichinohe.aomori.jp +shingo.aomori.jp +takko.aomori.jp +towada.aomori.jp +tsugaru.aomori.jp +tsuruta.aomori.jp +abiko.chiba.jp +asahi.chiba.jp +chonan.chiba.jp +chosei.chiba.jp +choshi.chiba.jp +chuo.chiba.jp +funabashi.chiba.jp +futtsu.chiba.jp +hanamigawa.chiba.jp +ichihara.chiba.jp +ichikawa.chiba.jp +ichinomiya.chiba.jp +inzai.chiba.jp +isumi.chiba.jp +kamagaya.chiba.jp +kamogawa.chiba.jp +kashiwa.chiba.jp +katori.chiba.jp +katsuura.chiba.jp +kimitsu.chiba.jp +kisarazu.chiba.jp +kozaki.chiba.jp +kujukuri.chiba.jp +kyonan.chiba.jp +matsudo.chiba.jp +midori.chiba.jp +mihama.chiba.jp +minamiboso.chiba.jp +mobara.chiba.jp +mutsuzawa.chiba.jp +nagara.chiba.jp +nagareyama.chiba.jp +narashino.chiba.jp +narita.chiba.jp +noda.chiba.jp +oamishirasato.chiba.jp +omigawa.chiba.jp +onjuku.chiba.jp +otaki.chiba.jp +sakae.chiba.jp +sakura.chiba.jp +shimofusa.chiba.jp +shirako.chiba.jp +shiroi.chiba.jp +shisui.chiba.jp +sodegaura.chiba.jp +sosa.chiba.jp +tako.chiba.jp +tateyama.chiba.jp +togane.chiba.jp +tohnosho.chiba.jp +tomisato.chiba.jp +urayasu.chiba.jp +yachimata.chiba.jp +yachiyo.chiba.jp +yokaichiba.chiba.jp +yokoshibahikari.chiba.jp +yotsukaido.chiba.jp +ainan.ehime.jp +honai.ehime.jp +ikata.ehime.jp +imabari.ehime.jp +iyo.ehime.jp +kamijima.ehime.jp +kihoku.ehime.jp +kumakogen.ehime.jp +masaki.ehime.jp +matsuno.ehime.jp +matsuyama.ehime.jp +namikata.ehime.jp +niihama.ehime.jp +ozu.ehime.jp +saijo.ehime.jp +seiyo.ehime.jp +shikokuchuo.ehime.jp +tobe.ehime.jp +toon.ehime.jp +uchiko.ehime.jp +uwajima.ehime.jp +yawatahama.ehime.jp +echizen.fukui.jp +eiheiji.fukui.jp +fukui.fukui.jp +ikeda.fukui.jp +katsuyama.fukui.jp +mihama.fukui.jp +minamiechizen.fukui.jp +obama.fukui.jp +ohi.fukui.jp +ono.fukui.jp +sabae.fukui.jp +sakai.fukui.jp +takahama.fukui.jp +tsuruga.fukui.jp +wakasa.fukui.jp +ashiya.fukuoka.jp +buzen.fukuoka.jp +chikugo.fukuoka.jp +chikuho.fukuoka.jp +chikujo.fukuoka.jp +chikushino.fukuoka.jp +chikuzen.fukuoka.jp +chuo.fukuoka.jp +dazaifu.fukuoka.jp +fukuchi.fukuoka.jp +hakata.fukuoka.jp +higashi.fukuoka.jp +hirokawa.fukuoka.jp +hisayama.fukuoka.jp +iizuka.fukuoka.jp +inatsuki.fukuoka.jp +kaho.fukuoka.jp +kasuga.fukuoka.jp +kasuya.fukuoka.jp +kawara.fukuoka.jp +keisen.fukuoka.jp +koga.fukuoka.jp +kurate.fukuoka.jp +kurogi.fukuoka.jp +kurume.fukuoka.jp +minami.fukuoka.jp +miyako.fukuoka.jp +miyama.fukuoka.jp +miyawaka.fukuoka.jp +mizumaki.fukuoka.jp +munakata.fukuoka.jp +nakagawa.fukuoka.jp +nakama.fukuoka.jp +nishi.fukuoka.jp +nogata.fukuoka.jp +ogori.fukuoka.jp +okagaki.fukuoka.jp +okawa.fukuoka.jp +oki.fukuoka.jp +omuta.fukuoka.jp +onga.fukuoka.jp +onojo.fukuoka.jp +oto.fukuoka.jp +saigawa.fukuoka.jp +sasaguri.fukuoka.jp +shingu.fukuoka.jp +shinyoshitomi.fukuoka.jp +shonai.fukuoka.jp +soeda.fukuoka.jp +sue.fukuoka.jp +tachiarai.fukuoka.jp +tagawa.fukuoka.jp +takata.fukuoka.jp +toho.fukuoka.jp +toyotsu.fukuoka.jp +tsuiki.fukuoka.jp +ukiha.fukuoka.jp +umi.fukuoka.jp +usui.fukuoka.jp +yamada.fukuoka.jp +yame.fukuoka.jp +yanagawa.fukuoka.jp +yukuhashi.fukuoka.jp +aizubange.fukushima.jp +aizumisato.fukushima.jp +aizuwakamatsu.fukushima.jp +asakawa.fukushima.jp +bandai.fukushima.jp +date.fukushima.jp +fukushima.fukushima.jp +furudono.fukushima.jp +futaba.fukushima.jp +hanawa.fukushima.jp +higashi.fukushima.jp +hirata.fukushima.jp +hirono.fukushima.jp +iitate.fukushima.jp +inawashiro.fukushima.jp +ishikawa.fukushima.jp +iwaki.fukushima.jp +izumizaki.fukushima.jp +kagamiishi.fukushima.jp +kaneyama.fukushima.jp +kawamata.fukushima.jp +kitakata.fukushima.jp +kitashiobara.fukushima.jp +koori.fukushima.jp +koriyama.fukushima.jp +kunimi.fukushima.jp +miharu.fukushima.jp +mishima.fukushima.jp +namie.fukushima.jp +nango.fukushima.jp +nishiaizu.fukushima.jp +nishigo.fukushima.jp +okuma.fukushima.jp +omotego.fukushima.jp +ono.fukushima.jp +otama.fukushima.jp +samegawa.fukushima.jp +shimogo.fukushima.jp +shirakawa.fukushima.jp +showa.fukushima.jp +soma.fukushima.jp +sukagawa.fukushima.jp +taishin.fukushima.jp +tamakawa.fukushima.jp +tanagura.fukushima.jp +tenei.fukushima.jp +yabuki.fukushima.jp +yamato.fukushima.jp +yamatsuri.fukushima.jp +yanaizu.fukushima.jp +yugawa.fukushima.jp +anpachi.gifu.jp +ena.gifu.jp +gifu.gifu.jp +ginan.gifu.jp +godo.gifu.jp +gujo.gifu.jp +hashima.gifu.jp +hichiso.gifu.jp +hida.gifu.jp +higashishirakawa.gifu.jp +ibigawa.gifu.jp +ikeda.gifu.jp +kakamigahara.gifu.jp +kani.gifu.jp +kasahara.gifu.jp +kasamatsu.gifu.jp +kawaue.gifu.jp +kitagata.gifu.jp +mino.gifu.jp +minokamo.gifu.jp +mitake.gifu.jp +mizunami.gifu.jp +motosu.gifu.jp +nakatsugawa.gifu.jp +ogaki.gifu.jp +sakahogi.gifu.jp +seki.gifu.jp +sekigahara.gifu.jp +shirakawa.gifu.jp +tajimi.gifu.jp +takayama.gifu.jp +tarui.gifu.jp +toki.gifu.jp +tomika.gifu.jp +wanouchi.gifu.jp +yamagata.gifu.jp +yaotsu.gifu.jp +yoro.gifu.jp +annaka.gunma.jp +chiyoda.gunma.jp +fujioka.gunma.jp +higashiagatsuma.gunma.jp +isesaki.gunma.jp +itakura.gunma.jp +kanna.gunma.jp +kanra.gunma.jp +katashina.gunma.jp +kawaba.gunma.jp +kiryu.gunma.jp +kusatsu.gunma.jp +maebashi.gunma.jp +meiwa.gunma.jp +midori.gunma.jp +minakami.gunma.jp +naganohara.gunma.jp +nakanojo.gunma.jp +nanmoku.gunma.jp +numata.gunma.jp +oizumi.gunma.jp +ora.gunma.jp +ota.gunma.jp +shibukawa.gunma.jp +shimonita.gunma.jp +shinto.gunma.jp +showa.gunma.jp +takasaki.gunma.jp +takayama.gunma.jp +tamamura.gunma.jp +tatebayashi.gunma.jp +tomioka.gunma.jp +tsukiyono.gunma.jp +tsumagoi.gunma.jp +ueno.gunma.jp +yoshioka.gunma.jp +asaminami.hiroshima.jp +daiwa.hiroshima.jp +etajima.hiroshima.jp +fuchu.hiroshima.jp +fukuyama.hiroshima.jp +hatsukaichi.hiroshima.jp +higashihiroshima.hiroshima.jp +hongo.hiroshima.jp +jinsekikogen.hiroshima.jp +kaita.hiroshima.jp +kui.hiroshima.jp +kumano.hiroshima.jp +kure.hiroshima.jp +mihara.hiroshima.jp +miyoshi.hiroshima.jp +naka.hiroshima.jp +onomichi.hiroshima.jp +osakikamijima.hiroshima.jp +otake.hiroshima.jp +saka.hiroshima.jp +sera.hiroshima.jp +seranishi.hiroshima.jp +shinichi.hiroshima.jp +shobara.hiroshima.jp +takehara.hiroshima.jp +abashiri.hokkaido.jp +abira.hokkaido.jp +aibetsu.hokkaido.jp +akabira.hokkaido.jp +akkeshi.hokkaido.jp +asahikawa.hokkaido.jp +ashibetsu.hokkaido.jp +ashoro.hokkaido.jp +assabu.hokkaido.jp +atsuma.hokkaido.jp +bibai.hokkaido.jp +biei.hokkaido.jp +bifuka.hokkaido.jp +bihoro.hokkaido.jp +biratori.hokkaido.jp +chippubetsu.hokkaido.jp +chitose.hokkaido.jp +date.hokkaido.jp +ebetsu.hokkaido.jp +embetsu.hokkaido.jp +eniwa.hokkaido.jp +erimo.hokkaido.jp +esan.hokkaido.jp +esashi.hokkaido.jp +fukagawa.hokkaido.jp +fukushima.hokkaido.jp +furano.hokkaido.jp +furubira.hokkaido.jp +haboro.hokkaido.jp +hakodate.hokkaido.jp +hamatonbetsu.hokkaido.jp +hidaka.hokkaido.jp +higashikagura.hokkaido.jp +higashikawa.hokkaido.jp +hiroo.hokkaido.jp +hokuryu.hokkaido.jp +hokuto.hokkaido.jp +honbetsu.hokkaido.jp +horokanai.hokkaido.jp +horonobe.hokkaido.jp +ikeda.hokkaido.jp +imakane.hokkaido.jp +ishikari.hokkaido.jp +iwamizawa.hokkaido.jp +iwanai.hokkaido.jp +kamifurano.hokkaido.jp +kamikawa.hokkaido.jp +kamishihoro.hokkaido.jp +kamisunagawa.hokkaido.jp +kamoenai.hokkaido.jp +kayabe.hokkaido.jp +kembuchi.hokkaido.jp +kikonai.hokkaido.jp +kimobetsu.hokkaido.jp +kitahiroshima.hokkaido.jp +kitami.hokkaido.jp +kiyosato.hokkaido.jp +koshimizu.hokkaido.jp +kunneppu.hokkaido.jp +kuriyama.hokkaido.jp +kuromatsunai.hokkaido.jp +kushiro.hokkaido.jp +kutchan.hokkaido.jp +kyowa.hokkaido.jp +mashike.hokkaido.jp +matsumae.hokkaido.jp +mikasa.hokkaido.jp +minamifurano.hokkaido.jp +mombetsu.hokkaido.jp +moseushi.hokkaido.jp +mukawa.hokkaido.jp +muroran.hokkaido.jp +naie.hokkaido.jp +nakagawa.hokkaido.jp +nakasatsunai.hokkaido.jp +nakatombetsu.hokkaido.jp +nanae.hokkaido.jp +nanporo.hokkaido.jp +nayoro.hokkaido.jp +nemuro.hokkaido.jp +niikappu.hokkaido.jp +niki.hokkaido.jp +nishiokoppe.hokkaido.jp +noboribetsu.hokkaido.jp +numata.hokkaido.jp +obihiro.hokkaido.jp +obira.hokkaido.jp +oketo.hokkaido.jp +okoppe.hokkaido.jp +otaru.hokkaido.jp +otobe.hokkaido.jp +otofuke.hokkaido.jp +otoineppu.hokkaido.jp +oumu.hokkaido.jp +ozora.hokkaido.jp +pippu.hokkaido.jp +rankoshi.hokkaido.jp +rebun.hokkaido.jp +rikubetsu.hokkaido.jp +rishiri.hokkaido.jp +rishirifuji.hokkaido.jp +saroma.hokkaido.jp +sarufutsu.hokkaido.jp +shakotan.hokkaido.jp +shari.hokkaido.jp +shibecha.hokkaido.jp +shibetsu.hokkaido.jp +shikabe.hokkaido.jp +shikaoi.hokkaido.jp +shimamaki.hokkaido.jp +shimizu.hokkaido.jp +shimokawa.hokkaido.jp +shinshinotsu.hokkaido.jp +shintoku.hokkaido.jp +shiranuka.hokkaido.jp +shiraoi.hokkaido.jp +shiriuchi.hokkaido.jp +sobetsu.hokkaido.jp +sunagawa.hokkaido.jp +taiki.hokkaido.jp +takasu.hokkaido.jp +takikawa.hokkaido.jp +takinoue.hokkaido.jp +teshikaga.hokkaido.jp +tobetsu.hokkaido.jp +tohma.hokkaido.jp +tomakomai.hokkaido.jp +tomari.hokkaido.jp +toya.hokkaido.jp +toyako.hokkaido.jp +toyotomi.hokkaido.jp +toyoura.hokkaido.jp +tsubetsu.hokkaido.jp +tsukigata.hokkaido.jp +urakawa.hokkaido.jp +urausu.hokkaido.jp +uryu.hokkaido.jp +utashinai.hokkaido.jp +wakkanai.hokkaido.jp +wassamu.hokkaido.jp +yakumo.hokkaido.jp +yoichi.hokkaido.jp +aioi.hyogo.jp +akashi.hyogo.jp +ako.hyogo.jp +amagasaki.hyogo.jp +aogaki.hyogo.jp +asago.hyogo.jp +ashiya.hyogo.jp +awaji.hyogo.jp +fukusaki.hyogo.jp +goshiki.hyogo.jp +harima.hyogo.jp +himeji.hyogo.jp +ichikawa.hyogo.jp +inagawa.hyogo.jp +itami.hyogo.jp +kakogawa.hyogo.jp +kamigori.hyogo.jp +kamikawa.hyogo.jp +kasai.hyogo.jp +kasuga.hyogo.jp +kawanishi.hyogo.jp +miki.hyogo.jp +minamiawaji.hyogo.jp +nishinomiya.hyogo.jp +nishiwaki.hyogo.jp +ono.hyogo.jp +sanda.hyogo.jp +sannan.hyogo.jp +sasayama.hyogo.jp +sayo.hyogo.jp +shingu.hyogo.jp +shinonsen.hyogo.jp +shiso.hyogo.jp +sumoto.hyogo.jp +taishi.hyogo.jp +taka.hyogo.jp +takarazuka.hyogo.jp +takasago.hyogo.jp +takino.hyogo.jp +tamba.hyogo.jp +tatsuno.hyogo.jp +toyooka.hyogo.jp +yabu.hyogo.jp +yashiro.hyogo.jp +yoka.hyogo.jp +yokawa.hyogo.jp +ami.ibaraki.jp +asahi.ibaraki.jp +bando.ibaraki.jp +chikusei.ibaraki.jp +daigo.ibaraki.jp +fujishiro.ibaraki.jp +hitachi.ibaraki.jp +hitachinaka.ibaraki.jp +hitachiomiya.ibaraki.jp +hitachiota.ibaraki.jp +ibaraki.ibaraki.jp +ina.ibaraki.jp +inashiki.ibaraki.jp +itako.ibaraki.jp +iwama.ibaraki.jp +joso.ibaraki.jp +kamisu.ibaraki.jp +kasama.ibaraki.jp +kashima.ibaraki.jp +kasumigaura.ibaraki.jp +koga.ibaraki.jp +miho.ibaraki.jp +mito.ibaraki.jp +moriya.ibaraki.jp +naka.ibaraki.jp +namegata.ibaraki.jp +oarai.ibaraki.jp +ogawa.ibaraki.jp +omitama.ibaraki.jp +ryugasaki.ibaraki.jp +sakai.ibaraki.jp +sakuragawa.ibaraki.jp +shimodate.ibaraki.jp +shimotsuma.ibaraki.jp +shirosato.ibaraki.jp +sowa.ibaraki.jp +suifu.ibaraki.jp +takahagi.ibaraki.jp +tamatsukuri.ibaraki.jp +tokai.ibaraki.jp +tomobe.ibaraki.jp +tone.ibaraki.jp +toride.ibaraki.jp +tsuchiura.ibaraki.jp +tsukuba.ibaraki.jp +uchihara.ibaraki.jp +ushiku.ibaraki.jp +yachiyo.ibaraki.jp +yamagata.ibaraki.jp +yawara.ibaraki.jp +yuki.ibaraki.jp +anamizu.ishikawa.jp +hakui.ishikawa.jp +hakusan.ishikawa.jp +kaga.ishikawa.jp +kahoku.ishikawa.jp +kanazawa.ishikawa.jp +kawakita.ishikawa.jp +komatsu.ishikawa.jp +nakanoto.ishikawa.jp +nanao.ishikawa.jp +nomi.ishikawa.jp +nonoichi.ishikawa.jp +noto.ishikawa.jp +shika.ishikawa.jp +suzu.ishikawa.jp +tsubata.ishikawa.jp +tsurugi.ishikawa.jp +uchinada.ishikawa.jp +wajima.ishikawa.jp +fudai.iwate.jp +fujisawa.iwate.jp +hanamaki.iwate.jp +hiraizumi.iwate.jp +hirono.iwate.jp +ichinohe.iwate.jp +ichinoseki.iwate.jp +iwaizumi.iwate.jp +iwate.iwate.jp +joboji.iwate.jp +kamaishi.iwate.jp +kanegasaki.iwate.jp +karumai.iwate.jp +kawai.iwate.jp +kitakami.iwate.jp +kuji.iwate.jp +kunohe.iwate.jp +kuzumaki.iwate.jp +miyako.iwate.jp +mizusawa.iwate.jp +morioka.iwate.jp +ninohe.iwate.jp +noda.iwate.jp +ofunato.iwate.jp +oshu.iwate.jp +otsuchi.iwate.jp +rikuzentakata.iwate.jp +shiwa.iwate.jp +shizukuishi.iwate.jp +sumita.iwate.jp +tanohata.iwate.jp +tono.iwate.jp +yahaba.iwate.jp +yamada.iwate.jp +ayagawa.kagawa.jp +higashikagawa.kagawa.jp +kanonji.kagawa.jp +kotohira.kagawa.jp +manno.kagawa.jp +marugame.kagawa.jp +mitoyo.kagawa.jp +naoshima.kagawa.jp +sanuki.kagawa.jp +tadotsu.kagawa.jp +takamatsu.kagawa.jp +tonosho.kagawa.jp +uchinomi.kagawa.jp +utazu.kagawa.jp +zentsuji.kagawa.jp +akune.kagoshima.jp +amami.kagoshima.jp +hioki.kagoshima.jp +isa.kagoshima.jp +isen.kagoshima.jp +izumi.kagoshima.jp +kagoshima.kagoshima.jp +kanoya.kagoshima.jp +kawanabe.kagoshima.jp +kinko.kagoshima.jp +kouyama.kagoshima.jp +makurazaki.kagoshima.jp +matsumoto.kagoshima.jp +minamitane.kagoshima.jp +nakatane.kagoshima.jp +nishinoomote.kagoshima.jp +satsumasendai.kagoshima.jp +soo.kagoshima.jp +tarumizu.kagoshima.jp +yusui.kagoshima.jp +aikawa.kanagawa.jp +atsugi.kanagawa.jp +ayase.kanagawa.jp +chigasaki.kanagawa.jp +ebina.kanagawa.jp +fujisawa.kanagawa.jp +hadano.kanagawa.jp +hakone.kanagawa.jp +hiratsuka.kanagawa.jp +isehara.kanagawa.jp +kaisei.kanagawa.jp +kamakura.kanagawa.jp +kiyokawa.kanagawa.jp +matsuda.kanagawa.jp +minamiashigara.kanagawa.jp +miura.kanagawa.jp +nakai.kanagawa.jp +ninomiya.kanagawa.jp +odawara.kanagawa.jp +oi.kanagawa.jp +oiso.kanagawa.jp +sagamihara.kanagawa.jp +samukawa.kanagawa.jp +tsukui.kanagawa.jp +yamakita.kanagawa.jp +yamato.kanagawa.jp +yokosuka.kanagawa.jp +yugawara.kanagawa.jp +zama.kanagawa.jp +zushi.kanagawa.jp +aki.kochi.jp +geisei.kochi.jp +hidaka.kochi.jp +higashitsuno.kochi.jp +ino.kochi.jp +kagami.kochi.jp +kami.kochi.jp +kitagawa.kochi.jp +kochi.kochi.jp +mihara.kochi.jp +motoyama.kochi.jp +muroto.kochi.jp +nahari.kochi.jp +nakamura.kochi.jp +nankoku.kochi.jp +nishitosa.kochi.jp +niyodogawa.kochi.jp +ochi.kochi.jp +okawa.kochi.jp +otoyo.kochi.jp +otsuki.kochi.jp +sakawa.kochi.jp +sukumo.kochi.jp +susaki.kochi.jp +tosa.kochi.jp +tosashimizu.kochi.jp +toyo.kochi.jp +tsuno.kochi.jp +umaji.kochi.jp +yasuda.kochi.jp +yusuhara.kochi.jp +amakusa.kumamoto.jp +arao.kumamoto.jp +aso.kumamoto.jp +choyo.kumamoto.jp +gyokuto.kumamoto.jp +kamiamakusa.kumamoto.jp +kikuchi.kumamoto.jp +kumamoto.kumamoto.jp +mashiki.kumamoto.jp +mifune.kumamoto.jp +minamata.kumamoto.jp +minamioguni.kumamoto.jp +nagasu.kumamoto.jp +nishihara.kumamoto.jp +oguni.kumamoto.jp +ozu.kumamoto.jp +sumoto.kumamoto.jp +takamori.kumamoto.jp +uki.kumamoto.jp +uto.kumamoto.jp +yamaga.kumamoto.jp +yamato.kumamoto.jp +yatsushiro.kumamoto.jp +ayabe.kyoto.jp +fukuchiyama.kyoto.jp +higashiyama.kyoto.jp +ide.kyoto.jp +ine.kyoto.jp +joyo.kyoto.jp +kameoka.kyoto.jp +kamo.kyoto.jp +kita.kyoto.jp +kizu.kyoto.jp +kumiyama.kyoto.jp +kyotamba.kyoto.jp +kyotanabe.kyoto.jp +kyotango.kyoto.jp +maizuru.kyoto.jp +minami.kyoto.jp +minamiyamashiro.kyoto.jp +miyazu.kyoto.jp +muko.kyoto.jp +nagaokakyo.kyoto.jp +nakagyo.kyoto.jp +nantan.kyoto.jp +oyamazaki.kyoto.jp +sakyo.kyoto.jp +seika.kyoto.jp +tanabe.kyoto.jp +uji.kyoto.jp +ujitawara.kyoto.jp +wazuka.kyoto.jp +yamashina.kyoto.jp +yawata.kyoto.jp +asahi.mie.jp +inabe.mie.jp +ise.mie.jp +kameyama.mie.jp +kawagoe.mie.jp +kiho.mie.jp +kisosaki.mie.jp +kiwa.mie.jp +komono.mie.jp +kumano.mie.jp +kuwana.mie.jp +matsusaka.mie.jp +meiwa.mie.jp +mihama.mie.jp +minamiise.mie.jp +misugi.mie.jp +miyama.mie.jp +nabari.mie.jp +shima.mie.jp +suzuka.mie.jp +tado.mie.jp +taiki.mie.jp +taki.mie.jp +tamaki.mie.jp +toba.mie.jp +tsu.mie.jp +udono.mie.jp +ureshino.mie.jp +watarai.mie.jp +yokkaichi.mie.jp +furukawa.miyagi.jp +higashimatsushima.miyagi.jp +ishinomaki.miyagi.jp +iwanuma.miyagi.jp +kakuda.miyagi.jp +kami.miyagi.jp +kawasaki.miyagi.jp +marumori.miyagi.jp +matsushima.miyagi.jp +minamisanriku.miyagi.jp +misato.miyagi.jp +murata.miyagi.jp +natori.miyagi.jp +ogawara.miyagi.jp +ohira.miyagi.jp +onagawa.miyagi.jp +osaki.miyagi.jp +rifu.miyagi.jp +semine.miyagi.jp +shibata.miyagi.jp +shichikashuku.miyagi.jp +shikama.miyagi.jp +shiogama.miyagi.jp +shiroishi.miyagi.jp +tagajo.miyagi.jp +taiwa.miyagi.jp +tome.miyagi.jp +tomiya.miyagi.jp +wakuya.miyagi.jp +watari.miyagi.jp +yamamoto.miyagi.jp +zao.miyagi.jp +aya.miyazaki.jp +ebino.miyazaki.jp +gokase.miyazaki.jp +hyuga.miyazaki.jp +kadogawa.miyazaki.jp +kawaminami.miyazaki.jp +kijo.miyazaki.jp +kitagawa.miyazaki.jp +kitakata.miyazaki.jp +kitaura.miyazaki.jp +kobayashi.miyazaki.jp +kunitomi.miyazaki.jp +kushima.miyazaki.jp +mimata.miyazaki.jp +miyakonojo.miyazaki.jp +miyazaki.miyazaki.jp +morotsuka.miyazaki.jp +nichinan.miyazaki.jp +nishimera.miyazaki.jp +nobeoka.miyazaki.jp +saito.miyazaki.jp +shiiba.miyazaki.jp +shintomi.miyazaki.jp +takaharu.miyazaki.jp +takanabe.miyazaki.jp +takazaki.miyazaki.jp +tsuno.miyazaki.jp +achi.nagano.jp +agematsu.nagano.jp +anan.nagano.jp +aoki.nagano.jp +asahi.nagano.jp +azumino.nagano.jp +chikuhoku.nagano.jp +chikuma.nagano.jp +chino.nagano.jp +fujimi.nagano.jp +hakuba.nagano.jp +hara.nagano.jp +hiraya.nagano.jp +iida.nagano.jp +iijima.nagano.jp +iiyama.nagano.jp +iizuna.nagano.jp +ikeda.nagano.jp +ikusaka.nagano.jp +ina.nagano.jp +karuizawa.nagano.jp +kawakami.nagano.jp +kiso.nagano.jp +kisofukushima.nagano.jp +kitaaiki.nagano.jp +komagane.nagano.jp +komoro.nagano.jp +matsukawa.nagano.jp +matsumoto.nagano.jp +miasa.nagano.jp +minamiaiki.nagano.jp +minamimaki.nagano.jp +minamiminowa.nagano.jp +minowa.nagano.jp +miyada.nagano.jp +miyota.nagano.jp +mochizuki.nagano.jp +nagano.nagano.jp +nagawa.nagano.jp +nagiso.nagano.jp +nakagawa.nagano.jp +nakano.nagano.jp +nozawaonsen.nagano.jp +obuse.nagano.jp +ogawa.nagano.jp +okaya.nagano.jp +omachi.nagano.jp +omi.nagano.jp +ookuwa.nagano.jp +ooshika.nagano.jp +otaki.nagano.jp +otari.nagano.jp +sakae.nagano.jp +sakaki.nagano.jp +saku.nagano.jp +sakuho.nagano.jp +shimosuwa.nagano.jp +shinanomachi.nagano.jp +shiojiri.nagano.jp +suwa.nagano.jp +suzaka.nagano.jp +takagi.nagano.jp +takamori.nagano.jp +takayama.nagano.jp +tateshina.nagano.jp +tatsuno.nagano.jp +togakushi.nagano.jp +togura.nagano.jp +tomi.nagano.jp +ueda.nagano.jp +wada.nagano.jp +yamagata.nagano.jp +yamanouchi.nagano.jp +yasaka.nagano.jp +yasuoka.nagano.jp +chijiwa.nagasaki.jp +futsu.nagasaki.jp +goto.nagasaki.jp +hasami.nagasaki.jp +hirado.nagasaki.jp +iki.nagasaki.jp +isahaya.nagasaki.jp +kawatana.nagasaki.jp +kuchinotsu.nagasaki.jp +matsuura.nagasaki.jp +nagasaki.nagasaki.jp +obama.nagasaki.jp +omura.nagasaki.jp +oseto.nagasaki.jp +saikai.nagasaki.jp +sasebo.nagasaki.jp +seihi.nagasaki.jp +shimabara.nagasaki.jp +shinkamigoto.nagasaki.jp +togitsu.nagasaki.jp +tsushima.nagasaki.jp +unzen.nagasaki.jp +ando.nara.jp +gose.nara.jp +heguri.nara.jp +higashiyoshino.nara.jp +ikaruga.nara.jp +ikoma.nara.jp +kamikitayama.nara.jp +kanmaki.nara.jp +kashiba.nara.jp +kashihara.nara.jp +katsuragi.nara.jp +kawai.nara.jp +kawakami.nara.jp +kawanishi.nara.jp +koryo.nara.jp +kurotaki.nara.jp +mitsue.nara.jp +miyake.nara.jp +nara.nara.jp +nosegawa.nara.jp +oji.nara.jp +ouda.nara.jp +oyodo.nara.jp +sakurai.nara.jp +sango.nara.jp +shimoichi.nara.jp +shimokitayama.nara.jp +shinjo.nara.jp +soni.nara.jp +takatori.nara.jp +tawaramoto.nara.jp +tenkawa.nara.jp +tenri.nara.jp +uda.nara.jp +yamatokoriyama.nara.jp +yamatotakada.nara.jp +yamazoe.nara.jp +yoshino.nara.jp +aga.niigata.jp +agano.niigata.jp +gosen.niigata.jp +itoigawa.niigata.jp +izumozaki.niigata.jp +joetsu.niigata.jp +kamo.niigata.jp +kariwa.niigata.jp +kashiwazaki.niigata.jp +minamiuonuma.niigata.jp +mitsuke.niigata.jp +muika.niigata.jp +murakami.niigata.jp +myoko.niigata.jp +nagaoka.niigata.jp +niigata.niigata.jp +ojiya.niigata.jp +omi.niigata.jp +sado.niigata.jp +sanjo.niigata.jp +seiro.niigata.jp +seirou.niigata.jp +sekikawa.niigata.jp +shibata.niigata.jp +tagami.niigata.jp +tainai.niigata.jp +tochio.niigata.jp +tokamachi.niigata.jp +tsubame.niigata.jp +tsunan.niigata.jp +uonuma.niigata.jp +yahiko.niigata.jp +yoita.niigata.jp +yuzawa.niigata.jp +beppu.oita.jp +bungoono.oita.jp +bungotakada.oita.jp +hasama.oita.jp +hiji.oita.jp +himeshima.oita.jp +hita.oita.jp +kamitsue.oita.jp +kokonoe.oita.jp +kuju.oita.jp +kunisaki.oita.jp +kusu.oita.jp +oita.oita.jp +saiki.oita.jp +taketa.oita.jp +tsukumi.oita.jp +usa.oita.jp +usuki.oita.jp +yufu.oita.jp +akaiwa.okayama.jp +asakuchi.okayama.jp +bizen.okayama.jp +hayashima.okayama.jp +ibara.okayama.jp +kagamino.okayama.jp +kasaoka.okayama.jp +kibichuo.okayama.jp +kumenan.okayama.jp +kurashiki.okayama.jp +maniwa.okayama.jp +misaki.okayama.jp +nagi.okayama.jp +niimi.okayama.jp +nishiawakura.okayama.jp +okayama.okayama.jp +satosho.okayama.jp +setouchi.okayama.jp +shinjo.okayama.jp +shoo.okayama.jp +soja.okayama.jp +takahashi.okayama.jp +tamano.okayama.jp +tsuyama.okayama.jp +wake.okayama.jp +yakage.okayama.jp +aguni.okinawa.jp +ginowan.okinawa.jp +ginoza.okinawa.jp +gushikami.okinawa.jp +haebaru.okinawa.jp +higashi.okinawa.jp +hirara.okinawa.jp +iheya.okinawa.jp +ishigaki.okinawa.jp +ishikawa.okinawa.jp +itoman.okinawa.jp +izena.okinawa.jp +kadena.okinawa.jp +kin.okinawa.jp +kitadaito.okinawa.jp +kitanakagusuku.okinawa.jp +kumejima.okinawa.jp +kunigami.okinawa.jp +minamidaito.okinawa.jp +motobu.okinawa.jp +nago.okinawa.jp +naha.okinawa.jp +nakagusuku.okinawa.jp +nakijin.okinawa.jp +nanjo.okinawa.jp +nishihara.okinawa.jp +ogimi.okinawa.jp +okinawa.okinawa.jp +onna.okinawa.jp +shimoji.okinawa.jp +taketomi.okinawa.jp +tarama.okinawa.jp +tokashiki.okinawa.jp +tomigusuku.okinawa.jp +tonaki.okinawa.jp +urasoe.okinawa.jp +uruma.okinawa.jp +yaese.okinawa.jp +yomitan.okinawa.jp +yonabaru.okinawa.jp +yonaguni.okinawa.jp +zamami.okinawa.jp +abeno.osaka.jp +chihayaakasaka.osaka.jp +chuo.osaka.jp +daito.osaka.jp +fujiidera.osaka.jp +habikino.osaka.jp +hannan.osaka.jp +higashiosaka.osaka.jp +higashisumiyoshi.osaka.jp +higashiyodogawa.osaka.jp +hirakata.osaka.jp +ibaraki.osaka.jp +ikeda.osaka.jp +izumi.osaka.jp +izumiotsu.osaka.jp +izumisano.osaka.jp +kadoma.osaka.jp +kaizuka.osaka.jp +kanan.osaka.jp +kashiwara.osaka.jp +katano.osaka.jp +kawachinagano.osaka.jp +kishiwada.osaka.jp +kita.osaka.jp +kumatori.osaka.jp +matsubara.osaka.jp +minato.osaka.jp +minoh.osaka.jp +misaki.osaka.jp +moriguchi.osaka.jp +neyagawa.osaka.jp +nishi.osaka.jp +nose.osaka.jp +osakasayama.osaka.jp +sakai.osaka.jp +sayama.osaka.jp +sennan.osaka.jp +settsu.osaka.jp +shijonawate.osaka.jp +shimamoto.osaka.jp +suita.osaka.jp +tadaoka.osaka.jp +taishi.osaka.jp +tajiri.osaka.jp +takaishi.osaka.jp +takatsuki.osaka.jp +tondabayashi.osaka.jp +toyonaka.osaka.jp +toyono.osaka.jp +yao.osaka.jp +ariake.saga.jp +arita.saga.jp +fukudomi.saga.jp +genkai.saga.jp +hamatama.saga.jp +hizen.saga.jp +imari.saga.jp +kamimine.saga.jp +kanzaki.saga.jp +karatsu.saga.jp +kashima.saga.jp +kitagata.saga.jp +kitahata.saga.jp +kiyama.saga.jp +kouhoku.saga.jp +kyuragi.saga.jp +nishiarita.saga.jp +ogi.saga.jp +omachi.saga.jp +ouchi.saga.jp +saga.saga.jp +shiroishi.saga.jp +taku.saga.jp +tara.saga.jp +tosu.saga.jp +yoshinogari.saga.jp +arakawa.saitama.jp +asaka.saitama.jp +chichibu.saitama.jp +fujimi.saitama.jp +fujimino.saitama.jp +fukaya.saitama.jp +hanno.saitama.jp +hanyu.saitama.jp +hasuda.saitama.jp +hatogaya.saitama.jp +hatoyama.saitama.jp +hidaka.saitama.jp +higashichichibu.saitama.jp +higashimatsuyama.saitama.jp +honjo.saitama.jp +ina.saitama.jp +iruma.saitama.jp +iwatsuki.saitama.jp +kamiizumi.saitama.jp +kamikawa.saitama.jp +kamisato.saitama.jp +kasukabe.saitama.jp +kawagoe.saitama.jp +kawaguchi.saitama.jp +kawajima.saitama.jp +kazo.saitama.jp +kitamoto.saitama.jp +koshigaya.saitama.jp +kounosu.saitama.jp +kuki.saitama.jp +kumagaya.saitama.jp +matsubushi.saitama.jp +minano.saitama.jp +misato.saitama.jp +miyashiro.saitama.jp +miyoshi.saitama.jp +moroyama.saitama.jp +nagatoro.saitama.jp +namegawa.saitama.jp +niiza.saitama.jp +ogano.saitama.jp +ogawa.saitama.jp +ogose.saitama.jp +okegawa.saitama.jp +omiya.saitama.jp +otaki.saitama.jp +ranzan.saitama.jp +ryokami.saitama.jp +saitama.saitama.jp +sakado.saitama.jp +satte.saitama.jp +sayama.saitama.jp +shiki.saitama.jp +shiraoka.saitama.jp +soka.saitama.jp +sugito.saitama.jp +toda.saitama.jp +tokigawa.saitama.jp +tokorozawa.saitama.jp +tsurugashima.saitama.jp +urawa.saitama.jp +warabi.saitama.jp +yashio.saitama.jp +yokoze.saitama.jp +yono.saitama.jp +yorii.saitama.jp +yoshida.saitama.jp +yoshikawa.saitama.jp +yoshimi.saitama.jp +aisho.shiga.jp +gamo.shiga.jp +higashiomi.shiga.jp +hikone.shiga.jp +koka.shiga.jp +konan.shiga.jp +kosei.shiga.jp +koto.shiga.jp +kusatsu.shiga.jp +maibara.shiga.jp +moriyama.shiga.jp +nagahama.shiga.jp +nishiazai.shiga.jp +notogawa.shiga.jp +omihachiman.shiga.jp +otsu.shiga.jp +ritto.shiga.jp +ryuoh.shiga.jp +takashima.shiga.jp +takatsuki.shiga.jp +torahime.shiga.jp +toyosato.shiga.jp +yasu.shiga.jp +akagi.shimane.jp +ama.shimane.jp +gotsu.shimane.jp +hamada.shimane.jp +higashiizumo.shimane.jp +hikawa.shimane.jp +hikimi.shimane.jp +izumo.shimane.jp +kakinoki.shimane.jp +masuda.shimane.jp +matsue.shimane.jp +misato.shimane.jp +nishinoshima.shimane.jp +ohda.shimane.jp +okinoshima.shimane.jp +okuizumo.shimane.jp +shimane.shimane.jp +tamayu.shimane.jp +tsuwano.shimane.jp +unnan.shimane.jp +yakumo.shimane.jp +yasugi.shimane.jp +yatsuka.shimane.jp +arai.shizuoka.jp +atami.shizuoka.jp +fuji.shizuoka.jp +fujieda.shizuoka.jp +fujikawa.shizuoka.jp +fujinomiya.shizuoka.jp +fukuroi.shizuoka.jp +gotemba.shizuoka.jp +haibara.shizuoka.jp +hamamatsu.shizuoka.jp +higashiizu.shizuoka.jp +ito.shizuoka.jp +iwata.shizuoka.jp +izu.shizuoka.jp +izunokuni.shizuoka.jp +kakegawa.shizuoka.jp +kannami.shizuoka.jp +kawanehon.shizuoka.jp +kawazu.shizuoka.jp +kikugawa.shizuoka.jp +kosai.shizuoka.jp +makinohara.shizuoka.jp +matsuzaki.shizuoka.jp +minamiizu.shizuoka.jp +mishima.shizuoka.jp +morimachi.shizuoka.jp +nishiizu.shizuoka.jp +numazu.shizuoka.jp +omaezaki.shizuoka.jp +shimada.shizuoka.jp +shimizu.shizuoka.jp +shimoda.shizuoka.jp +shizuoka.shizuoka.jp +susono.shizuoka.jp +yaizu.shizuoka.jp +yoshida.shizuoka.jp +ashikaga.tochigi.jp +bato.tochigi.jp +haga.tochigi.jp +ichikai.tochigi.jp +iwafune.tochigi.jp +kaminokawa.tochigi.jp +kanuma.tochigi.jp +karasuyama.tochigi.jp +kuroiso.tochigi.jp +mashiko.tochigi.jp +mibu.tochigi.jp +moka.tochigi.jp +motegi.tochigi.jp +nasu.tochigi.jp +nasushiobara.tochigi.jp +nikko.tochigi.jp +nishikata.tochigi.jp +nogi.tochigi.jp +ohira.tochigi.jp +ohtawara.tochigi.jp +oyama.tochigi.jp +sakura.tochigi.jp +sano.tochigi.jp +shimotsuke.tochigi.jp +shioya.tochigi.jp +takanezawa.tochigi.jp +tochigi.tochigi.jp +tsuga.tochigi.jp +ujiie.tochigi.jp +utsunomiya.tochigi.jp +yaita.tochigi.jp +aizumi.tokushima.jp +anan.tokushima.jp +ichiba.tokushima.jp +itano.tokushima.jp +kainan.tokushima.jp +komatsushima.tokushima.jp +matsushige.tokushima.jp +mima.tokushima.jp +minami.tokushima.jp +miyoshi.tokushima.jp +mugi.tokushima.jp +nakagawa.tokushima.jp +naruto.tokushima.jp +sanagochi.tokushima.jp +shishikui.tokushima.jp +tokushima.tokushima.jp +wajiki.tokushima.jp +adachi.tokyo.jp +akiruno.tokyo.jp +akishima.tokyo.jp +aogashima.tokyo.jp +arakawa.tokyo.jp +bunkyo.tokyo.jp +chiyoda.tokyo.jp +chofu.tokyo.jp +chuo.tokyo.jp +edogawa.tokyo.jp +fuchu.tokyo.jp +fussa.tokyo.jp +hachijo.tokyo.jp +hachioji.tokyo.jp +hamura.tokyo.jp +higashikurume.tokyo.jp +higashimurayama.tokyo.jp +higashiyamato.tokyo.jp +hino.tokyo.jp +hinode.tokyo.jp +hinohara.tokyo.jp +inagi.tokyo.jp +itabashi.tokyo.jp +katsushika.tokyo.jp +kita.tokyo.jp +kiyose.tokyo.jp +kodaira.tokyo.jp +koganei.tokyo.jp +kokubunji.tokyo.jp +komae.tokyo.jp +koto.tokyo.jp +kouzushima.tokyo.jp +kunitachi.tokyo.jp +machida.tokyo.jp +meguro.tokyo.jp +minato.tokyo.jp +mitaka.tokyo.jp +mizuho.tokyo.jp +musashimurayama.tokyo.jp +musashino.tokyo.jp +nakano.tokyo.jp +nerima.tokyo.jp +ogasawara.tokyo.jp +okutama.tokyo.jp +ome.tokyo.jp +oshima.tokyo.jp +ota.tokyo.jp +setagaya.tokyo.jp +shibuya.tokyo.jp +shinagawa.tokyo.jp +shinjuku.tokyo.jp +suginami.tokyo.jp +sumida.tokyo.jp +tachikawa.tokyo.jp +taito.tokyo.jp +tama.tokyo.jp +toshima.tokyo.jp +chizu.tottori.jp +hino.tottori.jp +kawahara.tottori.jp +koge.tottori.jp +kotoura.tottori.jp +misasa.tottori.jp +nanbu.tottori.jp +nichinan.tottori.jp +sakaiminato.tottori.jp +tottori.tottori.jp +wakasa.tottori.jp +yazu.tottori.jp +yonago.tottori.jp +asahi.toyama.jp +fuchu.toyama.jp +fukumitsu.toyama.jp +funahashi.toyama.jp +himi.toyama.jp +imizu.toyama.jp +inami.toyama.jp +johana.toyama.jp +kamiichi.toyama.jp +kurobe.toyama.jp +nakaniikawa.toyama.jp +namerikawa.toyama.jp +nanto.toyama.jp +nyuzen.toyama.jp +oyabe.toyama.jp +taira.toyama.jp +takaoka.toyama.jp +tateyama.toyama.jp +toga.toyama.jp +tonami.toyama.jp +toyama.toyama.jp +unazuki.toyama.jp +uozu.toyama.jp +yamada.toyama.jp +arida.wakayama.jp +aridagawa.wakayama.jp +gobo.wakayama.jp +hashimoto.wakayama.jp +hidaka.wakayama.jp +hirogawa.wakayama.jp +inami.wakayama.jp +iwade.wakayama.jp +kainan.wakayama.jp +kamitonda.wakayama.jp +katsuragi.wakayama.jp +kimino.wakayama.jp +kinokawa.wakayama.jp +kitayama.wakayama.jp +koya.wakayama.jp +koza.wakayama.jp +kozagawa.wakayama.jp +kudoyama.wakayama.jp +kushimoto.wakayama.jp +mihama.wakayama.jp +misato.wakayama.jp +nachikatsuura.wakayama.jp +shingu.wakayama.jp +shirahama.wakayama.jp +taiji.wakayama.jp +tanabe.wakayama.jp +wakayama.wakayama.jp +yuasa.wakayama.jp +yura.wakayama.jp +asahi.yamagata.jp +funagata.yamagata.jp +higashine.yamagata.jp +iide.yamagata.jp +kahoku.yamagata.jp +kaminoyama.yamagata.jp +kaneyama.yamagata.jp +kawanishi.yamagata.jp +mamurogawa.yamagata.jp +mikawa.yamagata.jp +murayama.yamagata.jp +nagai.yamagata.jp +nakayama.yamagata.jp +nanyo.yamagata.jp +nishikawa.yamagata.jp +obanazawa.yamagata.jp +oe.yamagata.jp +oguni.yamagata.jp +ohkura.yamagata.jp +oishida.yamagata.jp +sagae.yamagata.jp +sakata.yamagata.jp +sakegawa.yamagata.jp +shinjo.yamagata.jp +shirataka.yamagata.jp +shonai.yamagata.jp +takahata.yamagata.jp +tendo.yamagata.jp +tozawa.yamagata.jp +tsuruoka.yamagata.jp +yamagata.yamagata.jp +yamanobe.yamagata.jp +yonezawa.yamagata.jp +yuza.yamagata.jp +abu.yamaguchi.jp +hagi.yamaguchi.jp +hikari.yamaguchi.jp +hofu.yamaguchi.jp +iwakuni.yamaguchi.jp +kudamatsu.yamaguchi.jp +mitou.yamaguchi.jp +nagato.yamaguchi.jp +oshima.yamaguchi.jp +shimonoseki.yamaguchi.jp +shunan.yamaguchi.jp +tabuse.yamaguchi.jp +tokuyama.yamaguchi.jp +toyota.yamaguchi.jp +ube.yamaguchi.jp +yuu.yamaguchi.jp +chuo.yamanashi.jp +doshi.yamanashi.jp +fuefuki.yamanashi.jp +fujikawa.yamanashi.jp +fujikawaguchiko.yamanashi.jp +fujiyoshida.yamanashi.jp +hayakawa.yamanashi.jp +hokuto.yamanashi.jp +ichikawamisato.yamanashi.jp +kai.yamanashi.jp +kofu.yamanashi.jp +koshu.yamanashi.jp +kosuge.yamanashi.jp +minami-alps.yamanashi.jp +minobu.yamanashi.jp +nakamichi.yamanashi.jp +nanbu.yamanashi.jp +narusawa.yamanashi.jp +nirasaki.yamanashi.jp +nishikatsura.yamanashi.jp +oshino.yamanashi.jp +otsuki.yamanashi.jp +showa.yamanashi.jp +tabayama.yamanashi.jp +tsuru.yamanashi.jp +uenohara.yamanashi.jp +yamanakako.yamanashi.jp +yamanashi.yamanashi.jp + +// ke : http://www.kenic.or.ke/index.php/en/ke-domains/ke-domains +ke +ac.ke +co.ke +go.ke +info.ke +me.ke +mobi.ke +ne.ke +or.ke +sc.ke + +// kg : http://www.domain.kg/dmn_n.html +kg +org.kg +net.kg +com.kg +edu.kg +gov.kg +mil.kg + +// kh : http://www.mptc.gov.kh/dns_registration.htm +*.kh + +// ki : http://www.ki/dns/index.html +ki +edu.ki +biz.ki +net.ki +org.ki +gov.ki +info.ki +com.ki + +// km : https://en.wikipedia.org/wiki/.km +// http://www.domaine.km/documents/charte.doc +km +org.km +nom.km +gov.km +prd.km +tm.km +edu.km +mil.km +ass.km +com.km +// These are only mentioned as proposed suggestions at domaine.km, but +// https://en.wikipedia.org/wiki/.km says they're available for registration: +coop.km +asso.km +presse.km +medecin.km +notaires.km +pharmaciens.km +veterinaire.km +gouv.km + +// kn : https://en.wikipedia.org/wiki/.kn +// http://www.dot.kn/domainRules.html +kn +net.kn +org.kn +edu.kn +gov.kn + +// kp : http://www.kcce.kp/en_index.php +kp +com.kp +edu.kp +gov.kp +org.kp +rep.kp +tra.kp + +// kr : https://en.wikipedia.org/wiki/.kr +// see also: http://domain.nida.or.kr/eng/registration.jsp +kr +ac.kr +co.kr +es.kr +go.kr +hs.kr +kg.kr +mil.kr +ms.kr +ne.kr +or.kr +pe.kr +re.kr +sc.kr +// kr geographical names +busan.kr +chungbuk.kr +chungnam.kr +daegu.kr +daejeon.kr +gangwon.kr +gwangju.kr +gyeongbuk.kr +gyeonggi.kr +gyeongnam.kr +incheon.kr +jeju.kr +jeonbuk.kr +jeonnam.kr +seoul.kr +ulsan.kr + +// kw : https://en.wikipedia.org/wiki/.kw +*.kw + +// ky : http://www.icta.ky/da_ky_reg_dom.php +// Confirmed by registry 2008-06-17 +ky +edu.ky +gov.ky +com.ky +org.ky +net.ky + +// kz : https://en.wikipedia.org/wiki/.kz +// see also: http://www.nic.kz/rules/index.jsp +kz +org.kz +edu.kz +net.kz +gov.kz +mil.kz +com.kz + +// la : https://en.wikipedia.org/wiki/.la +// Submitted by registry +la +int.la +net.la +info.la +edu.la +gov.la +per.la +com.la +org.la + +// lb : https://en.wikipedia.org/wiki/.lb +// Submitted by registry +lb +com.lb +edu.lb +gov.lb +net.lb +org.lb + +// lc : https://en.wikipedia.org/wiki/.lc +// see also: http://www.nic.lc/rules.htm +lc +com.lc +net.lc +co.lc +org.lc +edu.lc +gov.lc + +// li : https://en.wikipedia.org/wiki/.li +li + +// lk : http://www.nic.lk/seclevpr.html +lk +gov.lk +sch.lk +net.lk +int.lk +com.lk +org.lk +edu.lk +ngo.lk +soc.lk +web.lk +ltd.lk +assn.lk +grp.lk +hotel.lk +ac.lk + +// lr : http://psg.com/dns/lr/lr.txt +// Submitted by registry +lr +com.lr +edu.lr +gov.lr +org.lr +net.lr + +// ls : https://en.wikipedia.org/wiki/.ls +ls +co.ls +org.ls + +// lt : https://en.wikipedia.org/wiki/.lt +lt +// gov.lt : http://www.gov.lt/index_en.php +gov.lt + +// lu : http://www.dns.lu/en/ +lu + +// lv : http://www.nic.lv/DNS/En/generic.php +lv +com.lv +edu.lv +gov.lv +org.lv +mil.lv +id.lv +net.lv +asn.lv +conf.lv + +// ly : http://www.nic.ly/regulations.php +ly +com.ly +net.ly +gov.ly +plc.ly +edu.ly +sch.ly +med.ly +org.ly +id.ly + +// ma : https://en.wikipedia.org/wiki/.ma +// http://www.anrt.ma/fr/admin/download/upload/file_fr782.pdf +ma +co.ma +net.ma +gov.ma +org.ma +ac.ma +press.ma + +// mc : http://www.nic.mc/ +mc +tm.mc +asso.mc + +// md : https://en.wikipedia.org/wiki/.md +md + +// me : https://en.wikipedia.org/wiki/.me +me +co.me +net.me +org.me +edu.me +ac.me +gov.me +its.me +priv.me + +// mg : http://nic.mg/nicmg/?page_id=39 +mg +org.mg +nom.mg +gov.mg +prd.mg +tm.mg +edu.mg +mil.mg +com.mg +co.mg + +// mh : https://en.wikipedia.org/wiki/.mh +mh + +// mil : https://en.wikipedia.org/wiki/.mil +mil + +// mk : https://en.wikipedia.org/wiki/.mk +// see also: http://dns.marnet.net.mk/postapka.php +mk +com.mk +org.mk +net.mk +edu.mk +gov.mk +inf.mk +name.mk + +// ml : http://www.gobin.info/domainname/ml-template.doc +// see also: https://en.wikipedia.org/wiki/.ml +ml +com.ml +edu.ml +gouv.ml +gov.ml +net.ml +org.ml +presse.ml + +// mm : https://en.wikipedia.org/wiki/.mm +*.mm + +// mn : https://en.wikipedia.org/wiki/.mn +mn +gov.mn +edu.mn +org.mn + +// mo : http://www.monic.net.mo/ +mo +com.mo +net.mo +org.mo +edu.mo +gov.mo + +// mobi : https://en.wikipedia.org/wiki/.mobi +mobi + +// mp : http://www.dot.mp/ +// Confirmed by registry 2008-06-17 +mp + +// mq : https://en.wikipedia.org/wiki/.mq +mq + +// mr : https://en.wikipedia.org/wiki/.mr +mr +gov.mr + +// ms : http://www.nic.ms/pdf/MS_Domain_Name_Rules.pdf +ms +com.ms +edu.ms +gov.ms +net.ms +org.ms + +// mt : https://www.nic.org.mt/go/policy +// Submitted by registry +mt +com.mt +edu.mt +net.mt +org.mt + +// mu : https://en.wikipedia.org/wiki/.mu +mu +com.mu +net.mu +org.mu +gov.mu +ac.mu +co.mu +or.mu + +// museum : http://about.museum/naming/ +// http://index.museum/ +museum +academy.museum +agriculture.museum +air.museum +airguard.museum +alabama.museum +alaska.museum +amber.museum +ambulance.museum +american.museum +americana.museum +americanantiques.museum +americanart.museum +amsterdam.museum +and.museum +annefrank.museum +anthro.museum +anthropology.museum +antiques.museum +aquarium.museum +arboretum.museum +archaeological.museum +archaeology.museum +architecture.museum +art.museum +artanddesign.museum +artcenter.museum +artdeco.museum +arteducation.museum +artgallery.museum +arts.museum +artsandcrafts.museum +asmatart.museum +assassination.museum +assisi.museum +association.museum +astronomy.museum +atlanta.museum +austin.museum +australia.museum +automotive.museum +aviation.museum +axis.museum +badajoz.museum +baghdad.museum +bahn.museum +bale.museum +baltimore.museum +barcelona.museum +baseball.museum +basel.museum +baths.museum +bauern.museum +beauxarts.museum +beeldengeluid.museum +bellevue.museum +bergbau.museum +berkeley.museum +berlin.museum +bern.museum +bible.museum +bilbao.museum +bill.museum +birdart.museum +birthplace.museum +bonn.museum +boston.museum +botanical.museum +botanicalgarden.museum +botanicgarden.museum +botany.museum +brandywinevalley.museum +brasil.museum +bristol.museum +british.museum +britishcolumbia.museum +broadcast.museum +brunel.museum +brussel.museum +brussels.museum +bruxelles.museum +building.museum +burghof.museum +bus.museum +bushey.museum +cadaques.museum +california.museum +cambridge.museum +can.museum +canada.museum +capebreton.museum +carrier.museum +cartoonart.museum +casadelamoneda.museum +castle.museum +castres.museum +celtic.museum +center.museum +chattanooga.museum +cheltenham.museum +chesapeakebay.museum +chicago.museum +children.museum +childrens.museum +childrensgarden.museum +chiropractic.museum +chocolate.museum +christiansburg.museum +cincinnati.museum +cinema.museum +circus.museum +civilisation.museum +civilization.museum +civilwar.museum +clinton.museum +clock.museum +coal.museum +coastaldefence.museum +cody.museum +coldwar.museum +collection.museum +colonialwilliamsburg.museum +coloradoplateau.museum +columbia.museum +columbus.museum +communication.museum +communications.museum +community.museum +computer.museum +computerhistory.museum +xn--comunicaes-v6a2o.museum +contemporary.museum +contemporaryart.museum +convent.museum +copenhagen.museum +corporation.museum +xn--correios-e-telecomunicaes-ghc29a.museum +corvette.museum +costume.museum +countryestate.museum +county.museum +crafts.museum +cranbrook.museum +creation.museum +cultural.museum +culturalcenter.museum +culture.museum +cyber.museum +cymru.museum +dali.museum +dallas.museum +database.museum +ddr.museum +decorativearts.museum +delaware.museum +delmenhorst.museum +denmark.museum +depot.museum +design.museum +detroit.museum +dinosaur.museum +discovery.museum +dolls.museum +donostia.museum +durham.museum +eastafrica.museum +eastcoast.museum +education.museum +educational.museum +egyptian.museum +eisenbahn.museum +elburg.museum +elvendrell.museum +embroidery.museum +encyclopedic.museum +england.museum +entomology.museum +environment.museum +environmentalconservation.museum +epilepsy.museum +essex.museum +estate.museum +ethnology.museum +exeter.museum +exhibition.museum +family.museum +farm.museum +farmequipment.museum +farmers.museum +farmstead.museum +field.museum +figueres.museum +filatelia.museum +film.museum +fineart.museum +finearts.museum +finland.museum +flanders.museum +florida.museum +force.museum +fortmissoula.museum +fortworth.museum +foundation.museum +francaise.museum +frankfurt.museum +franziskaner.museum +freemasonry.museum +freiburg.museum +fribourg.museum +frog.museum +fundacio.museum +furniture.museum +gallery.museum +garden.museum +gateway.museum +geelvinck.museum +gemological.museum +geology.museum +georgia.museum +giessen.museum +glas.museum +glass.museum +gorge.museum +grandrapids.museum +graz.museum +guernsey.museum +halloffame.museum +hamburg.museum +handson.museum +harvestcelebration.museum +hawaii.museum +health.museum +heimatunduhren.museum +hellas.museum +helsinki.museum +hembygdsforbund.museum +heritage.museum +histoire.museum +historical.museum +historicalsociety.museum +historichouses.museum +historisch.museum +historisches.museum +history.museum +historyofscience.museum +horology.museum +house.museum +humanities.museum +illustration.museum +imageandsound.museum +indian.museum +indiana.museum +indianapolis.museum +indianmarket.museum +intelligence.museum +interactive.museum +iraq.museum +iron.museum +isleofman.museum +jamison.museum +jefferson.museum +jerusalem.museum +jewelry.museum +jewish.museum +jewishart.museum +jfk.museum +journalism.museum +judaica.museum +judygarland.museum +juedisches.museum +juif.museum +karate.museum +karikatur.museum +kids.museum +koebenhavn.museum +koeln.museum +kunst.museum +kunstsammlung.museum +kunstunddesign.museum +labor.museum +labour.museum +lajolla.museum +lancashire.museum +landes.museum +lans.museum +xn--lns-qla.museum +larsson.museum +lewismiller.museum +lincoln.museum +linz.museum +living.museum +livinghistory.museum +localhistory.museum +london.museum +losangeles.museum +louvre.museum +loyalist.museum +lucerne.museum +luxembourg.museum +luzern.museum +mad.museum +madrid.museum +mallorca.museum +manchester.museum +mansion.museum +mansions.museum +manx.museum +marburg.museum +maritime.museum +maritimo.museum +maryland.museum +marylhurst.museum +media.museum +medical.museum +medizinhistorisches.museum +meeres.museum +memorial.museum +mesaverde.museum +michigan.museum +midatlantic.museum +military.museum +mill.museum +miners.museum +mining.museum +minnesota.museum +missile.museum +missoula.museum +modern.museum +moma.museum +money.museum +monmouth.museum +monticello.museum +montreal.museum +moscow.museum +motorcycle.museum +muenchen.museum +muenster.museum +mulhouse.museum +muncie.museum +museet.museum +museumcenter.museum +museumvereniging.museum +music.museum +national.museum +nationalfirearms.museum +nationalheritage.museum +nativeamerican.museum +naturalhistory.museum +naturalhistorymuseum.museum +naturalsciences.museum +nature.museum +naturhistorisches.museum +natuurwetenschappen.museum +naumburg.museum +naval.museum +nebraska.museum +neues.museum +newhampshire.museum +newjersey.museum +newmexico.museum +newport.museum +newspaper.museum +newyork.museum +niepce.museum +norfolk.museum +north.museum +nrw.museum +nuernberg.museum +nuremberg.museum +nyc.museum +nyny.museum +oceanographic.museum +oceanographique.museum +omaha.museum +online.museum +ontario.museum +openair.museum +oregon.museum +oregontrail.museum +otago.museum +oxford.museum +pacific.museum +paderborn.museum +palace.museum +paleo.museum +palmsprings.museum +panama.museum +paris.museum +pasadena.museum +pharmacy.museum +philadelphia.museum +philadelphiaarea.museum +philately.museum +phoenix.museum +photography.museum +pilots.museum +pittsburgh.museum +planetarium.museum +plantation.museum +plants.museum +plaza.museum +portal.museum +portland.museum +portlligat.museum +posts-and-telecommunications.museum +preservation.museum +presidio.museum +press.museum +project.museum +public.museum +pubol.museum +quebec.museum +railroad.museum +railway.museum +research.museum +resistance.museum +riodejaneiro.museum +rochester.museum +rockart.museum +roma.museum +russia.museum +saintlouis.museum +salem.museum +salvadordali.museum +salzburg.museum +sandiego.museum +sanfrancisco.museum +santabarbara.museum +santacruz.museum +santafe.museum +saskatchewan.museum +satx.museum +savannahga.museum +schlesisches.museum +schoenbrunn.museum +schokoladen.museum +school.museum +schweiz.museum +science.museum +scienceandhistory.museum +scienceandindustry.museum +sciencecenter.museum +sciencecenters.museum +science-fiction.museum +sciencehistory.museum +sciences.museum +sciencesnaturelles.museum +scotland.museum +seaport.museum +settlement.museum +settlers.museum +shell.museum +sherbrooke.museum +sibenik.museum +silk.museum +ski.museum +skole.museum +society.museum +sologne.museum +soundandvision.museum +southcarolina.museum +southwest.museum +space.museum +spy.museum +square.museum +stadt.museum +stalbans.museum +starnberg.museum +state.museum +stateofdelaware.museum +station.museum +steam.museum +steiermark.museum +stjohn.museum +stockholm.museum +stpetersburg.museum +stuttgart.museum +suisse.museum +surgeonshall.museum +surrey.museum +svizzera.museum +sweden.museum +sydney.museum +tank.museum +tcm.museum +technology.museum +telekommunikation.museum +television.museum +texas.museum +textile.museum +theater.museum +time.museum +timekeeping.museum +topology.museum +torino.museum +touch.museum +town.museum +transport.museum +tree.museum +trolley.museum +trust.museum +trustee.museum +uhren.museum +ulm.museum +undersea.museum +university.museum +usa.museum +usantiques.museum +usarts.museum +uscountryestate.museum +usculture.museum +usdecorativearts.museum +usgarden.museum +ushistory.museum +ushuaia.museum +uslivinghistory.museum +utah.museum +uvic.museum +valley.museum +vantaa.museum +versailles.museum +viking.museum +village.museum +virginia.museum +virtual.museum +virtuel.museum +vlaanderen.museum +volkenkunde.museum +wales.museum +wallonie.museum +war.museum +washingtondc.museum +watchandclock.museum +watch-and-clock.museum +western.museum +westfalen.museum +whaling.museum +wildlife.museum +williamsburg.museum +windmill.museum +workshop.museum +york.museum +yorkshire.museum +yosemite.museum +youth.museum +zoological.museum +zoology.museum +xn--9dbhblg6di.museum +xn--h1aegh.museum + +// mv : https://en.wikipedia.org/wiki/.mv +// "mv" included because, contra Wikipedia, google.mv exists. +mv +aero.mv +biz.mv +com.mv +coop.mv +edu.mv +gov.mv +info.mv +int.mv +mil.mv +museum.mv +name.mv +net.mv +org.mv +pro.mv + +// mw : http://www.registrar.mw/ +mw +ac.mw +biz.mw +co.mw +com.mw +coop.mw +edu.mw +gov.mw +int.mw +museum.mw +net.mw +org.mw + +// mx : http://www.nic.mx/ +// Submitted by registry +mx +com.mx +org.mx +gob.mx +edu.mx +net.mx + +// my : http://www.mynic.net.my/ +my +com.my +net.my +org.my +gov.my +edu.my +mil.my +name.my + +// mz : http://www.uem.mz/ +// Submitted by registry +mz +ac.mz +adv.mz +co.mz +edu.mz +gov.mz +mil.mz +net.mz +org.mz + +// na : http://www.na-nic.com.na/ +// http://www.info.na/domain/ +na +info.na +pro.na +name.na +school.na +or.na +dr.na +us.na +mx.na +ca.na +in.na +cc.na +tv.na +ws.na +mobi.na +co.na +com.na +org.na + +// name : has 2nd-level tlds, but there's no list of them +name + +// nc : http://www.cctld.nc/ +nc +asso.nc +nom.nc + +// ne : https://en.wikipedia.org/wiki/.ne +ne + +// net : https://en.wikipedia.org/wiki/.net +net + +// nf : https://en.wikipedia.org/wiki/.nf +nf +com.nf +net.nf +per.nf +rec.nf +web.nf +arts.nf +firm.nf +info.nf +other.nf +store.nf + +// ng : http://www.nira.org.ng/index.php/join-us/register-ng-domain/189-nira-slds +ng +com.ng +edu.ng +gov.ng +i.ng +mil.ng +mobi.ng +name.ng +net.ng +org.ng +sch.ng + +// ni : http://www.nic.ni/ +ni +ac.ni +biz.ni +co.ni +com.ni +edu.ni +gob.ni +in.ni +info.ni +int.ni +mil.ni +net.ni +nom.ni +org.ni +web.ni + +// nl : https://en.wikipedia.org/wiki/.nl +// https://www.sidn.nl/ +// ccTLD for the Netherlands +nl + +// BV.nl will be a registry for dutch BV's (besloten vennootschap) +bv.nl + +// no : http://www.norid.no/regelverk/index.en.html +// The Norwegian registry has declined to notify us of updates. The web pages +// referenced below are the official source of the data. There is also an +// announce mailing list: +// https://postlister.uninett.no/sympa/info/norid-diskusjon +no +// Norid generic domains : http://www.norid.no/regelverk/vedlegg-c.en.html +fhs.no +vgs.no +fylkesbibl.no +folkebibl.no +museum.no +idrett.no +priv.no +// Non-Norid generic domains : http://www.norid.no/regelverk/vedlegg-d.en.html +mil.no +stat.no +dep.no +kommune.no +herad.no +// no geographical names : http://www.norid.no/regelverk/vedlegg-b.en.html +// counties +aa.no +ah.no +bu.no +fm.no +hl.no +hm.no +jan-mayen.no +mr.no +nl.no +nt.no +of.no +ol.no +oslo.no +rl.no +sf.no +st.no +svalbard.no +tm.no +tr.no +va.no +vf.no +// primary and lower secondary schools per county +gs.aa.no +gs.ah.no +gs.bu.no +gs.fm.no +gs.hl.no +gs.hm.no +gs.jan-mayen.no +gs.mr.no +gs.nl.no +gs.nt.no +gs.of.no +gs.ol.no +gs.oslo.no +gs.rl.no +gs.sf.no +gs.st.no +gs.svalbard.no +gs.tm.no +gs.tr.no +gs.va.no +gs.vf.no +// cities +akrehamn.no +xn--krehamn-dxa.no +algard.no +xn--lgrd-poac.no +arna.no +brumunddal.no +bryne.no +bronnoysund.no +xn--brnnysund-m8ac.no +drobak.no +xn--drbak-wua.no +egersund.no +fetsund.no +floro.no +xn--flor-jra.no +fredrikstad.no +hokksund.no +honefoss.no +xn--hnefoss-q1a.no +jessheim.no +jorpeland.no +xn--jrpeland-54a.no +kirkenes.no +kopervik.no +krokstadelva.no +langevag.no +xn--langevg-jxa.no +leirvik.no +mjondalen.no +xn--mjndalen-64a.no +mo-i-rana.no +mosjoen.no +xn--mosjen-eya.no +nesoddtangen.no +orkanger.no +osoyro.no +xn--osyro-wua.no +raholt.no +xn--rholt-mra.no +sandnessjoen.no +xn--sandnessjen-ogb.no +skedsmokorset.no +slattum.no +spjelkavik.no +stathelle.no +stavern.no +stjordalshalsen.no +xn--stjrdalshalsen-sqb.no +tananger.no +tranby.no +vossevangen.no +// communities +afjord.no +xn--fjord-lra.no +agdenes.no +al.no +xn--l-1fa.no +alesund.no +xn--lesund-hua.no +alstahaug.no +alta.no +xn--lt-liac.no +alaheadju.no +xn--laheadju-7ya.no +alvdal.no +amli.no +xn--mli-tla.no +amot.no +xn--mot-tla.no +andebu.no +andoy.no +xn--andy-ira.no +andasuolo.no +ardal.no +xn--rdal-poa.no +aremark.no +arendal.no +xn--s-1fa.no +aseral.no +xn--seral-lra.no +asker.no +askim.no +askvoll.no +askoy.no +xn--asky-ira.no +asnes.no +xn--snes-poa.no +audnedaln.no +aukra.no +aure.no +aurland.no +aurskog-holand.no +xn--aurskog-hland-jnb.no +austevoll.no +austrheim.no +averoy.no +xn--avery-yua.no +balestrand.no +ballangen.no +balat.no +xn--blt-elab.no +balsfjord.no +bahccavuotna.no +xn--bhccavuotna-k7a.no +bamble.no +bardu.no +beardu.no +beiarn.no +bajddar.no +xn--bjddar-pta.no +baidar.no +xn--bidr-5nac.no +berg.no +bergen.no +berlevag.no +xn--berlevg-jxa.no +bearalvahki.no +xn--bearalvhki-y4a.no +bindal.no +birkenes.no +bjarkoy.no +xn--bjarky-fya.no +bjerkreim.no +bjugn.no +bodo.no +xn--bod-2na.no +badaddja.no +xn--bdddj-mrabd.no +budejju.no +bokn.no +bremanger.no +bronnoy.no +xn--brnny-wuac.no +bygland.no +bykle.no +barum.no +xn--brum-voa.no +bo.telemark.no +xn--b-5ga.telemark.no +bo.nordland.no +xn--b-5ga.nordland.no +bievat.no +xn--bievt-0qa.no +bomlo.no +xn--bmlo-gra.no +batsfjord.no +xn--btsfjord-9za.no +bahcavuotna.no +xn--bhcavuotna-s4a.no +dovre.no +drammen.no +drangedal.no +dyroy.no +xn--dyry-ira.no +donna.no +xn--dnna-gra.no +eid.no +eidfjord.no +eidsberg.no +eidskog.no +eidsvoll.no +eigersund.no +elverum.no +enebakk.no +engerdal.no +etne.no +etnedal.no +evenes.no +evenassi.no +xn--eveni-0qa01ga.no +evje-og-hornnes.no +farsund.no +fauske.no +fuossko.no +fuoisku.no +fedje.no +fet.no +finnoy.no +xn--finny-yua.no +fitjar.no +fjaler.no +fjell.no +flakstad.no +flatanger.no +flekkefjord.no +flesberg.no +flora.no +fla.no +xn--fl-zia.no +folldal.no +forsand.no +fosnes.no +frei.no +frogn.no +froland.no +frosta.no +frana.no +xn--frna-woa.no +froya.no +xn--frya-hra.no +fusa.no +fyresdal.no +forde.no +xn--frde-gra.no +gamvik.no +gangaviika.no +xn--ggaviika-8ya47h.no +gaular.no +gausdal.no +gildeskal.no +xn--gildeskl-g0a.no +giske.no +gjemnes.no +gjerdrum.no +gjerstad.no +gjesdal.no +gjovik.no +xn--gjvik-wua.no +gloppen.no +gol.no +gran.no +grane.no +granvin.no +gratangen.no +grimstad.no +grong.no +kraanghke.no +xn--kranghke-b0a.no +grue.no +gulen.no +hadsel.no +halden.no +halsa.no +hamar.no +hamaroy.no +habmer.no +xn--hbmer-xqa.no +hapmir.no +xn--hpmir-xqa.no +hammerfest.no +hammarfeasta.no +xn--hmmrfeasta-s4ac.no +haram.no +hareid.no +harstad.no +hasvik.no +aknoluokta.no +xn--koluokta-7ya57h.no +hattfjelldal.no +aarborte.no +haugesund.no +hemne.no +hemnes.no +hemsedal.no +heroy.more-og-romsdal.no +xn--hery-ira.xn--mre-og-romsdal-qqb.no +heroy.nordland.no +xn--hery-ira.nordland.no +hitra.no +hjartdal.no +hjelmeland.no +hobol.no +xn--hobl-ira.no +hof.no +hol.no +hole.no +holmestrand.no +holtalen.no +xn--holtlen-hxa.no +hornindal.no +horten.no +hurdal.no +hurum.no +hvaler.no +hyllestad.no +hagebostad.no +xn--hgebostad-g3a.no +hoyanger.no +xn--hyanger-q1a.no +hoylandet.no +xn--hylandet-54a.no +ha.no +xn--h-2fa.no +ibestad.no +inderoy.no +xn--indery-fya.no +iveland.no +jevnaker.no +jondal.no +jolster.no +xn--jlster-bya.no +karasjok.no +karasjohka.no +xn--krjohka-hwab49j.no +karlsoy.no +galsa.no +xn--gls-elac.no +karmoy.no +xn--karmy-yua.no +kautokeino.no +guovdageaidnu.no +klepp.no +klabu.no +xn--klbu-woa.no +kongsberg.no +kongsvinger.no +kragero.no +xn--krager-gya.no +kristiansand.no +kristiansund.no +krodsherad.no +xn--krdsherad-m8a.no +kvalsund.no +rahkkeravju.no +xn--rhkkervju-01af.no +kvam.no +kvinesdal.no +kvinnherad.no +kviteseid.no +kvitsoy.no +xn--kvitsy-fya.no +kvafjord.no +xn--kvfjord-nxa.no +giehtavuoatna.no +kvanangen.no +xn--kvnangen-k0a.no +navuotna.no +xn--nvuotna-hwa.no +kafjord.no +xn--kfjord-iua.no +gaivuotna.no +xn--givuotna-8ya.no +larvik.no +lavangen.no +lavagis.no +loabat.no +xn--loabt-0qa.no +lebesby.no +davvesiida.no +leikanger.no +leirfjord.no +leka.no +leksvik.no +lenvik.no +leangaviika.no +xn--leagaviika-52b.no +lesja.no +levanger.no +lier.no +lierne.no +lillehammer.no +lillesand.no +lindesnes.no +lindas.no +xn--linds-pra.no +lom.no +loppa.no +lahppi.no +xn--lhppi-xqa.no +lund.no +lunner.no +luroy.no +xn--lury-ira.no +luster.no +lyngdal.no +lyngen.no +ivgu.no +lardal.no +lerdal.no +xn--lrdal-sra.no +lodingen.no +xn--ldingen-q1a.no +lorenskog.no +xn--lrenskog-54a.no +loten.no +xn--lten-gra.no +malvik.no +masoy.no +xn--msy-ula0h.no +muosat.no +xn--muost-0qa.no +mandal.no +marker.no +marnardal.no +masfjorden.no +meland.no +meldal.no +melhus.no +meloy.no +xn--mely-ira.no +meraker.no +xn--merker-kua.no +moareke.no +xn--moreke-jua.no +midsund.no +midtre-gauldal.no +modalen.no +modum.no +molde.no +moskenes.no +moss.no +mosvik.no +malselv.no +xn--mlselv-iua.no +malatvuopmi.no +xn--mlatvuopmi-s4a.no +namdalseid.no +aejrie.no +namsos.no +namsskogan.no +naamesjevuemie.no +xn--nmesjevuemie-tcba.no +laakesvuemie.no +nannestad.no +narvik.no +narviika.no +naustdal.no +nedre-eiker.no +nes.akershus.no +nes.buskerud.no +nesna.no +nesodden.no +nesseby.no +unjarga.no +xn--unjrga-rta.no +nesset.no +nissedal.no +nittedal.no +nord-aurdal.no +nord-fron.no +nord-odal.no +norddal.no +nordkapp.no +davvenjarga.no +xn--davvenjrga-y4a.no +nordre-land.no +nordreisa.no +raisa.no +xn--risa-5na.no +nore-og-uvdal.no +notodden.no +naroy.no +xn--nry-yla5g.no +notteroy.no +xn--nttery-byae.no +odda.no +oksnes.no +xn--ksnes-uua.no +oppdal.no +oppegard.no +xn--oppegrd-ixa.no +orkdal.no +orland.no +xn--rland-uua.no +orskog.no +xn--rskog-uua.no +orsta.no +xn--rsta-fra.no +os.hedmark.no +os.hordaland.no +osen.no +osteroy.no +xn--ostery-fya.no +ostre-toten.no +xn--stre-toten-zcb.no +overhalla.no +ovre-eiker.no +xn--vre-eiker-k8a.no +oyer.no +xn--yer-zna.no +oygarden.no +xn--ygarden-p1a.no +oystre-slidre.no +xn--ystre-slidre-ujb.no +porsanger.no +porsangu.no +xn--porsgu-sta26f.no +porsgrunn.no +radoy.no +xn--rady-ira.no +rakkestad.no +rana.no +ruovat.no +randaberg.no +rauma.no +rendalen.no +rennebu.no +rennesoy.no +xn--rennesy-v1a.no +rindal.no +ringebu.no +ringerike.no +ringsaker.no +rissa.no +risor.no +xn--risr-ira.no +roan.no +rollag.no +rygge.no +ralingen.no +xn--rlingen-mxa.no +rodoy.no +xn--rdy-0nab.no +romskog.no +xn--rmskog-bya.no +roros.no +xn--rros-gra.no +rost.no +xn--rst-0na.no +royken.no +xn--ryken-vua.no +royrvik.no +xn--ryrvik-bya.no +rade.no +xn--rde-ula.no +salangen.no +siellak.no +saltdal.no +salat.no +xn--slt-elab.no +xn--slat-5na.no +samnanger.no +sande.more-og-romsdal.no +sande.xn--mre-og-romsdal-qqb.no +sande.vestfold.no +sandefjord.no +sandnes.no +sandoy.no +xn--sandy-yua.no +sarpsborg.no +sauda.no +sauherad.no +sel.no +selbu.no +selje.no +seljord.no +sigdal.no +siljan.no +sirdal.no +skaun.no +skedsmo.no +ski.no +skien.no +skiptvet.no +skjervoy.no +xn--skjervy-v1a.no +skierva.no +xn--skierv-uta.no +skjak.no +xn--skjk-soa.no +skodje.no +skanland.no +xn--sknland-fxa.no +skanit.no +xn--sknit-yqa.no +smola.no +xn--smla-hra.no +snillfjord.no +snasa.no +xn--snsa-roa.no +snoasa.no +snaase.no +xn--snase-nra.no +sogndal.no +sokndal.no +sola.no +solund.no +songdalen.no +sortland.no +spydeberg.no +stange.no +stavanger.no +steigen.no +steinkjer.no +stjordal.no +xn--stjrdal-s1a.no +stokke.no +stor-elvdal.no +stord.no +stordal.no +storfjord.no +omasvuotna.no +strand.no +stranda.no +stryn.no +sula.no +suldal.no +sund.no +sunndal.no +surnadal.no +sveio.no +svelvik.no +sykkylven.no +sogne.no +xn--sgne-gra.no +somna.no +xn--smna-gra.no +sondre-land.no +xn--sndre-land-0cb.no +sor-aurdal.no +xn--sr-aurdal-l8a.no +sor-fron.no +xn--sr-fron-q1a.no +sor-odal.no +xn--sr-odal-q1a.no +sor-varanger.no +xn--sr-varanger-ggb.no +matta-varjjat.no +xn--mtta-vrjjat-k7af.no +sorfold.no +xn--srfold-bya.no +sorreisa.no +xn--srreisa-q1a.no +sorum.no +xn--srum-gra.no +tana.no +deatnu.no +time.no +tingvoll.no +tinn.no +tjeldsund.no +dielddanuorri.no +tjome.no +xn--tjme-hra.no +tokke.no +tolga.no +torsken.no +tranoy.no +xn--trany-yua.no +tromso.no +xn--troms-zua.no +tromsa.no +romsa.no +trondheim.no +troandin.no +trysil.no +trana.no +xn--trna-woa.no +trogstad.no +xn--trgstad-r1a.no +tvedestrand.no +tydal.no +tynset.no +tysfjord.no +divtasvuodna.no +divttasvuotna.no +tysnes.no +tysvar.no +xn--tysvr-vra.no +tonsberg.no +xn--tnsberg-q1a.no +ullensaker.no +ullensvang.no +ulvik.no +utsira.no +vadso.no +xn--vads-jra.no +cahcesuolo.no +xn--hcesuolo-7ya35b.no +vaksdal.no +valle.no +vang.no +vanylven.no +vardo.no +xn--vard-jra.no +varggat.no +xn--vrggt-xqad.no +vefsn.no +vaapste.no +vega.no +vegarshei.no +xn--vegrshei-c0a.no +vennesla.no +verdal.no +verran.no +vestby.no +vestnes.no +vestre-slidre.no +vestre-toten.no +vestvagoy.no +xn--vestvgy-ixa6o.no +vevelstad.no +vik.no +vikna.no +vindafjord.no +volda.no +voss.no +varoy.no +xn--vry-yla5g.no +vagan.no +xn--vgan-qoa.no +voagat.no +vagsoy.no +xn--vgsy-qoa0j.no +vaga.no +xn--vg-yiab.no +valer.ostfold.no +xn--vler-qoa.xn--stfold-9xa.no +valer.hedmark.no +xn--vler-qoa.hedmark.no + +// np : http://www.mos.com.np/register.html +*.np + +// nr : http://cenpac.net.nr/dns/index.html +// Submitted by registry +nr +biz.nr +info.nr +gov.nr +edu.nr +org.nr +net.nr +com.nr + +// nu : https://en.wikipedia.org/wiki/.nu +nu + +// nz : https://en.wikipedia.org/wiki/.nz +// Submitted by registry +nz +ac.nz +co.nz +cri.nz +geek.nz +gen.nz +govt.nz +health.nz +iwi.nz +kiwi.nz +maori.nz +mil.nz +xn--mori-qsa.nz +net.nz +org.nz +parliament.nz +school.nz + +// om : https://en.wikipedia.org/wiki/.om +om +co.om +com.om +edu.om +gov.om +med.om +museum.om +net.om +org.om +pro.om + +// onion : https://tools.ietf.org/html/rfc7686 +onion + +// org : https://en.wikipedia.org/wiki/.org +org + +// pa : http://www.nic.pa/ +// Some additional second level "domains" resolve directly as hostnames, such as +// pannet.pa, so we add a rule for "pa". +pa +ac.pa +gob.pa +com.pa +org.pa +sld.pa +edu.pa +net.pa +ing.pa +abo.pa +med.pa +nom.pa + +// pe : https://www.nic.pe/InformeFinalComision.pdf +pe +edu.pe +gob.pe +nom.pe +mil.pe +org.pe +com.pe +net.pe + +// pf : http://www.gobin.info/domainname/formulaire-pf.pdf +pf +com.pf +org.pf +edu.pf + +// pg : https://en.wikipedia.org/wiki/.pg +*.pg + +// ph : http://www.domains.ph/FAQ2.asp +// Submitted by registry +ph +com.ph +net.ph +org.ph +gov.ph +edu.ph +ngo.ph +mil.ph +i.ph + +// pk : http://pk5.pknic.net.pk/pk5/msgNamepk.PK +pk +com.pk +net.pk +edu.pk +org.pk +fam.pk +biz.pk +web.pk +gov.pk +gob.pk +gok.pk +gon.pk +gop.pk +gos.pk +info.pk + +// pl http://www.dns.pl/english/index.html +// Submitted by registry +pl +com.pl +net.pl +org.pl +// pl functional domains (http://www.dns.pl/english/index.html) +aid.pl +agro.pl +atm.pl +auto.pl +biz.pl +edu.pl +gmina.pl +gsm.pl +info.pl +mail.pl +miasta.pl +media.pl +mil.pl +nieruchomosci.pl +nom.pl +pc.pl +powiat.pl +priv.pl +realestate.pl +rel.pl +sex.pl +shop.pl +sklep.pl +sos.pl +szkola.pl +targi.pl +tm.pl +tourism.pl +travel.pl +turystyka.pl +// Government domains +gov.pl +ap.gov.pl +ic.gov.pl +is.gov.pl +us.gov.pl +kmpsp.gov.pl +kppsp.gov.pl +kwpsp.gov.pl +psp.gov.pl +wskr.gov.pl +kwp.gov.pl +mw.gov.pl +ug.gov.pl +um.gov.pl +umig.gov.pl +ugim.gov.pl +upow.gov.pl +uw.gov.pl +starostwo.gov.pl +pa.gov.pl +po.gov.pl +psse.gov.pl +pup.gov.pl +rzgw.gov.pl +sa.gov.pl +so.gov.pl +sr.gov.pl +wsa.gov.pl +sko.gov.pl +uzs.gov.pl +wiih.gov.pl +winb.gov.pl +pinb.gov.pl +wios.gov.pl +witd.gov.pl +wzmiuw.gov.pl +piw.gov.pl +wiw.gov.pl +griw.gov.pl +wif.gov.pl +oum.gov.pl +sdn.gov.pl +zp.gov.pl +uppo.gov.pl +mup.gov.pl +wuoz.gov.pl +konsulat.gov.pl +oirm.gov.pl +// pl regional domains (http://www.dns.pl/english/index.html) +augustow.pl +babia-gora.pl +bedzin.pl +beskidy.pl +bialowieza.pl +bialystok.pl +bielawa.pl +bieszczady.pl +boleslawiec.pl +bydgoszcz.pl +bytom.pl +cieszyn.pl +czeladz.pl +czest.pl +dlugoleka.pl +elblag.pl +elk.pl +glogow.pl +gniezno.pl +gorlice.pl +grajewo.pl +ilawa.pl +jaworzno.pl +jelenia-gora.pl +jgora.pl +kalisz.pl +kazimierz-dolny.pl +karpacz.pl +kartuzy.pl +kaszuby.pl +katowice.pl +kepno.pl +ketrzyn.pl +klodzko.pl +kobierzyce.pl +kolobrzeg.pl +konin.pl +konskowola.pl +kutno.pl +lapy.pl +lebork.pl +legnica.pl +lezajsk.pl +limanowa.pl +lomza.pl +lowicz.pl +lubin.pl +lukow.pl +malbork.pl +malopolska.pl +mazowsze.pl +mazury.pl +mielec.pl +mielno.pl +mragowo.pl +naklo.pl +nowaruda.pl +nysa.pl +olawa.pl +olecko.pl +olkusz.pl +olsztyn.pl +opoczno.pl +opole.pl +ostroda.pl +ostroleka.pl +ostrowiec.pl +ostrowwlkp.pl +pila.pl +pisz.pl +podhale.pl +podlasie.pl +polkowice.pl +pomorze.pl +pomorskie.pl +prochowice.pl +pruszkow.pl +przeworsk.pl +pulawy.pl +radom.pl +rawa-maz.pl +rybnik.pl +rzeszow.pl +sanok.pl +sejny.pl +slask.pl +slupsk.pl +sosnowiec.pl +stalowa-wola.pl +skoczow.pl +starachowice.pl +stargard.pl +suwalki.pl +swidnica.pl +swiebodzin.pl +swinoujscie.pl +szczecin.pl +szczytno.pl +tarnobrzeg.pl +tgory.pl +turek.pl +tychy.pl +ustka.pl +walbrzych.pl +warmia.pl +warszawa.pl +waw.pl +wegrow.pl +wielun.pl +wlocl.pl +wloclawek.pl +wodzislaw.pl +wolomin.pl +wroclaw.pl +zachpomor.pl +zagan.pl +zarow.pl +zgora.pl +zgorzelec.pl + +// pm : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +pm + +// pn : http://www.government.pn/PnRegistry/policies.htm +pn +gov.pn +co.pn +org.pn +edu.pn +net.pn + +// post : https://en.wikipedia.org/wiki/.post +post + +// pr : http://www.nic.pr/index.asp?f=1 +pr +com.pr +net.pr +org.pr +gov.pr +edu.pr +isla.pr +pro.pr +biz.pr +info.pr +name.pr +// these aren't mentioned on nic.pr, but on https://en.wikipedia.org/wiki/.pr +est.pr +prof.pr +ac.pr + +// pro : http://registry.pro/get-pro +pro +aaa.pro +aca.pro +acct.pro +avocat.pro +bar.pro +cpa.pro +eng.pro +jur.pro +law.pro +med.pro +recht.pro + +// ps : https://en.wikipedia.org/wiki/.ps +// http://www.nic.ps/registration/policy.html#reg +ps +edu.ps +gov.ps +sec.ps +plo.ps +com.ps +org.ps +net.ps + +// pt : http://online.dns.pt/dns/start_dns +pt +net.pt +gov.pt +org.pt +edu.pt +int.pt +publ.pt +com.pt +nome.pt + +// pw : https://en.wikipedia.org/wiki/.pw +pw +co.pw +ne.pw +or.pw +ed.pw +go.pw +belau.pw + +// py : http://www.nic.py/pautas.html#seccion_9 +// Submitted by registry +py +com.py +coop.py +edu.py +gov.py +mil.py +net.py +org.py + +// qa : http://domains.qa/en/ +qa +com.qa +edu.qa +gov.qa +mil.qa +name.qa +net.qa +org.qa +sch.qa + +// re : http://www.afnic.re/obtenir/chartes/nommage-re/annexe-descriptifs +re +asso.re +com.re +nom.re + +// ro : http://www.rotld.ro/ +ro +arts.ro +com.ro +firm.ro +info.ro +nom.ro +nt.ro +org.ro +rec.ro +store.ro +tm.ro +www.ro + +// rs : https://www.rnids.rs/en/domains/national-domains +rs +ac.rs +co.rs +edu.rs +gov.rs +in.rs +org.rs + +// ru : https://cctld.ru/en/domains/domens_ru/reserved/ +ru +ac.ru +edu.ru +gov.ru +int.ru +mil.ru +test.ru + +// rw : http://www.nic.rw/cgi-bin/policy.pl +rw +gov.rw +net.rw +edu.rw +ac.rw +com.rw +co.rw +int.rw +mil.rw +gouv.rw + +// sa : http://www.nic.net.sa/ +sa +com.sa +net.sa +org.sa +gov.sa +med.sa +pub.sa +edu.sa +sch.sa + +// sb : http://www.sbnic.net.sb/ +// Submitted by registry +sb +com.sb +edu.sb +gov.sb +net.sb +org.sb + +// sc : http://www.nic.sc/ +sc +com.sc +gov.sc +net.sc +org.sc +edu.sc + +// sd : http://www.isoc.sd/sudanic.isoc.sd/billing_pricing.htm +// Submitted by registry +sd +com.sd +net.sd +org.sd +edu.sd +med.sd +tv.sd +gov.sd +info.sd + +// se : https://en.wikipedia.org/wiki/.se +// Submitted by registry +se +a.se +ac.se +b.se +bd.se +brand.se +c.se +d.se +e.se +f.se +fh.se +fhsk.se +fhv.se +g.se +h.se +i.se +k.se +komforb.se +kommunalforbund.se +komvux.se +l.se +lanbib.se +m.se +n.se +naturbruksgymn.se +o.se +org.se +p.se +parti.se +pp.se +press.se +r.se +s.se +t.se +tm.se +u.se +w.se +x.se +y.se +z.se + +// sg : http://www.nic.net.sg/page/registration-policies-procedures-and-guidelines +sg +com.sg +net.sg +org.sg +gov.sg +edu.sg +per.sg + +// sh : http://www.nic.sh/registrar.html +sh +com.sh +net.sh +gov.sh +org.sh +mil.sh + +// si : https://en.wikipedia.org/wiki/.si +si + +// sj : No registrations at this time. +// Submitted by registry +sj + +// sk : https://en.wikipedia.org/wiki/.sk +// list of 2nd level domains ? +sk + +// sl : http://www.nic.sl +// Submitted by registry +sl +com.sl +net.sl +edu.sl +gov.sl +org.sl + +// sm : https://en.wikipedia.org/wiki/.sm +sm + +// sn : https://en.wikipedia.org/wiki/.sn +sn +art.sn +com.sn +edu.sn +gouv.sn +org.sn +perso.sn +univ.sn + +// so : http://www.soregistry.com/ +so +com.so +net.so +org.so + +// sr : https://en.wikipedia.org/wiki/.sr +sr + +// st : http://www.nic.st/html/policyrules/ +st +co.st +com.st +consulado.st +edu.st +embaixada.st +gov.st +mil.st +net.st +org.st +principe.st +saotome.st +store.st + +// su : https://en.wikipedia.org/wiki/.su +su + +// sv : http://www.svnet.org.sv/niveldos.pdf +sv +com.sv +edu.sv +gob.sv +org.sv +red.sv + +// sx : https://en.wikipedia.org/wiki/.sx +// Submitted by registry +sx +gov.sx + +// sy : https://en.wikipedia.org/wiki/.sy +// see also: http://www.gobin.info/domainname/sy.doc +sy +edu.sy +gov.sy +net.sy +mil.sy +com.sy +org.sy + +// sz : https://en.wikipedia.org/wiki/.sz +// http://www.sispa.org.sz/ +sz +co.sz +ac.sz +org.sz + +// tc : https://en.wikipedia.org/wiki/.tc +tc + +// td : https://en.wikipedia.org/wiki/.td +td + +// tel: https://en.wikipedia.org/wiki/.tel +// http://www.telnic.org/ +tel + +// tf : https://en.wikipedia.org/wiki/.tf +tf + +// tg : https://en.wikipedia.org/wiki/.tg +// http://www.nic.tg/ +tg + +// th : https://en.wikipedia.org/wiki/.th +// Submitted by registry +th +ac.th +co.th +go.th +in.th +mi.th +net.th +or.th + +// tj : http://www.nic.tj/policy.html +tj +ac.tj +biz.tj +co.tj +com.tj +edu.tj +go.tj +gov.tj +int.tj +mil.tj +name.tj +net.tj +nic.tj +org.tj +test.tj +web.tj + +// tk : https://en.wikipedia.org/wiki/.tk +tk + +// tl : https://en.wikipedia.org/wiki/.tl +tl +gov.tl + +// tm : http://www.nic.tm/local.html +tm +com.tm +co.tm +org.tm +net.tm +nom.tm +gov.tm +mil.tm +edu.tm + +// tn : https://en.wikipedia.org/wiki/.tn +// http://whois.ati.tn/ +tn +com.tn +ens.tn +fin.tn +gov.tn +ind.tn +intl.tn +nat.tn +net.tn +org.tn +info.tn +perso.tn +tourism.tn +edunet.tn +rnrt.tn +rns.tn +rnu.tn +mincom.tn +agrinet.tn +defense.tn +turen.tn + +// to : https://en.wikipedia.org/wiki/.to +// Submitted by registry +to +com.to +gov.to +net.to +org.to +edu.to +mil.to + +// subTLDs: https://www.nic.tr/forms/eng/policies.pdf +// and: https://www.nic.tr/forms/politikalar.pdf +// Submitted by +tr +com.tr +info.tr +biz.tr +net.tr +org.tr +web.tr +gen.tr +tv.tr +av.tr +dr.tr +bbs.tr +name.tr +tel.tr +gov.tr +bel.tr +pol.tr +mil.tr +k12.tr +edu.tr +kep.tr + +// Used by Northern Cyprus +nc.tr + +// Used by government agencies of Northern Cyprus +gov.nc.tr + +// travel : https://en.wikipedia.org/wiki/.travel +travel + +// tt : http://www.nic.tt/ +tt +co.tt +com.tt +org.tt +net.tt +biz.tt +info.tt +pro.tt +int.tt +coop.tt +jobs.tt +mobi.tt +travel.tt +museum.tt +aero.tt +name.tt +gov.tt +edu.tt + +// tv : https://en.wikipedia.org/wiki/.tv +// Not listing any 2LDs as reserved since none seem to exist in practice, +// Wikipedia notwithstanding. +tv + +// tw : https://en.wikipedia.org/wiki/.tw +tw +edu.tw +gov.tw +mil.tw +com.tw +net.tw +org.tw +idv.tw +game.tw +ebiz.tw +club.tw +xn--zf0ao64a.tw +xn--uc0atv.tw +xn--czrw28b.tw + +// tz : http://www.tznic.or.tz/index.php/domains +// Submitted by registry +tz +ac.tz +co.tz +go.tz +hotel.tz +info.tz +me.tz +mil.tz +mobi.tz +ne.tz +or.tz +sc.tz +tv.tz + +// ua : https://hostmaster.ua/policy/?ua +// Submitted by registry +ua +// ua 2LD +com.ua +edu.ua +gov.ua +in.ua +net.ua +org.ua +// ua geographic names +// https://hostmaster.ua/2ld/ +cherkassy.ua +cherkasy.ua +chernigov.ua +chernihiv.ua +chernivtsi.ua +chernovtsy.ua +ck.ua +cn.ua +cr.ua +crimea.ua +cv.ua +dn.ua +dnepropetrovsk.ua +dnipropetrovsk.ua +dominic.ua +donetsk.ua +dp.ua +if.ua +ivano-frankivsk.ua +kh.ua +kharkiv.ua +kharkov.ua +kherson.ua +khmelnitskiy.ua +khmelnytskyi.ua +kiev.ua +kirovograd.ua +km.ua +kr.ua +krym.ua +ks.ua +kv.ua +kyiv.ua +lg.ua +lt.ua +lugansk.ua +lutsk.ua +lv.ua +lviv.ua +mk.ua +mykolaiv.ua +nikolaev.ua +od.ua +odesa.ua +odessa.ua +pl.ua +poltava.ua +rivne.ua +rovno.ua +rv.ua +sb.ua +sebastopol.ua +sevastopol.ua +sm.ua +sumy.ua +te.ua +ternopil.ua +uz.ua +uzhgorod.ua +vinnica.ua +vinnytsia.ua +vn.ua +volyn.ua +yalta.ua +zaporizhzhe.ua +zaporizhzhia.ua +zhitomir.ua +zhytomyr.ua +zp.ua +zt.ua + +// ug : https://www.registry.co.ug/ +ug +co.ug +or.ug +ac.ug +sc.ug +go.ug +ne.ug +com.ug +org.ug + +// uk : https://en.wikipedia.org/wiki/.uk +// Submitted by registry +uk +ac.uk +co.uk +gov.uk +ltd.uk +me.uk +net.uk +nhs.uk +org.uk +plc.uk +police.uk +*.sch.uk + +// us : https://en.wikipedia.org/wiki/.us +us +dni.us +fed.us +isa.us +kids.us +nsn.us +// us geographic names +ak.us +al.us +ar.us +as.us +az.us +ca.us +co.us +ct.us +dc.us +de.us +fl.us +ga.us +gu.us +hi.us +ia.us +id.us +il.us +in.us +ks.us +ky.us +la.us +ma.us +md.us +me.us +mi.us +mn.us +mo.us +ms.us +mt.us +nc.us +nd.us +ne.us +nh.us +nj.us +nm.us +nv.us +ny.us +oh.us +ok.us +or.us +pa.us +pr.us +ri.us +sc.us +sd.us +tn.us +tx.us +ut.us +vi.us +vt.us +va.us +wa.us +wi.us +wv.us +wy.us +// The registrar notes several more specific domains available in each state, +// such as state.*.us, dst.*.us, etc., but resolution of these is somewhat +// haphazard; in some states these domains resolve as addresses, while in others +// only subdomains are available, or even nothing at all. We include the +// most common ones where it's clear that different sites are different +// entities. +k12.ak.us +k12.al.us +k12.ar.us +k12.as.us +k12.az.us +k12.ca.us +k12.co.us +k12.ct.us +k12.dc.us +k12.de.us +k12.fl.us +k12.ga.us +k12.gu.us +// k12.hi.us Bug 614565 - Hawaii has a state-wide DOE login +k12.ia.us +k12.id.us +k12.il.us +k12.in.us +k12.ks.us +k12.ky.us +k12.la.us +k12.ma.us +k12.md.us +k12.me.us +k12.mi.us +k12.mn.us +k12.mo.us +k12.ms.us +k12.mt.us +k12.nc.us +// k12.nd.us Bug 1028347 - Removed at request of Travis Rosso +k12.ne.us +k12.nh.us +k12.nj.us +k12.nm.us +k12.nv.us +k12.ny.us +k12.oh.us +k12.ok.us +k12.or.us +k12.pa.us +k12.pr.us +k12.ri.us +k12.sc.us +// k12.sd.us Bug 934131 - Removed at request of James Booze +k12.tn.us +k12.tx.us +k12.ut.us +k12.vi.us +k12.vt.us +k12.va.us +k12.wa.us +k12.wi.us +// k12.wv.us Bug 947705 - Removed at request of Verne Britton +k12.wy.us +cc.ak.us +cc.al.us +cc.ar.us +cc.as.us +cc.az.us +cc.ca.us +cc.co.us +cc.ct.us +cc.dc.us +cc.de.us +cc.fl.us +cc.ga.us +cc.gu.us +cc.hi.us +cc.ia.us +cc.id.us +cc.il.us +cc.in.us +cc.ks.us +cc.ky.us +cc.la.us +cc.ma.us +cc.md.us +cc.me.us +cc.mi.us +cc.mn.us +cc.mo.us +cc.ms.us +cc.mt.us +cc.nc.us +cc.nd.us +cc.ne.us +cc.nh.us +cc.nj.us +cc.nm.us +cc.nv.us +cc.ny.us +cc.oh.us +cc.ok.us +cc.or.us +cc.pa.us +cc.pr.us +cc.ri.us +cc.sc.us +cc.sd.us +cc.tn.us +cc.tx.us +cc.ut.us +cc.vi.us +cc.vt.us +cc.va.us +cc.wa.us +cc.wi.us +cc.wv.us +cc.wy.us +lib.ak.us +lib.al.us +lib.ar.us +lib.as.us +lib.az.us +lib.ca.us +lib.co.us +lib.ct.us +lib.dc.us +// lib.de.us Issue #243 - Moved to Private section at request of Ed Moore +lib.fl.us +lib.ga.us +lib.gu.us +lib.hi.us +lib.ia.us +lib.id.us +lib.il.us +lib.in.us +lib.ks.us +lib.ky.us +lib.la.us +lib.ma.us +lib.md.us +lib.me.us +lib.mi.us +lib.mn.us +lib.mo.us +lib.ms.us +lib.mt.us +lib.nc.us +lib.nd.us +lib.ne.us +lib.nh.us +lib.nj.us +lib.nm.us +lib.nv.us +lib.ny.us +lib.oh.us +lib.ok.us +lib.or.us +lib.pa.us +lib.pr.us +lib.ri.us +lib.sc.us +lib.sd.us +lib.tn.us +lib.tx.us +lib.ut.us +lib.vi.us +lib.vt.us +lib.va.us +lib.wa.us +lib.wi.us +// lib.wv.us Bug 941670 - Removed at request of Larry W Arnold +lib.wy.us +// k12.ma.us contains school districts in Massachusetts. The 4LDs are +// managed independently except for private (PVT), charter (CHTR) and +// parochial (PAROCH) schools. Those are delegated directly to the +// 5LD operators. +pvt.k12.ma.us +chtr.k12.ma.us +paroch.k12.ma.us +// Merit Network, Inc. maintains the registry for =~ /(k12|cc|lib).mi.us/ and the following +// see also: http://domreg.merit.edu +// see also: whois -h whois.domreg.merit.edu help +ann-arbor.mi.us +cog.mi.us +dst.mi.us +eaton.mi.us +gen.mi.us +mus.mi.us +tec.mi.us +washtenaw.mi.us + +// uy : http://www.nic.org.uy/ +uy +com.uy +edu.uy +gub.uy +mil.uy +net.uy +org.uy + +// uz : http://www.reg.uz/ +uz +co.uz +com.uz +net.uz +org.uz + +// va : https://en.wikipedia.org/wiki/.va +va + +// vc : https://en.wikipedia.org/wiki/.vc +// Submitted by registry +vc +com.vc +net.vc +org.vc +gov.vc +mil.vc +edu.vc + +// ve : https://registro.nic.ve/ +// Submitted by registry +ve +arts.ve +co.ve +com.ve +e12.ve +edu.ve +firm.ve +gob.ve +gov.ve +info.ve +int.ve +mil.ve +net.ve +org.ve +rec.ve +store.ve +tec.ve +web.ve + +// vg : https://en.wikipedia.org/wiki/.vg +vg + +// vi : http://www.nic.vi/newdomainform.htm +// http://www.nic.vi/Domain_Rules/body_domain_rules.html indicates some other +// TLDs are "reserved", such as edu.vi and gov.vi, but doesn't actually say they +// are available for registration (which they do not seem to be). +vi +co.vi +com.vi +k12.vi +net.vi +org.vi + +// vn : https://www.dot.vn/vnnic/vnnic/domainregistration.jsp +vn +com.vn +net.vn +org.vn +edu.vn +gov.vn +int.vn +ac.vn +biz.vn +info.vn +name.vn +pro.vn +health.vn + +// vu : https://en.wikipedia.org/wiki/.vu +// http://www.vunic.vu/ +vu +com.vu +edu.vu +net.vu +org.vu + +// wf : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +wf + +// ws : https://en.wikipedia.org/wiki/.ws +// http://samoanic.ws/index.dhtml +ws +com.ws +net.ws +org.ws +gov.ws +edu.ws + +// yt : http://www.afnic.fr/medias/documents/AFNIC-naming-policy2012.pdf +yt + +// IDN ccTLDs +// When submitting patches, please maintain a sort by ISO 3166 ccTLD, then +// U-label, and follow this format: +// // A-Label ("", [, variant info]) : +// // [sponsoring org] +// U-Label + +// xn--mgbaam7a8h ("Emerat", Arabic) : AE +// http://nic.ae/english/arabicdomain/rules.jsp +xn--mgbaam7a8h + +// xn--y9a3aq ("hye", Armenian) : AM +// ISOC AM (operated by .am Registry) +xn--y9a3aq + +// xn--54b7fta0cc ("Bangla", Bangla) : BD +xn--54b7fta0cc + +// xn--90ae ("bg", Bulgarian) : BG +xn--90ae + +// xn--90ais ("bel", Belarusian/Russian Cyrillic) : BY +// Operated by .by registry +xn--90ais + +// xn--fiqs8s ("Zhongguo/China", Chinese, Simplified) : CN +// CNNIC +// http://cnnic.cn/html/Dir/2005/10/11/3218.htm +xn--fiqs8s + +// xn--fiqz9s ("Zhongguo/China", Chinese, Traditional) : CN +// CNNIC +// http://cnnic.cn/html/Dir/2005/10/11/3218.htm +xn--fiqz9s + +// xn--lgbbat1ad8j ("Algeria/Al Jazair", Arabic) : DZ +xn--lgbbat1ad8j + +// xn--wgbh1c ("Egypt/Masr", Arabic) : EG +// http://www.dotmasr.eg/ +xn--wgbh1c + +// xn--e1a4c ("eu", Cyrillic) : EU +xn--e1a4c + +// xn--node ("ge", Georgian Mkhedruli) : GE +xn--node + +// xn--qxam ("el", Greek) : GR +// Hellenic Ministry of Infrastructure, Transport, and Networks +xn--qxam + +// xn--j6w193g ("Hong Kong", Chinese) : HK +// https://www2.hkirc.hk/register/rules.jsp +xn--j6w193g + +// xn--2scrj9c ("Bharat", Kannada) : IN +// India +xn--2scrj9c + +// xn--3hcrj9c ("Bharat", Oriya) : IN +// India +xn--3hcrj9c + +// xn--45br5cyl ("Bharatam", Assamese) : IN +// India +xn--45br5cyl + +// xn--h2breg3eve ("Bharatam", Sanskrit) : IN +// India +xn--h2breg3eve + +// xn--h2brj9c8c ("Bharot", Santali) : IN +// India +xn--h2brj9c8c + +// xn--mgbgu82a ("Bharat", Sindhi) : IN +// India +xn--mgbgu82a + +// xn--rvc1e0am3e ("Bharatam", Malayalam) : IN +// India +xn--rvc1e0am3e + +// xn--h2brj9c ("Bharat", Devanagari) : IN +// India +xn--h2brj9c + +// xn--mgbbh1a71e ("Bharat", Arabic) : IN +// India +xn--mgbbh1a71e + +// xn--fpcrj9c3d ("Bharat", Telugu) : IN +// India +xn--fpcrj9c3d + +// xn--gecrj9c ("Bharat", Gujarati) : IN +// India +xn--gecrj9c + +// xn--s9brj9c ("Bharat", Gurmukhi) : IN +// India +xn--s9brj9c + +// xn--45brj9c ("Bharat", Bengali) : IN +// India +xn--45brj9c + +// xn--xkc2dl3a5ee0h ("India", Tamil) : IN +// India +xn--xkc2dl3a5ee0h + +// xn--mgba3a4f16a ("Iran", Persian) : IR +xn--mgba3a4f16a + +// xn--mgba3a4fra ("Iran", Arabic) : IR +xn--mgba3a4fra + +// xn--mgbtx2b ("Iraq", Arabic) : IQ +// Communications and Media Commission +xn--mgbtx2b + +// xn--mgbayh7gpa ("al-Ordon", Arabic) : JO +// National Information Technology Center (NITC) +// Royal Scientific Society, Al-Jubeiha +xn--mgbayh7gpa + +// xn--3e0b707e ("Republic of Korea", Hangul) : KR +xn--3e0b707e + +// xn--80ao21a ("Kaz", Kazakh) : KZ +xn--80ao21a + +// xn--fzc2c9e2c ("Lanka", Sinhalese-Sinhala) : LK +// http://nic.lk +xn--fzc2c9e2c + +// xn--xkc2al3hye2a ("Ilangai", Tamil) : LK +// http://nic.lk +xn--xkc2al3hye2a + +// xn--mgbc0a9azcg ("Morocco/al-Maghrib", Arabic) : MA +xn--mgbc0a9azcg + +// xn--d1alf ("mkd", Macedonian) : MK +// MARnet +xn--d1alf + +// xn--l1acc ("mon", Mongolian) : MN +xn--l1acc + +// xn--mix891f ("Macao", Chinese, Traditional) : MO +// MONIC / HNET Asia (Registry Operator for .mo) +xn--mix891f + +// xn--mix082f ("Macao", Chinese, Simplified) : MO +xn--mix082f + +// xn--mgbx4cd0ab ("Malaysia", Malay) : MY +xn--mgbx4cd0ab + +// xn--mgb9awbf ("Oman", Arabic) : OM +xn--mgb9awbf + +// xn--mgbai9azgqp6j ("Pakistan", Urdu/Arabic) : PK +xn--mgbai9azgqp6j + +// xn--mgbai9a5eva00b ("Pakistan", Urdu/Arabic, variant) : PK +xn--mgbai9a5eva00b + +// xn--ygbi2ammx ("Falasteen", Arabic) : PS +// The Palestinian National Internet Naming Authority (PNINA) +// http://www.pnina.ps +xn--ygbi2ammx + +// xn--90a3ac ("srb", Cyrillic) : RS +// https://www.rnids.rs/en/domains/national-domains +xn--90a3ac +xn--o1ac.xn--90a3ac +xn--c1avg.xn--90a3ac +xn--90azh.xn--90a3ac +xn--d1at.xn--90a3ac +xn--o1ach.xn--90a3ac +xn--80au.xn--90a3ac + +// xn--p1ai ("rf", Russian-Cyrillic) : RU +// http://www.cctld.ru/en/docs/rulesrf.php +xn--p1ai + +// xn--wgbl6a ("Qatar", Arabic) : QA +// http://www.ict.gov.qa/ +xn--wgbl6a + +// xn--mgberp4a5d4ar ("AlSaudiah", Arabic) : SA +// http://www.nic.net.sa/ +xn--mgberp4a5d4ar + +// xn--mgberp4a5d4a87g ("AlSaudiah", Arabic, variant) : SA +xn--mgberp4a5d4a87g + +// xn--mgbqly7c0a67fbc ("AlSaudiah", Arabic, variant) : SA +xn--mgbqly7c0a67fbc + +// xn--mgbqly7cvafr ("AlSaudiah", Arabic, variant) : SA +xn--mgbqly7cvafr + +// xn--mgbpl2fh ("sudan", Arabic) : SD +// Operated by .sd registry +xn--mgbpl2fh + +// xn--yfro4i67o Singapore ("Singapore", Chinese) : SG +xn--yfro4i67o + +// xn--clchc0ea0b2g2a9gcd ("Singapore", Tamil) : SG +xn--clchc0ea0b2g2a9gcd + +// xn--ogbpf8fl ("Syria", Arabic) : SY +xn--ogbpf8fl + +// xn--mgbtf8fl ("Syria", Arabic, variant) : SY +xn--mgbtf8fl + +// xn--o3cw4h ("Thai", Thai) : TH +// http://www.thnic.co.th +xn--o3cw4h +xn--12c1fe0br.xn--o3cw4h +xn--12co0c3b4eva.xn--o3cw4h +xn--h3cuzk1di.xn--o3cw4h +xn--o3cyx2a.xn--o3cw4h +xn--m3ch0j3a.xn--o3cw4h +xn--12cfi8ixb8l.xn--o3cw4h + +// xn--pgbs0dh ("Tunisia", Arabic) : TN +// http://nic.tn +xn--pgbs0dh + +// xn--kpry57d ("Taiwan", Chinese, Traditional) : TW +// http://www.twnic.net/english/dn/dn_07a.htm +xn--kpry57d + +// xn--kprw13d ("Taiwan", Chinese, Simplified) : TW +// http://www.twnic.net/english/dn/dn_07a.htm +xn--kprw13d + +// xn--nnx388a ("Taiwan", Chinese, variant) : TW +xn--nnx388a + +// xn--j1amh ("ukr", Cyrillic) : UA +xn--j1amh + +// xn--mgb2ddes ("AlYemen", Arabic) : YE +xn--mgb2ddes + +// xxx : http://icmregistry.com +xxx + +// ye : http://www.y.net.ye/services/domain_name.htm +*.ye + +// za : http://www.zadna.org.za/content/page/domain-information +ac.za +agric.za +alt.za +co.za +edu.za +gov.za +grondar.za +law.za +mil.za +net.za +ngo.za +nis.za +nom.za +org.za +school.za +tm.za +web.za + +// zm : https://zicta.zm/ +// Submitted by registry +zm +ac.zm +biz.zm +co.zm +com.zm +edu.zm +gov.zm +info.zm +mil.zm +net.zm +org.zm +sch.zm + +// zw : https://www.potraz.gov.zw/ +// Confirmed by registry 2017-01-25 +zw +ac.zw +co.zw +gov.zw +mil.zw +org.zw + +// List of new gTLDs imported from https://newgtlds.icann.org/newgtlds.csv on 2017-02-23T00:46:09Z + +// aaa : 2015-02-26 American Automobile Association, Inc. +aaa + +// aarp : 2015-05-21 AARP +aarp + +// abarth : 2015-07-30 Fiat Chrysler Automobiles N.V. +abarth + +// abb : 2014-10-24 ABB Ltd +abb + +// abbott : 2014-07-24 Abbott Laboratories, Inc. +abbott + +// abbvie : 2015-07-30 AbbVie Inc. +abbvie + +// abc : 2015-07-30 Disney Enterprises, Inc. +abc + +// able : 2015-06-25 Able Inc. +able + +// abogado : 2014-04-24 Top Level Domain Holdings Limited +abogado + +// abudhabi : 2015-07-30 Abu Dhabi Systems and Information Centre +abudhabi + +// academy : 2013-11-07 Half Oaks, LLC +academy + +// accenture : 2014-08-15 Accenture plc +accenture + +// accountant : 2014-11-20 dot Accountant Limited +accountant + +// accountants : 2014-03-20 Knob Town, LLC +accountants + +// aco : 2015-01-08 ACO Severin Ahlmann GmbH & Co. KG +aco + +// active : 2014-05-01 The Active Network, Inc +active + +// actor : 2013-12-12 United TLD Holdco Ltd. +actor + +// adac : 2015-07-16 Allgemeiner Deutscher Automobil-Club e.V. (ADAC) +adac + +// ads : 2014-12-04 Charleston Road Registry Inc. +ads + +// adult : 2014-10-16 ICM Registry AD LLC +adult + +// aeg : 2015-03-19 Aktiebolaget Electrolux +aeg + +// aetna : 2015-05-21 Aetna Life Insurance Company +aetna + +// afamilycompany : 2015-07-23 Johnson Shareholdings, Inc. +afamilycompany + +// afl : 2014-10-02 Australian Football League +afl + +// africa : 2014-03-24 ZA Central Registry NPC trading as Registry.Africa +africa + +// agakhan : 2015-04-23 Fondation Aga Khan (Aga Khan Foundation) +agakhan + +// agency : 2013-11-14 Steel Falls, LLC +agency + +// aig : 2014-12-18 American International Group, Inc. +aig + +// aigo : 2015-08-06 aigo Digital Technology Co,Ltd. +aigo + +// airbus : 2015-07-30 Airbus S.A.S. +airbus + +// airforce : 2014-03-06 United TLD Holdco Ltd. +airforce + +// airtel : 2014-10-24 Bharti Airtel Limited +airtel + +// akdn : 2015-04-23 Fondation Aga Khan (Aga Khan Foundation) +akdn + +// alfaromeo : 2015-07-31 Fiat Chrysler Automobiles N.V. +alfaromeo + +// alibaba : 2015-01-15 Alibaba Group Holding Limited +alibaba + +// alipay : 2015-01-15 Alibaba Group Holding Limited +alipay + +// allfinanz : 2014-07-03 Allfinanz Deutsche Vermögensberatung Aktiengesellschaft +allfinanz + +// allstate : 2015-07-31 Allstate Fire and Casualty Insurance Company +allstate + +// ally : 2015-06-18 Ally Financial Inc. +ally + +// alsace : 2014-07-02 REGION D ALSACE +alsace + +// alstom : 2015-07-30 ALSTOM +alstom + +// americanexpress : 2015-07-31 American Express Travel Related Services Company, Inc. +americanexpress + +// americanfamily : 2015-07-23 AmFam, Inc. +americanfamily + +// amex : 2015-07-31 American Express Travel Related Services Company, Inc. +amex + +// amfam : 2015-07-23 AmFam, Inc. +amfam + +// amica : 2015-05-28 Amica Mutual Insurance Company +amica + +// amsterdam : 2014-07-24 Gemeente Amsterdam +amsterdam + +// analytics : 2014-12-18 Campus IP LLC +analytics + +// android : 2014-08-07 Charleston Road Registry Inc. +android + +// anquan : 2015-01-08 QIHOO 360 TECHNOLOGY CO. LTD. +anquan + +// anz : 2015-07-31 Australia and New Zealand Banking Group Limited +anz + +// aol : 2015-09-17 AOL Inc. +aol + +// apartments : 2014-12-11 June Maple, LLC +apartments + +// app : 2015-05-14 Charleston Road Registry Inc. +app + +// apple : 2015-05-14 Apple Inc. +apple + +// aquarelle : 2014-07-24 Aquarelle.com +aquarelle + +// arab : 2015-11-12 League of Arab States +arab + +// aramco : 2014-11-20 Aramco Services Company +aramco + +// archi : 2014-02-06 STARTING DOT LIMITED +archi + +// army : 2014-03-06 United TLD Holdco Ltd. +army + +// art : 2016-03-24 UK Creative Ideas Limited +art + +// arte : 2014-12-11 Association Relative à la Télévision Européenne G.E.I.E. +arte + +// asda : 2015-07-31 Wal-Mart Stores, Inc. +asda + +// associates : 2014-03-06 Baxter Hill, LLC +associates + +// athleta : 2015-07-30 The Gap, Inc. +athleta + +// attorney : 2014-03-20 +attorney + +// auction : 2014-03-20 +auction + +// audi : 2015-05-21 AUDI Aktiengesellschaft +audi + +// audible : 2015-06-25 Amazon EU S.à r.l. +audible + +// audio : 2014-03-20 Uniregistry, Corp. +audio + +// auspost : 2015-08-13 Australian Postal Corporation +auspost + +// author : 2014-12-18 Amazon EU S.à r.l. +author + +// auto : 2014-11-13 +auto + +// autos : 2014-01-09 DERAutos, LLC +autos + +// avianca : 2015-01-08 Aerovias del Continente Americano S.A. Avianca +avianca + +// aws : 2015-06-25 Amazon EU S.à r.l. +aws + +// axa : 2013-12-19 AXA SA +axa + +// azure : 2014-12-18 Microsoft Corporation +azure + +// baby : 2015-04-09 Johnson & Johnson Services, Inc. +baby + +// baidu : 2015-01-08 Baidu, Inc. +baidu + +// banamex : 2015-07-30 Citigroup Inc. +banamex + +// bananarepublic : 2015-07-31 The Gap, Inc. +bananarepublic + +// band : 2014-06-12 +band + +// bank : 2014-09-25 fTLD Registry Services LLC +bank + +// bar : 2013-12-12 Punto 2012 Sociedad Anonima Promotora de Inversion de Capital Variable +bar + +// barcelona : 2014-07-24 Municipi de Barcelona +barcelona + +// barclaycard : 2014-11-20 Barclays Bank PLC +barclaycard + +// barclays : 2014-11-20 Barclays Bank PLC +barclays + +// barefoot : 2015-06-11 Gallo Vineyards, Inc. +barefoot + +// bargains : 2013-11-14 Half Hallow, LLC +bargains + +// baseball : 2015-10-29 MLB Advanced Media DH, LLC +baseball + +// basketball : 2015-08-20 Fédération Internationale de Basketball (FIBA) +basketball + +// bauhaus : 2014-04-17 Werkhaus GmbH +bauhaus + +// bayern : 2014-01-23 Bayern Connect GmbH +bayern + +// bbc : 2014-12-18 British Broadcasting Corporation +bbc + +// bbt : 2015-07-23 BB&T Corporation +bbt + +// bbva : 2014-10-02 BANCO BILBAO VIZCAYA ARGENTARIA, S.A. +bbva + +// bcg : 2015-04-02 The Boston Consulting Group, Inc. +bcg + +// bcn : 2014-07-24 Municipi de Barcelona +bcn + +// beats : 2015-05-14 Beats Electronics, LLC +beats + +// beauty : 2015-12-03 L'Oréal +beauty + +// beer : 2014-01-09 Top Level Domain Holdings Limited +beer + +// bentley : 2014-12-18 Bentley Motors Limited +bentley + +// berlin : 2013-10-31 dotBERLIN GmbH & Co. KG +berlin + +// best : 2013-12-19 BestTLD Pty Ltd +best + +// bestbuy : 2015-07-31 BBY Solutions, Inc. +bestbuy + +// bet : 2015-05-07 Afilias plc +bet + +// bharti : 2014-01-09 Bharti Enterprises (Holding) Private Limited +bharti + +// bible : 2014-06-19 American Bible Society +bible + +// bid : 2013-12-19 dot Bid Limited +bid + +// bike : 2013-08-27 Grand Hollow, LLC +bike + +// bing : 2014-12-18 Microsoft Corporation +bing + +// bingo : 2014-12-04 Sand Cedar, LLC +bingo + +// bio : 2014-03-06 STARTING DOT LIMITED +bio + +// black : 2014-01-16 Afilias Limited +black + +// blackfriday : 2014-01-16 Uniregistry, Corp. +blackfriday + +// blanco : 2015-07-16 BLANCO GmbH + Co KG +blanco + +// blockbuster : 2015-07-30 Dish DBS Corporation +blockbuster + +// blog : 2015-05-14 +blog + +// bloomberg : 2014-07-17 Bloomberg IP Holdings LLC +bloomberg + +// blue : 2013-11-07 Afilias Limited +blue + +// bms : 2014-10-30 Bristol-Myers Squibb Company +bms + +// bmw : 2014-01-09 Bayerische Motoren Werke Aktiengesellschaft +bmw + +// bnl : 2014-07-24 Banca Nazionale del Lavoro +bnl + +// bnpparibas : 2014-05-29 BNP Paribas +bnpparibas + +// boats : 2014-12-04 DERBoats, LLC +boats + +// boehringer : 2015-07-09 Boehringer Ingelheim International GmbH +boehringer + +// bofa : 2015-07-31 NMS Services, Inc. +bofa + +// bom : 2014-10-16 Núcleo de Informação e Coordenação do Ponto BR - NIC.br +bom + +// bond : 2014-06-05 Bond University Limited +bond + +// boo : 2014-01-30 Charleston Road Registry Inc. +boo + +// book : 2015-08-27 Amazon EU S.à r.l. +book + +// booking : 2015-07-16 Booking.com B.V. +booking + +// boots : 2015-01-08 THE BOOTS COMPANY PLC +boots + +// bosch : 2015-06-18 Robert Bosch GMBH +bosch + +// bostik : 2015-05-28 Bostik SA +bostik + +// boston : 2015-12-10 +boston + +// bot : 2014-12-18 Amazon EU S.à r.l. +bot + +// boutique : 2013-11-14 Over Galley, LLC +boutique + +// box : 2015-11-12 NS1 Limited +box + +// bradesco : 2014-12-18 Banco Bradesco S.A. +bradesco + +// bridgestone : 2014-12-18 Bridgestone Corporation +bridgestone + +// broadway : 2014-12-22 Celebrate Broadway, Inc. +broadway + +// broker : 2014-12-11 IG Group Holdings PLC +broker + +// brother : 2015-01-29 Brother Industries, Ltd. +brother + +// brussels : 2014-02-06 DNS.be vzw +brussels + +// budapest : 2013-11-21 Top Level Domain Holdings Limited +budapest + +// bugatti : 2015-07-23 Bugatti International SA +bugatti + +// build : 2013-11-07 Plan Bee LLC +build + +// builders : 2013-11-07 Atomic Madison, LLC +builders + +// business : 2013-11-07 Spring Cross, LLC +business + +// buy : 2014-12-18 Amazon EU S.à r.l. +buy + +// buzz : 2013-10-02 DOTSTRATEGY CO. +buzz + +// bzh : 2014-02-27 Association www.bzh +bzh + +// cab : 2013-10-24 Half Sunset, LLC +cab + +// cafe : 2015-02-11 Pioneer Canyon, LLC +cafe + +// cal : 2014-07-24 Charleston Road Registry Inc. +cal + +// call : 2014-12-18 Amazon EU S.à r.l. +call + +// calvinklein : 2015-07-30 PVH gTLD Holdings LLC +calvinklein + +// cam : 2016-04-21 AC Webconnecting Holding B.V. +cam + +// camera : 2013-08-27 Atomic Maple, LLC +camera + +// camp : 2013-11-07 Delta Dynamite, LLC +camp + +// cancerresearch : 2014-05-15 Australian Cancer Research Foundation +cancerresearch + +// canon : 2014-09-12 Canon Inc. +canon + +// capetown : 2014-03-24 ZA Central Registry NPC trading as ZA Central Registry +capetown + +// capital : 2014-03-06 Delta Mill, LLC +capital + +// capitalone : 2015-08-06 Capital One Financial Corporation +capitalone + +// car : 2015-01-22 +car + +// caravan : 2013-12-12 Caravan International, Inc. +caravan + +// cards : 2013-12-05 Foggy Hollow, LLC +cards + +// care : 2014-03-06 Goose Cross +care + +// career : 2013-10-09 dotCareer LLC +career + +// careers : 2013-10-02 Wild Corner, LLC +careers + +// cars : 2014-11-13 +cars + +// cartier : 2014-06-23 Richemont DNS Inc. +cartier + +// casa : 2013-11-21 Top Level Domain Holdings Limited +casa + +// case : 2015-09-03 CNH Industrial N.V. +case + +// caseih : 2015-09-03 CNH Industrial N.V. +caseih + +// cash : 2014-03-06 Delta Lake, LLC +cash + +// casino : 2014-12-18 Binky Sky, LLC +casino + +// catering : 2013-12-05 New Falls. LLC +catering + +// catholic : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication) +catholic + +// cba : 2014-06-26 COMMONWEALTH BANK OF AUSTRALIA +cba + +// cbn : 2014-08-22 The Christian Broadcasting Network, Inc. +cbn + +// cbre : 2015-07-02 CBRE, Inc. +cbre + +// cbs : 2015-08-06 CBS Domains Inc. +cbs + +// ceb : 2015-04-09 The Corporate Executive Board Company +ceb + +// center : 2013-11-07 Tin Mill, LLC +center + +// ceo : 2013-11-07 CEOTLD Pty Ltd +ceo + +// cern : 2014-06-05 European Organization for Nuclear Research ("CERN") +cern + +// cfa : 2014-08-28 CFA Institute +cfa + +// cfd : 2014-12-11 IG Group Holdings PLC +cfd + +// chanel : 2015-04-09 Chanel International B.V. +chanel + +// channel : 2014-05-08 Charleston Road Registry Inc. +channel + +// chase : 2015-04-30 JPMorgan Chase & Co. +chase + +// chat : 2014-12-04 Sand Fields, LLC +chat + +// cheap : 2013-11-14 Sand Cover, LLC +cheap + +// chintai : 2015-06-11 CHINTAI Corporation +chintai + +// christmas : 2013-11-21 Uniregistry, Corp. +christmas + +// chrome : 2014-07-24 Charleston Road Registry Inc. +chrome + +// chrysler : 2015-07-30 FCA US LLC. +chrysler + +// church : 2014-02-06 Holly Fields, LLC +church + +// cipriani : 2015-02-19 Hotel Cipriani Srl +cipriani + +// circle : 2014-12-18 Amazon EU S.à r.l. +circle + +// cisco : 2014-12-22 Cisco Technology, Inc. +cisco + +// citadel : 2015-07-23 Citadel Domain LLC +citadel + +// citi : 2015-07-30 Citigroup Inc. +citi + +// citic : 2014-01-09 CITIC Group Corporation +citic + +// city : 2014-05-29 Snow Sky, LLC +city + +// cityeats : 2014-12-11 Lifestyle Domain Holdings, Inc. +cityeats + +// claims : 2014-03-20 Black Corner, LLC +claims + +// cleaning : 2013-12-05 Fox Shadow, LLC +cleaning + +// click : 2014-06-05 Uniregistry, Corp. +click + +// clinic : 2014-03-20 Goose Park, LLC +clinic + +// clinique : 2015-10-01 The Estée Lauder Companies Inc. +clinique + +// clothing : 2013-08-27 Steel Lake, LLC +clothing + +// cloud : 2015-04-16 ARUBA S.p.A. +cloud + +// club : 2013-11-08 .CLUB DOMAINS, LLC +club + +// clubmed : 2015-06-25 Club Méditerranée S.A. +clubmed + +// coach : 2014-10-09 Koko Island, LLC +coach + +// codes : 2013-10-31 Puff Willow, LLC +codes + +// coffee : 2013-10-17 Trixy Cover, LLC +coffee + +// college : 2014-01-16 XYZ.COM LLC +college + +// cologne : 2014-02-05 NetCologne Gesellschaft für Telekommunikation mbH +cologne + +// comcast : 2015-07-23 Comcast IP Holdings I, LLC +comcast + +// commbank : 2014-06-26 COMMONWEALTH BANK OF AUSTRALIA +commbank + +// community : 2013-12-05 Fox Orchard, LLC +community + +// company : 2013-11-07 Silver Avenue, LLC +company + +// compare : 2015-10-08 iSelect Ltd +compare + +// computer : 2013-10-24 Pine Mill, LLC +computer + +// comsec : 2015-01-08 VeriSign, Inc. +comsec + +// condos : 2013-12-05 Pine House, LLC +condos + +// construction : 2013-09-16 Fox Dynamite, LLC +construction + +// consulting : 2013-12-05 +consulting + +// contact : 2015-01-08 Top Level Spectrum, Inc. +contact + +// contractors : 2013-09-10 Magic Woods, LLC +contractors + +// cooking : 2013-11-21 Top Level Domain Holdings Limited +cooking + +// cookingchannel : 2015-07-02 Lifestyle Domain Holdings, Inc. +cookingchannel + +// cool : 2013-11-14 Koko Lake, LLC +cool + +// corsica : 2014-09-25 Collectivité Territoriale de Corse +corsica + +// country : 2013-12-19 Top Level Domain Holdings Limited +country + +// coupon : 2015-02-26 Amazon EU S.à r.l. +coupon + +// coupons : 2015-03-26 Black Island, LLC +coupons + +// courses : 2014-12-04 OPEN UNIVERSITIES AUSTRALIA PTY LTD +courses + +// credit : 2014-03-20 Snow Shadow, LLC +credit + +// creditcard : 2014-03-20 Binky Frostbite, LLC +creditcard + +// creditunion : 2015-01-22 CUNA Performance Resources, LLC +creditunion + +// cricket : 2014-10-09 dot Cricket Limited +cricket + +// crown : 2014-10-24 Crown Equipment Corporation +crown + +// crs : 2014-04-03 Federated Co-operatives Limited +crs + +// cruise : 2015-12-10 Viking River Cruises (Bermuda) Ltd. +cruise + +// cruises : 2013-12-05 Spring Way, LLC +cruises + +// csc : 2014-09-25 Alliance-One Services, Inc. +csc + +// cuisinella : 2014-04-03 SALM S.A.S. +cuisinella + +// cymru : 2014-05-08 Nominet UK +cymru + +// cyou : 2015-01-22 Beijing Gamease Age Digital Technology Co., Ltd. +cyou + +// dabur : 2014-02-06 Dabur India Limited +dabur + +// dad : 2014-01-23 Charleston Road Registry Inc. +dad + +// dance : 2013-10-24 United TLD Holdco Ltd. +dance + +// data : 2016-06-02 Dish DBS Corporation +data + +// date : 2014-11-20 dot Date Limited +date + +// dating : 2013-12-05 Pine Fest, LLC +dating + +// datsun : 2014-03-27 NISSAN MOTOR CO., LTD. +datsun + +// day : 2014-01-30 Charleston Road Registry Inc. +day + +// dclk : 2014-11-20 Charleston Road Registry Inc. +dclk + +// dds : 2015-05-07 Top Level Domain Holdings Limited +dds + +// deal : 2015-06-25 Amazon EU S.à r.l. +deal + +// dealer : 2014-12-22 Dealer Dot Com, Inc. +dealer + +// deals : 2014-05-22 Sand Sunset, LLC +deals + +// degree : 2014-03-06 +degree + +// delivery : 2014-09-11 Steel Station, LLC +delivery + +// dell : 2014-10-24 Dell Inc. +dell + +// deloitte : 2015-07-31 Deloitte Touche Tohmatsu +deloitte + +// delta : 2015-02-19 Delta Air Lines, Inc. +delta + +// democrat : 2013-10-24 United TLD Holdco Ltd. +democrat + +// dental : 2014-03-20 Tin Birch, LLC +dental + +// dentist : 2014-03-20 +dentist + +// desi : 2013-11-14 Desi Networks LLC +desi + +// design : 2014-11-07 Top Level Design, LLC +design + +// dev : 2014-10-16 Charleston Road Registry Inc. +dev + +// dhl : 2015-07-23 Deutsche Post AG +dhl + +// diamonds : 2013-09-22 John Edge, LLC +diamonds + +// diet : 2014-06-26 Uniregistry, Corp. +diet + +// digital : 2014-03-06 Dash Park, LLC +digital + +// direct : 2014-04-10 Half Trail, LLC +direct + +// directory : 2013-09-20 Extra Madison, LLC +directory + +// discount : 2014-03-06 Holly Hill, LLC +discount + +// discover : 2015-07-23 Discover Financial Services +discover + +// dish : 2015-07-30 Dish DBS Corporation +dish + +// diy : 2015-11-05 Lifestyle Domain Holdings, Inc. +diy + +// dnp : 2013-12-13 Dai Nippon Printing Co., Ltd. +dnp + +// docs : 2014-10-16 Charleston Road Registry Inc. +docs + +// doctor : 2016-06-02 Brice Trail, LLC +doctor + +// dodge : 2015-07-30 FCA US LLC. +dodge + +// dog : 2014-12-04 Koko Mill, LLC +dog + +// doha : 2014-09-18 Communications Regulatory Authority (CRA) +doha + +// domains : 2013-10-17 Sugar Cross, LLC +domains + +// dot : 2015-05-21 Dish DBS Corporation +dot + +// download : 2014-11-20 dot Support Limited +download + +// drive : 2015-03-05 Charleston Road Registry Inc. +drive + +// dtv : 2015-06-04 Dish DBS Corporation +dtv + +// dubai : 2015-01-01 Dubai Smart Government Department +dubai + +// duck : 2015-07-23 Johnson Shareholdings, Inc. +duck + +// dunlop : 2015-07-02 The Goodyear Tire & Rubber Company +dunlop + +// duns : 2015-08-06 The Dun & Bradstreet Corporation +duns + +// dupont : 2015-06-25 E. I. du Pont de Nemours and Company +dupont + +// durban : 2014-03-24 ZA Central Registry NPC trading as ZA Central Registry +durban + +// dvag : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG +dvag + +// dvr : 2016-05-26 Hughes Satellite Systems Corporation +dvr + +// earth : 2014-12-04 Interlink Co., Ltd. +earth + +// eat : 2014-01-23 Charleston Road Registry Inc. +eat + +// eco : 2016-07-08 Big Room Inc. +eco + +// edeka : 2014-12-18 EDEKA Verband kaufmännischer Genossenschaften e.V. +edeka + +// education : 2013-11-07 Brice Way, LLC +education + +// email : 2013-10-31 Spring Madison, LLC +email + +// emerck : 2014-04-03 Merck KGaA +emerck + +// energy : 2014-09-11 Binky Birch, LLC +energy + +// engineer : 2014-03-06 United TLD Holdco Ltd. +engineer + +// engineering : 2014-03-06 Romeo Canyon +engineering + +// enterprises : 2013-09-20 Snow Oaks, LLC +enterprises + +// epost : 2015-07-23 Deutsche Post AG +epost + +// epson : 2014-12-04 Seiko Epson Corporation +epson + +// equipment : 2013-08-27 Corn Station, LLC +equipment + +// ericsson : 2015-07-09 Telefonaktiebolaget L M Ericsson +ericsson + +// erni : 2014-04-03 ERNI Group Holding AG +erni + +// esq : 2014-05-08 Charleston Road Registry Inc. +esq + +// estate : 2013-08-27 Trixy Park, LLC +estate + +// esurance : 2015-07-23 Esurance Insurance Company +esurance + +// etisalat : 2015-09-03 Emirates Telecommunications Corporation (trading as Etisalat) +etisalat + +// eurovision : 2014-04-24 European Broadcasting Union (EBU) +eurovision + +// eus : 2013-12-12 Puntueus Fundazioa +eus + +// events : 2013-12-05 Pioneer Maple, LLC +events + +// everbank : 2014-05-15 EverBank +everbank + +// exchange : 2014-03-06 Spring Falls, LLC +exchange + +// expert : 2013-11-21 Magic Pass, LLC +expert + +// exposed : 2013-12-05 Victor Beach, LLC +exposed + +// express : 2015-02-11 Sea Sunset, LLC +express + +// extraspace : 2015-05-14 Extra Space Storage LLC +extraspace + +// fage : 2014-12-18 Fage International S.A. +fage + +// fail : 2014-03-06 Atomic Pipe, LLC +fail + +// fairwinds : 2014-11-13 FairWinds Partners, LLC +fairwinds + +// faith : 2014-11-20 dot Faith Limited +faith + +// family : 2015-04-02 +family + +// fan : 2014-03-06 +fan + +// fans : 2014-11-07 Asiamix Digital Limited +fans + +// farm : 2013-11-07 Just Maple, LLC +farm + +// farmers : 2015-07-09 Farmers Insurance Exchange +farmers + +// fashion : 2014-07-03 Top Level Domain Holdings Limited +fashion + +// fast : 2014-12-18 Amazon EU S.à r.l. +fast + +// fedex : 2015-08-06 Federal Express Corporation +fedex + +// feedback : 2013-12-19 Top Level Spectrum, Inc. +feedback + +// ferrari : 2015-07-31 Fiat Chrysler Automobiles N.V. +ferrari + +// ferrero : 2014-12-18 Ferrero Trading Lux S.A. +ferrero + +// fiat : 2015-07-31 Fiat Chrysler Automobiles N.V. +fiat + +// fidelity : 2015-07-30 Fidelity Brokerage Services LLC +fidelity + +// fido : 2015-08-06 Rogers Communications Partnership +fido + +// film : 2015-01-08 Motion Picture Domain Registry Pty Ltd +film + +// final : 2014-10-16 Núcleo de Informação e Coordenação do Ponto BR - NIC.br +final + +// finance : 2014-03-20 Cotton Cypress, LLC +finance + +// financial : 2014-03-06 Just Cover, LLC +financial + +// fire : 2015-06-25 Amazon EU S.à r.l. +fire + +// firestone : 2014-12-18 Bridgestone Corporation +firestone + +// firmdale : 2014-03-27 Firmdale Holdings Limited +firmdale + +// fish : 2013-12-12 Fox Woods, LLC +fish + +// fishing : 2013-11-21 Top Level Domain Holdings Limited +fishing + +// fit : 2014-11-07 Top Level Domain Holdings Limited +fit + +// fitness : 2014-03-06 Brice Orchard, LLC +fitness + +// flickr : 2015-04-02 Yahoo! Domain Services Inc. +flickr + +// flights : 2013-12-05 Fox Station, LLC +flights + +// flir : 2015-07-23 FLIR Systems, Inc. +flir + +// florist : 2013-11-07 Half Cypress, LLC +florist + +// flowers : 2014-10-09 Uniregistry, Corp. +flowers + +// fly : 2014-05-08 Charleston Road Registry Inc. +fly + +// foo : 2014-01-23 Charleston Road Registry Inc. +foo + +// food : 2016-04-21 Lifestyle Domain Holdings, Inc. +food + +// foodnetwork : 2015-07-02 Lifestyle Domain Holdings, Inc. +foodnetwork + +// football : 2014-12-18 Foggy Farms, LLC +football + +// ford : 2014-11-13 Ford Motor Company +ford + +// forex : 2014-12-11 IG Group Holdings PLC +forex + +// forsale : 2014-05-22 +forsale + +// forum : 2015-04-02 Fegistry, LLC +forum + +// foundation : 2013-12-05 John Dale, LLC +foundation + +// fox : 2015-09-11 FOX Registry, LLC +fox + +// free : 2015-12-10 Amazon EU S.à r.l. +free + +// fresenius : 2015-07-30 Fresenius Immobilien-Verwaltungs-GmbH +fresenius + +// frl : 2014-05-15 FRLregistry B.V. +frl + +// frogans : 2013-12-19 OP3FT +frogans + +// frontdoor : 2015-07-02 Lifestyle Domain Holdings, Inc. +frontdoor + +// frontier : 2015-02-05 Frontier Communications Corporation +frontier + +// ftr : 2015-07-16 Frontier Communications Corporation +ftr + +// fujitsu : 2015-07-30 Fujitsu Limited +fujitsu + +// fujixerox : 2015-07-23 Xerox DNHC LLC +fujixerox + +// fun : 2016-01-14 +fun + +// fund : 2014-03-20 John Castle, LLC +fund + +// furniture : 2014-03-20 Lone Fields, LLC +furniture + +// futbol : 2013-09-20 +futbol + +// fyi : 2015-04-02 Silver Tigers, LLC +fyi + +// gal : 2013-11-07 Asociación puntoGAL +gal + +// gallery : 2013-09-13 Sugar House, LLC +gallery + +// gallo : 2015-06-11 Gallo Vineyards, Inc. +gallo + +// gallup : 2015-02-19 Gallup, Inc. +gallup + +// game : 2015-05-28 Uniregistry, Corp. +game + +// games : 2015-05-28 +games + +// gap : 2015-07-31 The Gap, Inc. +gap + +// garden : 2014-06-26 Top Level Domain Holdings Limited +garden + +// gbiz : 2014-07-17 Charleston Road Registry Inc. +gbiz + +// gdn : 2014-07-31 Joint Stock Company "Navigation-information systems" +gdn + +// gea : 2014-12-04 GEA Group Aktiengesellschaft +gea + +// gent : 2014-01-23 COMBELL GROUP NV/SA +gent + +// genting : 2015-03-12 Resorts World Inc Pte. Ltd. +genting + +// george : 2015-07-31 Wal-Mart Stores, Inc. +george + +// ggee : 2014-01-09 GMO Internet, Inc. +ggee + +// gift : 2013-10-17 Uniregistry, Corp. +gift + +// gifts : 2014-07-03 Goose Sky, LLC +gifts + +// gives : 2014-03-06 United TLD Holdco Ltd. +gives + +// giving : 2014-11-13 Giving Limited +giving + +// glade : 2015-07-23 Johnson Shareholdings, Inc. +glade + +// glass : 2013-11-07 Black Cover, LLC +glass + +// gle : 2014-07-24 Charleston Road Registry Inc. +gle + +// global : 2014-04-17 Dot GLOBAL AS +global + +// globo : 2013-12-19 Globo Comunicação e Participações S.A +globo + +// gmail : 2014-05-01 Charleston Road Registry Inc. +gmail + +// gmbh : 2016-01-29 Extra Dynamite, LLC +gmbh + +// gmo : 2014-01-09 GMO Internet, Inc. +gmo + +// gmx : 2014-04-24 1&1 Mail & Media GmbH +gmx + +// godaddy : 2015-07-23 Go Daddy East, LLC +godaddy + +// gold : 2015-01-22 June Edge, LLC +gold + +// goldpoint : 2014-11-20 YODOBASHI CAMERA CO.,LTD. +goldpoint + +// golf : 2014-12-18 Lone falls, LLC +golf + +// goo : 2014-12-18 NTT Resonant Inc. +goo + +// goodhands : 2015-07-31 Allstate Fire and Casualty Insurance Company +goodhands + +// goodyear : 2015-07-02 The Goodyear Tire & Rubber Company +goodyear + +// goog : 2014-11-20 Charleston Road Registry Inc. +goog + +// google : 2014-07-24 Charleston Road Registry Inc. +google + +// gop : 2014-01-16 Republican State Leadership Committee, Inc. +gop + +// got : 2014-12-18 Amazon EU S.à r.l. +got + +// grainger : 2015-05-07 Grainger Registry Services, LLC +grainger + +// graphics : 2013-09-13 Over Madison, LLC +graphics + +// gratis : 2014-03-20 Pioneer Tigers, LLC +gratis + +// green : 2014-05-08 Afilias Limited +green + +// gripe : 2014-03-06 Corn Sunset, LLC +gripe + +// grocery : 2016-06-16 Wal-Mart Stores, Inc. +grocery + +// group : 2014-08-15 Romeo Town, LLC +group + +// guardian : 2015-07-30 The Guardian Life Insurance Company of America +guardian + +// gucci : 2014-11-13 Guccio Gucci S.p.a. +gucci + +// guge : 2014-08-28 Charleston Road Registry Inc. +guge + +// guide : 2013-09-13 Snow Moon, LLC +guide + +// guitars : 2013-11-14 Uniregistry, Corp. +guitars + +// guru : 2013-08-27 Pioneer Cypress, LLC +guru + +// hair : 2015-12-03 L'Oréal +hair + +// hamburg : 2014-02-20 Hamburg Top-Level-Domain GmbH +hamburg + +// hangout : 2014-11-13 Charleston Road Registry Inc. +hangout + +// haus : 2013-12-05 +haus + +// hbo : 2015-07-30 HBO Registry Services, Inc. +hbo + +// hdfc : 2015-07-30 HOUSING DEVELOPMENT FINANCE CORPORATION LIMITED +hdfc + +// hdfcbank : 2015-02-12 HDFC Bank Limited +hdfcbank + +// health : 2015-02-11 DotHealth, LLC +health + +// healthcare : 2014-06-12 Silver Glen, LLC +healthcare + +// help : 2014-06-26 Uniregistry, Corp. +help + +// helsinki : 2015-02-05 City of Helsinki +helsinki + +// here : 2014-02-06 Charleston Road Registry Inc. +here + +// hermes : 2014-07-10 HERMES INTERNATIONAL +hermes + +// hgtv : 2015-07-02 Lifestyle Domain Holdings, Inc. +hgtv + +// hiphop : 2014-03-06 Uniregistry, Corp. +hiphop + +// hisamitsu : 2015-07-16 Hisamitsu Pharmaceutical Co.,Inc. +hisamitsu + +// hitachi : 2014-10-31 Hitachi, Ltd. +hitachi + +// hiv : 2014-03-13 +hiv + +// hkt : 2015-05-14 PCCW-HKT DataCom Services Limited +hkt + +// hockey : 2015-03-19 Half Willow, LLC +hockey + +// holdings : 2013-08-27 John Madison, LLC +holdings + +// holiday : 2013-11-07 Goose Woods, LLC +holiday + +// homedepot : 2015-04-02 Homer TLC, Inc. +homedepot + +// homegoods : 2015-07-16 The TJX Companies, Inc. +homegoods + +// homes : 2014-01-09 DERHomes, LLC +homes + +// homesense : 2015-07-16 The TJX Companies, Inc. +homesense + +// honda : 2014-12-18 Honda Motor Co., Ltd. +honda + +// honeywell : 2015-07-23 Honeywell GTLD LLC +honeywell + +// horse : 2013-11-21 Top Level Domain Holdings Limited +horse + +// hospital : 2016-10-20 Ruby Pike, LLC +hospital + +// host : 2014-04-17 DotHost Inc. +host + +// hosting : 2014-05-29 Uniregistry, Corp. +hosting + +// hot : 2015-08-27 Amazon EU S.à r.l. +hot + +// hoteles : 2015-03-05 Travel Reservations SRL +hoteles + +// hotels : 2016-04-07 Booking.com B.V. +hotels + +// hotmail : 2014-12-18 Microsoft Corporation +hotmail + +// house : 2013-11-07 Sugar Park, LLC +house + +// how : 2014-01-23 Charleston Road Registry Inc. +how + +// hsbc : 2014-10-24 HSBC Holdings PLC +hsbc + +// hughes : 2015-07-30 Hughes Satellite Systems Corporation +hughes + +// hyatt : 2015-07-30 Hyatt GTLD, L.L.C. +hyatt + +// hyundai : 2015-07-09 Hyundai Motor Company +hyundai + +// ibm : 2014-07-31 International Business Machines Corporation +ibm + +// icbc : 2015-02-19 Industrial and Commercial Bank of China Limited +icbc + +// ice : 2014-10-30 IntercontinentalExchange, Inc. +ice + +// icu : 2015-01-08 One.com A/S +icu + +// ieee : 2015-07-23 IEEE Global LLC +ieee + +// ifm : 2014-01-30 ifm electronic gmbh +ifm + +// ikano : 2015-07-09 Ikano S.A. +ikano + +// imamat : 2015-08-06 Fondation Aga Khan (Aga Khan Foundation) +imamat + +// imdb : 2015-06-25 Amazon EU S.à r.l. +imdb + +// immo : 2014-07-10 Auburn Bloom, LLC +immo + +// immobilien : 2013-11-07 United TLD Holdco Ltd. +immobilien + +// industries : 2013-12-05 Outer House, LLC +industries + +// infiniti : 2014-03-27 NISSAN MOTOR CO., LTD. +infiniti + +// ing : 2014-01-23 Charleston Road Registry Inc. +ing + +// ink : 2013-12-05 Top Level Design, LLC +ink + +// institute : 2013-11-07 Outer Maple, LLC +institute + +// insurance : 2015-02-19 fTLD Registry Services LLC +insurance + +// insure : 2014-03-20 Pioneer Willow, LLC +insure + +// intel : 2015-08-06 Intel Corporation +intel + +// international : 2013-11-07 Wild Way, LLC +international + +// intuit : 2015-07-30 Intuit Administrative Services, Inc. +intuit + +// investments : 2014-03-20 Holly Glen, LLC +investments + +// ipiranga : 2014-08-28 Ipiranga Produtos de Petroleo S.A. +ipiranga + +// irish : 2014-08-07 Dot-Irish LLC +irish + +// iselect : 2015-02-11 iSelect Ltd +iselect + +// ismaili : 2015-08-06 Fondation Aga Khan (Aga Khan Foundation) +ismaili + +// ist : 2014-08-28 Istanbul Metropolitan Municipality +ist + +// istanbul : 2014-08-28 Istanbul Metropolitan Municipality +istanbul + +// itau : 2014-10-02 Itau Unibanco Holding S.A. +itau + +// itv : 2015-07-09 ITV Services Limited +itv + +// iveco : 2015-09-03 CNH Industrial N.V. +iveco + +// iwc : 2014-06-23 Richemont DNS Inc. +iwc + +// jaguar : 2014-11-13 Jaguar Land Rover Ltd +jaguar + +// java : 2014-06-19 Oracle Corporation +java + +// jcb : 2014-11-20 JCB Co., Ltd. +jcb + +// jcp : 2015-04-23 JCP Media, Inc. +jcp + +// jeep : 2015-07-30 FCA US LLC. +jeep + +// jetzt : 2014-01-09 +jetzt + +// jewelry : 2015-03-05 Wild Bloom, LLC +jewelry + +// jio : 2015-04-02 Affinity Names, Inc. +jio + +// jlc : 2014-12-04 Richemont DNS Inc. +jlc + +// jll : 2015-04-02 Jones Lang LaSalle Incorporated +jll + +// jmp : 2015-03-26 Matrix IP LLC +jmp + +// jnj : 2015-06-18 Johnson & Johnson Services, Inc. +jnj + +// joburg : 2014-03-24 ZA Central Registry NPC trading as ZA Central Registry +joburg + +// jot : 2014-12-18 Amazon EU S.à r.l. +jot + +// joy : 2014-12-18 Amazon EU S.à r.l. +joy + +// jpmorgan : 2015-04-30 JPMorgan Chase & Co. +jpmorgan + +// jprs : 2014-09-18 Japan Registry Services Co., Ltd. +jprs + +// juegos : 2014-03-20 Uniregistry, Corp. +juegos + +// juniper : 2015-07-30 JUNIPER NETWORKS, INC. +juniper + +// kaufen : 2013-11-07 United TLD Holdco Ltd. +kaufen + +// kddi : 2014-09-12 KDDI CORPORATION +kddi + +// kerryhotels : 2015-04-30 Kerry Trading Co. Limited +kerryhotels + +// kerrylogistics : 2015-04-09 Kerry Trading Co. Limited +kerrylogistics + +// kerryproperties : 2015-04-09 Kerry Trading Co. Limited +kerryproperties + +// kfh : 2014-12-04 Kuwait Finance House +kfh + +// kia : 2015-07-09 KIA MOTORS CORPORATION +kia + +// kim : 2013-09-23 Afilias Limited +kim + +// kinder : 2014-11-07 Ferrero Trading Lux S.A. +kinder + +// kindle : 2015-06-25 Amazon EU S.à r.l. +kindle + +// kitchen : 2013-09-20 Just Goodbye, LLC +kitchen + +// kiwi : 2013-09-20 DOT KIWI LIMITED +kiwi + +// koeln : 2014-01-09 NetCologne Gesellschaft für Telekommunikation mbH +koeln + +// komatsu : 2015-01-08 Komatsu Ltd. +komatsu + +// kosher : 2015-08-20 Kosher Marketing Assets LLC +kosher + +// kpmg : 2015-04-23 KPMG International Cooperative (KPMG International Genossenschaft) +kpmg + +// kpn : 2015-01-08 Koninklijke KPN N.V. +kpn + +// krd : 2013-12-05 KRG Department of Information Technology +krd + +// kred : 2013-12-19 KredTLD Pty Ltd +kred + +// kuokgroup : 2015-04-09 Kerry Trading Co. Limited +kuokgroup + +// kyoto : 2014-11-07 Academic Institution: Kyoto Jyoho Gakuen +kyoto + +// lacaixa : 2014-01-09 CAIXA D'ESTALVIS I PENSIONS DE BARCELONA +lacaixa + +// ladbrokes : 2015-08-06 LADBROKES INTERNATIONAL PLC +ladbrokes + +// lamborghini : 2015-06-04 Automobili Lamborghini S.p.A. +lamborghini + +// lamer : 2015-10-01 The Estée Lauder Companies Inc. +lamer + +// lancaster : 2015-02-12 LANCASTER +lancaster + +// lancia : 2015-07-31 Fiat Chrysler Automobiles N.V. +lancia + +// lancome : 2015-07-23 L'Oréal +lancome + +// land : 2013-09-10 Pine Moon, LLC +land + +// landrover : 2014-11-13 Jaguar Land Rover Ltd +landrover + +// lanxess : 2015-07-30 LANXESS Corporation +lanxess + +// lasalle : 2015-04-02 Jones Lang LaSalle Incorporated +lasalle + +// lat : 2014-10-16 ECOM-LAC Federaciòn de Latinoamèrica y el Caribe para Internet y el Comercio Electrònico +lat + +// latino : 2015-07-30 Dish DBS Corporation +latino + +// latrobe : 2014-06-16 La Trobe University +latrobe + +// law : 2015-01-22 Minds + Machines Group Limited +law + +// lawyer : 2014-03-20 +lawyer + +// lds : 2014-03-20 IRI Domain Management, LLC ("Applicant") +lds + +// lease : 2014-03-06 Victor Trail, LLC +lease + +// leclerc : 2014-08-07 A.C.D. LEC Association des Centres Distributeurs Edouard Leclerc +leclerc + +// lefrak : 2015-07-16 LeFrak Organization, Inc. +lefrak + +// legal : 2014-10-16 Blue Falls, LLC +legal + +// lego : 2015-07-16 LEGO Juris A/S +lego + +// lexus : 2015-04-23 TOYOTA MOTOR CORPORATION +lexus + +// lgbt : 2014-05-08 Afilias Limited +lgbt + +// liaison : 2014-10-02 Liaison Technologies, Incorporated +liaison + +// lidl : 2014-09-18 Schwarz Domains und Services GmbH & Co. KG +lidl + +// life : 2014-02-06 Trixy Oaks, LLC +life + +// lifeinsurance : 2015-01-15 American Council of Life Insurers +lifeinsurance + +// lifestyle : 2014-12-11 Lifestyle Domain Holdings, Inc. +lifestyle + +// lighting : 2013-08-27 John McCook, LLC +lighting + +// like : 2014-12-18 Amazon EU S.à r.l. +like + +// lilly : 2015-07-31 Eli Lilly and Company +lilly + +// limited : 2014-03-06 Big Fest, LLC +limited + +// limo : 2013-10-17 Hidden Frostbite, LLC +limo + +// lincoln : 2014-11-13 Ford Motor Company +lincoln + +// linde : 2014-12-04 Linde Aktiengesellschaft +linde + +// link : 2013-11-14 Uniregistry, Corp. +link + +// lipsy : 2015-06-25 Lipsy Ltd +lipsy + +// live : 2014-12-04 +live + +// living : 2015-07-30 Lifestyle Domain Holdings, Inc. +living + +// lixil : 2015-03-19 LIXIL Group Corporation +lixil + +// loan : 2014-11-20 dot Loan Limited +loan + +// loans : 2014-03-20 June Woods, LLC +loans + +// locker : 2015-06-04 Dish DBS Corporation +locker + +// locus : 2015-06-25 Locus Analytics LLC +locus + +// loft : 2015-07-30 Annco, Inc. +loft + +// lol : 2015-01-30 Uniregistry, Corp. +lol + +// london : 2013-11-14 Dot London Domains Limited +london + +// lotte : 2014-11-07 Lotte Holdings Co., Ltd. +lotte + +// lotto : 2014-04-10 Afilias Limited +lotto + +// love : 2014-12-22 Merchant Law Group LLP +love + +// lpl : 2015-07-30 LPL Holdings, Inc. +lpl + +// lplfinancial : 2015-07-30 LPL Holdings, Inc. +lplfinancial + +// ltd : 2014-09-25 Over Corner, LLC +ltd + +// ltda : 2014-04-17 DOMAIN ROBOT SERVICOS DE HOSPEDAGEM NA INTERNET LTDA +ltda + +// lundbeck : 2015-08-06 H. Lundbeck A/S +lundbeck + +// lupin : 2014-11-07 LUPIN LIMITED +lupin + +// luxe : 2014-01-09 Top Level Domain Holdings Limited +luxe + +// luxury : 2013-10-17 Luxury Partners, LLC +luxury + +// macys : 2015-07-31 Macys, Inc. +macys + +// madrid : 2014-05-01 Comunidad de Madrid +madrid + +// maif : 2014-10-02 Mutuelle Assurance Instituteur France (MAIF) +maif + +// maison : 2013-12-05 Victor Frostbite, LLC +maison + +// makeup : 2015-01-15 L'Oréal +makeup + +// man : 2014-12-04 MAN SE +man + +// management : 2013-11-07 John Goodbye, LLC +management + +// mango : 2013-10-24 PUNTO FA S.L. +mango + +// map : 2016-06-09 Charleston Road Registry Inc. +map + +// market : 2014-03-06 +market + +// marketing : 2013-11-07 Fern Pass, LLC +marketing + +// markets : 2014-12-11 IG Group Holdings PLC +markets + +// marriott : 2014-10-09 Marriott Worldwide Corporation +marriott + +// marshalls : 2015-07-16 The TJX Companies, Inc. +marshalls + +// maserati : 2015-07-31 Fiat Chrysler Automobiles N.V. +maserati + +// mattel : 2015-08-06 Mattel Sites, Inc. +mattel + +// mba : 2015-04-02 Lone Hollow, LLC +mba + +// mckinsey : 2015-07-31 McKinsey Holdings, Inc. +mckinsey + +// med : 2015-08-06 Medistry LLC +med + +// media : 2014-03-06 Grand Glen, LLC +media + +// meet : 2014-01-16 +meet + +// melbourne : 2014-05-29 The Crown in right of the State of Victoria, represented by its Department of State Development, Business and Innovation +melbourne + +// meme : 2014-01-30 Charleston Road Registry Inc. +meme + +// memorial : 2014-10-16 Dog Beach, LLC +memorial + +// men : 2015-02-26 Exclusive Registry Limited +men + +// menu : 2013-09-11 Wedding TLD2, LLC +menu + +// meo : 2014-11-07 PT Comunicacoes S.A. +meo + +// merckmsd : 2016-07-14 MSD Registry Holdings, Inc. +merckmsd + +// metlife : 2015-05-07 MetLife Services and Solutions, LLC +metlife + +// miami : 2013-12-19 Top Level Domain Holdings Limited +miami + +// microsoft : 2014-12-18 Microsoft Corporation +microsoft + +// mini : 2014-01-09 Bayerische Motoren Werke Aktiengesellschaft +mini + +// mint : 2015-07-30 Intuit Administrative Services, Inc. +mint + +// mit : 2015-07-02 Massachusetts Institute of Technology +mit + +// mitsubishi : 2015-07-23 Mitsubishi Corporation +mitsubishi + +// mlb : 2015-05-21 MLB Advanced Media DH, LLC +mlb + +// mls : 2015-04-23 The Canadian Real Estate Association +mls + +// mma : 2014-11-07 MMA IARD +mma + +// mobile : 2016-06-02 Dish DBS Corporation +mobile + +// mobily : 2014-12-18 GreenTech Consultancy Company W.L.L. +mobily + +// moda : 2013-11-07 United TLD Holdco Ltd. +moda + +// moe : 2013-11-13 Interlink Co., Ltd. +moe + +// moi : 2014-12-18 Amazon EU S.à r.l. +moi + +// mom : 2015-04-16 Uniregistry, Corp. +mom + +// monash : 2013-09-30 Monash University +monash + +// money : 2014-10-16 Outer McCook, LLC +money + +// monster : 2015-09-11 Monster Worldwide, Inc. +monster + +// mopar : 2015-07-30 FCA US LLC. +mopar + +// mormon : 2013-12-05 IRI Domain Management, LLC ("Applicant") +mormon + +// mortgage : 2014-03-20 +mortgage + +// moscow : 2013-12-19 Foundation for Assistance for Internet Technologies and Infrastructure Development (FAITID) +moscow + +// moto : 2015-06-04 +moto + +// motorcycles : 2014-01-09 DERMotorcycles, LLC +motorcycles + +// mov : 2014-01-30 Charleston Road Registry Inc. +mov + +// movie : 2015-02-05 New Frostbite, LLC +movie + +// movistar : 2014-10-16 Telefónica S.A. +movistar + +// msd : 2015-07-23 MSD Registry Holdings, Inc. +msd + +// mtn : 2014-12-04 MTN Dubai Limited +mtn + +// mtpc : 2014-11-20 Mitsubishi Tanabe Pharma Corporation +mtpc + +// mtr : 2015-03-12 MTR Corporation Limited +mtr + +// mutual : 2015-04-02 Northwestern Mutual MU TLD Registry, LLC +mutual + +// nab : 2015-08-20 National Australia Bank Limited +nab + +// nadex : 2014-12-11 IG Group Holdings PLC +nadex + +// nagoya : 2013-10-24 GMO Registry, Inc. +nagoya + +// nationwide : 2015-07-23 Nationwide Mutual Insurance Company +nationwide + +// natura : 2015-03-12 NATURA COSMÉTICOS S.A. +natura + +// navy : 2014-03-06 United TLD Holdco Ltd. +navy + +// nba : 2015-07-31 NBA REGISTRY, LLC +nba + +// nec : 2015-01-08 NEC Corporation +nec + +// netbank : 2014-06-26 COMMONWEALTH BANK OF AUSTRALIA +netbank + +// netflix : 2015-06-18 Netflix, Inc. +netflix + +// network : 2013-11-14 Trixy Manor, LLC +network + +// neustar : 2013-12-05 NeuStar, Inc. +neustar + +// new : 2014-01-30 Charleston Road Registry Inc. +new + +// newholland : 2015-09-03 CNH Industrial N.V. +newholland + +// news : 2014-12-18 +news + +// next : 2015-06-18 Next plc +next + +// nextdirect : 2015-06-18 Next plc +nextdirect + +// nexus : 2014-07-24 Charleston Road Registry Inc. +nexus + +// nfl : 2015-07-23 NFL Reg Ops LLC +nfl + +// ngo : 2014-03-06 Public Interest Registry +ngo + +// nhk : 2014-02-13 Japan Broadcasting Corporation (NHK) +nhk + +// nico : 2014-12-04 DWANGO Co., Ltd. +nico + +// nike : 2015-07-23 NIKE, Inc. +nike + +// nikon : 2015-05-21 NIKON CORPORATION +nikon + +// ninja : 2013-11-07 United TLD Holdco Ltd. +ninja + +// nissan : 2014-03-27 NISSAN MOTOR CO., LTD. +nissan + +// nissay : 2015-10-29 Nippon Life Insurance Company +nissay + +// nokia : 2015-01-08 Nokia Corporation +nokia + +// northwesternmutual : 2015-06-18 Northwestern Mutual Registry, LLC +northwesternmutual + +// norton : 2014-12-04 Symantec Corporation +norton + +// now : 2015-06-25 Amazon EU S.à r.l. +now + +// nowruz : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti. +nowruz + +// nowtv : 2015-05-14 Starbucks (HK) Limited +nowtv + +// nra : 2014-05-22 NRA Holdings Company, INC. +nra + +// nrw : 2013-11-21 Minds + Machines GmbH +nrw + +// ntt : 2014-10-31 NIPPON TELEGRAPH AND TELEPHONE CORPORATION +ntt + +// nyc : 2014-01-23 The City of New York by and through the New York City Department of Information Technology & Telecommunications +nyc + +// obi : 2014-09-25 OBI Group Holding SE & Co. KGaA +obi + +// observer : 2015-04-30 +observer + +// off : 2015-07-23 Johnson Shareholdings, Inc. +off + +// office : 2015-03-12 Microsoft Corporation +office + +// okinawa : 2013-12-05 BusinessRalliart Inc. +okinawa + +// olayan : 2015-05-14 Crescent Holding GmbH +olayan + +// olayangroup : 2015-05-14 Crescent Holding GmbH +olayangroup + +// oldnavy : 2015-07-31 The Gap, Inc. +oldnavy + +// ollo : 2015-06-04 Dish DBS Corporation +ollo + +// omega : 2015-01-08 The Swatch Group Ltd +omega + +// one : 2014-11-07 One.com A/S +one + +// ong : 2014-03-06 Public Interest Registry +ong + +// onl : 2013-09-16 I-Registry Ltd. +onl + +// online : 2015-01-15 DotOnline Inc. +online + +// onyourside : 2015-07-23 Nationwide Mutual Insurance Company +onyourside + +// ooo : 2014-01-09 INFIBEAM INCORPORATION LIMITED +ooo + +// open : 2015-07-31 American Express Travel Related Services Company, Inc. +open + +// oracle : 2014-06-19 Oracle Corporation +oracle + +// orange : 2015-03-12 Orange Brand Services Limited +orange + +// organic : 2014-03-27 Afilias Limited +organic + +// origins : 2015-10-01 The Estée Lauder Companies Inc. +origins + +// osaka : 2014-09-04 Interlink Co., Ltd. +osaka + +// otsuka : 2013-10-11 Otsuka Holdings Co., Ltd. +otsuka + +// ott : 2015-06-04 Dish DBS Corporation +ott + +// ovh : 2014-01-16 OVH SAS +ovh + +// page : 2014-12-04 Charleston Road Registry Inc. +page + +// panasonic : 2015-07-30 Panasonic Corporation +panasonic + +// panerai : 2014-11-07 Richemont DNS Inc. +panerai + +// paris : 2014-01-30 City of Paris +paris + +// pars : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti. +pars + +// partners : 2013-12-05 Magic Glen, LLC +partners + +// parts : 2013-12-05 Sea Goodbye, LLC +parts + +// party : 2014-09-11 Blue Sky Registry Limited +party + +// passagens : 2015-03-05 Travel Reservations SRL +passagens + +// pay : 2015-08-27 Amazon EU S.à r.l. +pay + +// pccw : 2015-05-14 PCCW Enterprises Limited +pccw + +// pet : 2015-05-07 Afilias plc +pet + +// pfizer : 2015-09-11 Pfizer Inc. +pfizer + +// pharmacy : 2014-06-19 National Association of Boards of Pharmacy +pharmacy + +// phd : 2016-07-28 Charleston Road Registry Inc. +phd + +// philips : 2014-11-07 Koninklijke Philips N.V. +philips + +// phone : 2016-06-02 Dish DBS Corporation +phone + +// photo : 2013-11-14 Uniregistry, Corp. +photo + +// photography : 2013-09-20 Sugar Glen, LLC +photography + +// photos : 2013-10-17 Sea Corner, LLC +photos + +// physio : 2014-05-01 PhysBiz Pty Ltd +physio + +// piaget : 2014-10-16 Richemont DNS Inc. +piaget + +// pics : 2013-11-14 Uniregistry, Corp. +pics + +// pictet : 2014-06-26 Pictet Europe S.A. +pictet + +// pictures : 2014-03-06 Foggy Sky, LLC +pictures + +// pid : 2015-01-08 Top Level Spectrum, Inc. +pid + +// pin : 2014-12-18 Amazon EU S.à r.l. +pin + +// ping : 2015-06-11 Ping Registry Provider, Inc. +ping + +// pink : 2013-10-01 Afilias Limited +pink + +// pioneer : 2015-07-16 Pioneer Corporation +pioneer + +// pizza : 2014-06-26 Foggy Moon, LLC +pizza + +// place : 2014-04-24 Snow Galley, LLC +place + +// play : 2015-03-05 Charleston Road Registry Inc. +play + +// playstation : 2015-07-02 Sony Computer Entertainment Inc. +playstation + +// plumbing : 2013-09-10 Spring Tigers, LLC +plumbing + +// plus : 2015-02-05 Sugar Mill, LLC +plus + +// pnc : 2015-07-02 PNC Domain Co., LLC +pnc + +// pohl : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG +pohl + +// poker : 2014-07-03 Afilias Domains No. 5 Limited +poker + +// politie : 2015-08-20 Politie Nederland +politie + +// porn : 2014-10-16 ICM Registry PN LLC +porn + +// pramerica : 2015-07-30 Prudential Financial, Inc. +pramerica + +// praxi : 2013-12-05 Praxi S.p.A. +praxi + +// press : 2014-04-03 DotPress Inc. +press + +// prime : 2015-06-25 Amazon EU S.à r.l. +prime + +// prod : 2014-01-23 Charleston Road Registry Inc. +prod + +// productions : 2013-12-05 Magic Birch, LLC +productions + +// prof : 2014-07-24 Charleston Road Registry Inc. +prof + +// progressive : 2015-07-23 Progressive Casualty Insurance Company +progressive + +// promo : 2014-12-18 +promo + +// properties : 2013-12-05 Big Pass, LLC +properties + +// property : 2014-05-22 Uniregistry, Corp. +property + +// protection : 2015-04-23 +protection + +// pru : 2015-07-30 Prudential Financial, Inc. +pru + +// prudential : 2015-07-30 Prudential Financial, Inc. +prudential + +// pub : 2013-12-12 United TLD Holdco Ltd. +pub + +// pwc : 2015-10-29 PricewaterhouseCoopers LLP +pwc + +// qpon : 2013-11-14 dotCOOL, Inc. +qpon + +// quebec : 2013-12-19 PointQuébec Inc +quebec + +// quest : 2015-03-26 Quest ION Limited +quest + +// qvc : 2015-07-30 QVC, Inc. +qvc + +// racing : 2014-12-04 Premier Registry Limited +racing + +// radio : 2016-07-21 European Broadcasting Union (EBU) +radio + +// raid : 2015-07-23 Johnson Shareholdings, Inc. +raid + +// read : 2014-12-18 Amazon EU S.à r.l. +read + +// realestate : 2015-09-11 dotRealEstate LLC +realestate + +// realtor : 2014-05-29 Real Estate Domains LLC +realtor + +// realty : 2015-03-19 Fegistry, LLC +realty + +// recipes : 2013-10-17 Grand Island, LLC +recipes + +// red : 2013-11-07 Afilias Limited +red + +// redstone : 2014-10-31 Redstone Haute Couture Co., Ltd. +redstone + +// redumbrella : 2015-03-26 Travelers TLD, LLC +redumbrella + +// rehab : 2014-03-06 United TLD Holdco Ltd. +rehab + +// reise : 2014-03-13 +reise + +// reisen : 2014-03-06 New Cypress, LLC +reisen + +// reit : 2014-09-04 National Association of Real Estate Investment Trusts, Inc. +reit + +// reliance : 2015-04-02 Reliance Industries Limited +reliance + +// ren : 2013-12-12 Beijing Qianxiang Wangjing Technology Development Co., Ltd. +ren + +// rent : 2014-12-04 DERRent, LLC +rent + +// rentals : 2013-12-05 Big Hollow,LLC +rentals + +// repair : 2013-11-07 Lone Sunset, LLC +repair + +// report : 2013-12-05 Binky Glen, LLC +report + +// republican : 2014-03-20 United TLD Holdco Ltd. +republican + +// rest : 2013-12-19 Punto 2012 Sociedad Anonima Promotora de Inversion de Capital Variable +rest + +// restaurant : 2014-07-03 Snow Avenue, LLC +restaurant + +// review : 2014-11-20 dot Review Limited +review + +// reviews : 2013-09-13 +reviews + +// rexroth : 2015-06-18 Robert Bosch GMBH +rexroth + +// rich : 2013-11-21 I-Registry Ltd. +rich + +// richardli : 2015-05-14 Pacific Century Asset Management (HK) Limited +richardli + +// ricoh : 2014-11-20 Ricoh Company, Ltd. +ricoh + +// rightathome : 2015-07-23 Johnson Shareholdings, Inc. +rightathome + +// ril : 2015-04-02 Reliance Industries Limited +ril + +// rio : 2014-02-27 Empresa Municipal de Informática SA - IPLANRIO +rio + +// rip : 2014-07-10 United TLD Holdco Ltd. +rip + +// rmit : 2015-11-19 Royal Melbourne Institute of Technology +rmit + +// rocher : 2014-12-18 Ferrero Trading Lux S.A. +rocher + +// rocks : 2013-11-14 +rocks + +// rodeo : 2013-12-19 Top Level Domain Holdings Limited +rodeo + +// rogers : 2015-08-06 Rogers Communications Partnership +rogers + +// room : 2014-12-18 Amazon EU S.à r.l. +room + +// rsvp : 2014-05-08 Charleston Road Registry Inc. +rsvp + +// rugby : 2016-12-15 World Rugby Strategic Developments Limited +rugby + +// ruhr : 2013-10-02 regiodot GmbH & Co. KG +ruhr + +// run : 2015-03-19 Snow Park, LLC +run + +// rwe : 2015-04-02 RWE AG +rwe + +// ryukyu : 2014-01-09 BusinessRalliart Inc. +ryukyu + +// saarland : 2013-12-12 dotSaarland GmbH +saarland + +// safe : 2014-12-18 Amazon EU S.à r.l. +safe + +// safety : 2015-01-08 Safety Registry Services, LLC. +safety + +// sakura : 2014-12-18 SAKURA Internet Inc. +sakura + +// sale : 2014-10-16 +sale + +// salon : 2014-12-11 Outer Orchard, LLC +salon + +// samsclub : 2015-07-31 Wal-Mart Stores, Inc. +samsclub + +// samsung : 2014-04-03 SAMSUNG SDS CO., LTD +samsung + +// sandvik : 2014-11-13 Sandvik AB +sandvik + +// sandvikcoromant : 2014-11-07 Sandvik AB +sandvikcoromant + +// sanofi : 2014-10-09 Sanofi +sanofi + +// sap : 2014-03-27 SAP AG +sap + +// sapo : 2014-11-07 PT Comunicacoes S.A. +sapo + +// sarl : 2014-07-03 Delta Orchard, LLC +sarl + +// sas : 2015-04-02 Research IP LLC +sas + +// save : 2015-06-25 Amazon EU S.à r.l. +save + +// saxo : 2014-10-31 Saxo Bank A/S +saxo + +// sbi : 2015-03-12 STATE BANK OF INDIA +sbi + +// sbs : 2014-11-07 SPECIAL BROADCASTING SERVICE CORPORATION +sbs + +// sca : 2014-03-13 SVENSKA CELLULOSA AKTIEBOLAGET SCA (publ) +sca + +// scb : 2014-02-20 The Siam Commercial Bank Public Company Limited ("SCB") +scb + +// schaeffler : 2015-08-06 Schaeffler Technologies AG & Co. KG +schaeffler + +// schmidt : 2014-04-03 SALM S.A.S. +schmidt + +// scholarships : 2014-04-24 Scholarships.com, LLC +scholarships + +// school : 2014-12-18 Little Galley, LLC +school + +// schule : 2014-03-06 Outer Moon, LLC +schule + +// schwarz : 2014-09-18 Schwarz Domains und Services GmbH & Co. KG +schwarz + +// science : 2014-09-11 dot Science Limited +science + +// scjohnson : 2015-07-23 Johnson Shareholdings, Inc. +scjohnson + +// scor : 2014-10-31 SCOR SE +scor + +// scot : 2014-01-23 Dot Scot Registry Limited +scot + +// search : 2016-06-09 Charleston Road Registry Inc. +search + +// seat : 2014-05-22 SEAT, S.A. (Sociedad Unipersonal) +seat + +// secure : 2015-08-27 Amazon EU S.à r.l. +secure + +// security : 2015-05-14 +security + +// seek : 2014-12-04 Seek Limited +seek + +// select : 2015-10-08 iSelect Ltd +select + +// sener : 2014-10-24 Sener Ingeniería y Sistemas, S.A. +sener + +// services : 2014-02-27 Fox Castle, LLC +services + +// ses : 2015-07-23 SES +ses + +// seven : 2015-08-06 Seven West Media Ltd +seven + +// sew : 2014-07-17 SEW-EURODRIVE GmbH & Co KG +sew + +// sex : 2014-11-13 ICM Registry SX LLC +sex + +// sexy : 2013-09-11 Uniregistry, Corp. +sexy + +// sfr : 2015-08-13 Societe Francaise du Radiotelephone - SFR +sfr + +// shangrila : 2015-09-03 Shangri‐La International Hotel Management Limited +shangrila + +// sharp : 2014-05-01 Sharp Corporation +sharp + +// shaw : 2015-04-23 Shaw Cablesystems G.P. +shaw + +// shell : 2015-07-30 Shell Information Technology International Inc +shell + +// shia : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti. +shia + +// shiksha : 2013-11-14 Afilias Limited +shiksha + +// shoes : 2013-10-02 Binky Galley, LLC +shoes + +// shop : 2016-04-08 GMO Registry, Inc. +shop + +// shopping : 2016-03-31 +shopping + +// shouji : 2015-01-08 QIHOO 360 TECHNOLOGY CO. LTD. +shouji + +// show : 2015-03-05 Snow Beach, LLC +show + +// showtime : 2015-08-06 CBS Domains Inc. +showtime + +// shriram : 2014-01-23 Shriram Capital Ltd. +shriram + +// silk : 2015-06-25 Amazon EU S.à r.l. +silk + +// sina : 2015-03-12 Sina Corporation +sina + +// singles : 2013-08-27 Fern Madison, LLC +singles + +// site : 2015-01-15 DotSite Inc. +site + +// ski : 2015-04-09 STARTING DOT LIMITED +ski + +// skin : 2015-01-15 L'Oréal +skin + +// sky : 2014-06-19 Sky IP International Ltd, a company incorporated in England and Wales, operating via its registered Swiss branch +sky + +// skype : 2014-12-18 Microsoft Corporation +skype + +// sling : 2015-07-30 Hughes Satellite Systems Corporation +sling + +// smart : 2015-07-09 Smart Communications, Inc. (SMART) +smart + +// smile : 2014-12-18 Amazon EU S.à r.l. +smile + +// sncf : 2015-02-19 Société Nationale des Chemins de fer Francais S N C F +sncf + +// soccer : 2015-03-26 Foggy Shadow, LLC +soccer + +// social : 2013-11-07 United TLD Holdco Ltd. +social + +// softbank : 2015-07-02 SoftBank Corp. +softbank + +// software : 2014-03-20 +software + +// sohu : 2013-12-19 Sohu.com Limited +sohu + +// solar : 2013-11-07 Ruby Town, LLC +solar + +// solutions : 2013-11-07 Silver Cover, LLC +solutions + +// song : 2015-02-26 Amazon EU S.à r.l. +song + +// sony : 2015-01-08 Sony Corporation +sony + +// soy : 2014-01-23 Charleston Road Registry Inc. +soy + +// space : 2014-04-03 DotSpace Inc. +space + +// spiegel : 2014-02-05 SPIEGEL-Verlag Rudolf Augstein GmbH & Co. KG +spiegel + +// spot : 2015-02-26 Amazon EU S.à r.l. +spot + +// spreadbetting : 2014-12-11 IG Group Holdings PLC +spreadbetting + +// srl : 2015-05-07 mySRL GmbH +srl + +// srt : 2015-07-30 FCA US LLC. +srt + +// stada : 2014-11-13 STADA Arzneimittel AG +stada + +// staples : 2015-07-30 Staples, Inc. +staples + +// star : 2015-01-08 Star India Private Limited +star + +// starhub : 2015-02-05 StarHub Ltd +starhub + +// statebank : 2015-03-12 STATE BANK OF INDIA +statebank + +// statefarm : 2015-07-30 State Farm Mutual Automobile Insurance Company +statefarm + +// statoil : 2014-12-04 Statoil ASA +statoil + +// stc : 2014-10-09 Saudi Telecom Company +stc + +// stcgroup : 2014-10-09 Saudi Telecom Company +stcgroup + +// stockholm : 2014-12-18 Stockholms kommun +stockholm + +// storage : 2014-12-22 Self Storage Company LLC +storage + +// store : 2015-04-09 DotStore Inc. +store + +// stream : 2016-01-08 dot Stream Limited +stream + +// studio : 2015-02-11 +studio + +// study : 2014-12-11 OPEN UNIVERSITIES AUSTRALIA PTY LTD +study + +// style : 2014-12-04 Binky Moon, LLC +style + +// sucks : 2014-12-22 Vox Populi Registry Inc. +sucks + +// supplies : 2013-12-19 Atomic Fields, LLC +supplies + +// supply : 2013-12-19 Half Falls, LLC +supply + +// support : 2013-10-24 Grand Orchard, LLC +support + +// surf : 2014-01-09 Top Level Domain Holdings Limited +surf + +// surgery : 2014-03-20 Tin Avenue, LLC +surgery + +// suzuki : 2014-02-20 SUZUKI MOTOR CORPORATION +suzuki + +// swatch : 2015-01-08 The Swatch Group Ltd +swatch + +// swiftcover : 2015-07-23 Swiftcover Insurance Services Limited +swiftcover + +// swiss : 2014-10-16 Swiss Confederation +swiss + +// sydney : 2014-09-18 State of New South Wales, Department of Premier and Cabinet +sydney + +// symantec : 2014-12-04 Symantec Corporation +symantec + +// systems : 2013-11-07 Dash Cypress, LLC +systems + +// tab : 2014-12-04 Tabcorp Holdings Limited +tab + +// taipei : 2014-07-10 Taipei City Government +taipei + +// talk : 2015-04-09 Amazon EU S.à r.l. +talk + +// taobao : 2015-01-15 Alibaba Group Holding Limited +taobao + +// target : 2015-07-31 Target Domain Holdings, LLC +target + +// tatamotors : 2015-03-12 Tata Motors Ltd +tatamotors + +// tatar : 2014-04-24 Limited Liability Company "Coordination Center of Regional Domain of Tatarstan Republic" +tatar + +// tattoo : 2013-08-30 Uniregistry, Corp. +tattoo + +// tax : 2014-03-20 Storm Orchard, LLC +tax + +// taxi : 2015-03-19 Pine Falls, LLC +taxi + +// tci : 2014-09-12 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti. +tci + +// tdk : 2015-06-11 TDK Corporation +tdk + +// team : 2015-03-05 Atomic Lake, LLC +team + +// tech : 2015-01-30 Dot Tech LLC +tech + +// technology : 2013-09-13 Auburn Falls +technology + +// telecity : 2015-02-19 TelecityGroup International Limited +telecity + +// telefonica : 2014-10-16 Telefónica S.A. +telefonica + +// temasek : 2014-08-07 Temasek Holdings (Private) Limited +temasek + +// tennis : 2014-12-04 Cotton Bloom, LLC +tennis + +// teva : 2015-07-02 Teva Pharmaceutical Industries Limited +teva + +// thd : 2015-04-02 Homer TLC, Inc. +thd + +// theater : 2015-03-19 Blue Tigers, LLC +theater + +// theatre : 2015-05-07 +theatre + +// tiaa : 2015-07-23 Teachers Insurance and Annuity Association of America +tiaa + +// tickets : 2015-02-05 Accent Media Limited +tickets + +// tienda : 2013-11-14 Victor Manor, LLC +tienda + +// tiffany : 2015-01-30 Tiffany and Company +tiffany + +// tips : 2013-09-20 Corn Willow, LLC +tips + +// tires : 2014-11-07 Dog Edge, LLC +tires + +// tirol : 2014-04-24 punkt Tirol GmbH +tirol + +// tjmaxx : 2015-07-16 The TJX Companies, Inc. +tjmaxx + +// tjx : 2015-07-16 The TJX Companies, Inc. +tjx + +// tkmaxx : 2015-07-16 The TJX Companies, Inc. +tkmaxx + +// tmall : 2015-01-15 Alibaba Group Holding Limited +tmall + +// today : 2013-09-20 Pearl Woods, LLC +today + +// tokyo : 2013-11-13 GMO Registry, Inc. +tokyo + +// tools : 2013-11-21 Pioneer North, LLC +tools + +// top : 2014-03-20 Jiangsu Bangning Science & Technology Co.,Ltd. +top + +// toray : 2014-12-18 Toray Industries, Inc. +toray + +// toshiba : 2014-04-10 TOSHIBA Corporation +toshiba + +// total : 2015-08-06 Total SA +total + +// tours : 2015-01-22 Sugar Station, LLC +tours + +// town : 2014-03-06 Koko Moon, LLC +town + +// toyota : 2015-04-23 TOYOTA MOTOR CORPORATION +toyota + +// toys : 2014-03-06 Pioneer Orchard, LLC +toys + +// trade : 2014-01-23 Elite Registry Limited +trade + +// trading : 2014-12-11 IG Group Holdings PLC +trading + +// training : 2013-11-07 Wild Willow, LLC +training + +// travelchannel : 2015-07-02 Lifestyle Domain Holdings, Inc. +travelchannel + +// travelers : 2015-03-26 Travelers TLD, LLC +travelers + +// travelersinsurance : 2015-03-26 Travelers TLD, LLC +travelersinsurance + +// trust : 2014-10-16 +trust + +// trv : 2015-03-26 Travelers TLD, LLC +trv + +// tube : 2015-06-11 Latin American Telecom LLC +tube + +// tui : 2014-07-03 TUI AG +tui + +// tunes : 2015-02-26 Amazon EU S.à r.l. +tunes + +// tushu : 2014-12-18 Amazon EU S.à r.l. +tushu + +// tvs : 2015-02-19 T V SUNDRAM IYENGAR & SONS LIMITED +tvs + +// ubank : 2015-08-20 National Australia Bank Limited +ubank + +// ubs : 2014-12-11 UBS AG +ubs + +// uconnect : 2015-07-30 FCA US LLC. +uconnect + +// unicom : 2015-10-15 China United Network Communications Corporation Limited +unicom + +// university : 2014-03-06 Little Station, LLC +university + +// uno : 2013-09-11 Dot Latin LLC +uno + +// uol : 2014-05-01 UBN INTERNET LTDA. +uol + +// ups : 2015-06-25 UPS Market Driver, Inc. +ups + +// vacations : 2013-12-05 Atomic Tigers, LLC +vacations + +// vana : 2014-12-11 Lifestyle Domain Holdings, Inc. +vana + +// vanguard : 2015-09-03 The Vanguard Group, Inc. +vanguard + +// vegas : 2014-01-16 Dot Vegas, Inc. +vegas + +// ventures : 2013-08-27 Binky Lake, LLC +ventures + +// verisign : 2015-08-13 VeriSign, Inc. +verisign + +// versicherung : 2014-03-20 +versicherung + +// vet : 2014-03-06 +vet + +// viajes : 2013-10-17 Black Madison, LLC +viajes + +// video : 2014-10-16 +video + +// vig : 2015-05-14 VIENNA INSURANCE GROUP AG Wiener Versicherung Gruppe +vig + +// viking : 2015-04-02 Viking River Cruises (Bermuda) Ltd. +viking + +// villas : 2013-12-05 New Sky, LLC +villas + +// vin : 2015-06-18 Holly Shadow, LLC +vin + +// vip : 2015-01-22 Minds + Machines Group Limited +vip + +// virgin : 2014-09-25 Virgin Enterprises Limited +virgin + +// visa : 2015-07-30 Visa Worldwide Pte. Limited +visa + +// vision : 2013-12-05 Koko Station, LLC +vision + +// vista : 2014-09-18 Vistaprint Limited +vista + +// vistaprint : 2014-09-18 Vistaprint Limited +vistaprint + +// viva : 2014-11-07 Saudi Telecom Company +viva + +// vivo : 2015-07-31 Telefonica Brasil S.A. +vivo + +// vlaanderen : 2014-02-06 DNS.be vzw +vlaanderen + +// vodka : 2013-12-19 Top Level Domain Holdings Limited +vodka + +// volkswagen : 2015-05-14 Volkswagen Group of America Inc. +volkswagen + +// volvo : 2015-11-12 Volvo Holding Sverige Aktiebolag +volvo + +// vote : 2013-11-21 Monolith Registry LLC +vote + +// voting : 2013-11-13 Valuetainment Corp. +voting + +// voto : 2013-11-21 Monolith Registry LLC +voto + +// voyage : 2013-08-27 Ruby House, LLC +voyage + +// vuelos : 2015-03-05 Travel Reservations SRL +vuelos + +// wales : 2014-05-08 Nominet UK +wales + +// walmart : 2015-07-31 Wal-Mart Stores, Inc. +walmart + +// walter : 2014-11-13 Sandvik AB +walter + +// wang : 2013-10-24 Zodiac Leo Limited +wang + +// wanggou : 2014-12-18 Amazon EU S.à r.l. +wanggou + +// warman : 2015-06-18 Weir Group IP Limited +warman + +// watch : 2013-11-14 Sand Shadow, LLC +watch + +// watches : 2014-12-22 Richemont DNS Inc. +watches + +// weather : 2015-01-08 The Weather Channel, LLC +weather + +// weatherchannel : 2015-03-12 The Weather Channel, LLC +weatherchannel + +// webcam : 2014-01-23 dot Webcam Limited +webcam + +// weber : 2015-06-04 Saint-Gobain Weber SA +weber + +// website : 2014-04-03 DotWebsite Inc. +website + +// wed : 2013-10-01 Atgron, Inc. +wed + +// wedding : 2014-04-24 Top Level Domain Holdings Limited +wedding + +// weibo : 2015-03-05 Sina Corporation +weibo + +// weir : 2015-01-29 Weir Group IP Limited +weir + +// whoswho : 2014-02-20 Who's Who Registry +whoswho + +// wien : 2013-10-28 punkt.wien GmbH +wien + +// wiki : 2013-11-07 Top Level Design, LLC +wiki + +// williamhill : 2014-03-13 William Hill Organization Limited +williamhill + +// win : 2014-11-20 First Registry Limited +win + +// windows : 2014-12-18 Microsoft Corporation +windows + +// wine : 2015-06-18 June Station, LLC +wine + +// winners : 2015-07-16 The TJX Companies, Inc. +winners + +// wme : 2014-02-13 William Morris Endeavor Entertainment, LLC +wme + +// wolterskluwer : 2015-08-06 Wolters Kluwer N.V. +wolterskluwer + +// woodside : 2015-07-09 Woodside Petroleum Limited +woodside + +// work : 2013-12-19 Top Level Domain Holdings Limited +work + +// works : 2013-11-14 Little Dynamite, LLC +works + +// world : 2014-06-12 Bitter Fields, LLC +world + +// wow : 2015-10-08 Amazon EU S.à r.l. +wow + +// wtc : 2013-12-19 World Trade Centers Association, Inc. +wtc + +// wtf : 2014-03-06 Hidden Way, LLC +wtf + +// xbox : 2014-12-18 Microsoft Corporation +xbox + +// xerox : 2014-10-24 Xerox DNHC LLC +xerox + +// xfinity : 2015-07-09 Comcast IP Holdings I, LLC +xfinity + +// xihuan : 2015-01-08 QIHOO 360 TECHNOLOGY CO. LTD. +xihuan + +// xin : 2014-12-11 Elegant Leader Limited +xin + +// xn--11b4c3d : 2015-01-15 VeriSign Sarl +xn--11b4c3d + +// xn--1ck2e1b : 2015-02-26 Amazon EU S.à r.l. +xn--1ck2e1b + +// xn--1qqw23a : 2014-01-09 Guangzhou YU Wei Information Technology Co., Ltd. +xn--1qqw23a + +// xn--30rr7y : 2014-06-12 Excellent First Limited +xn--30rr7y + +// xn--3bst00m : 2013-09-13 Eagle Horizon Limited +xn--3bst00m + +// xn--3ds443g : 2013-09-08 TLD REGISTRY LIMITED +xn--3ds443g + +// xn--3oq18vl8pn36a : 2015-07-02 Volkswagen (China) Investment Co., Ltd. +xn--3oq18vl8pn36a + +// xn--3pxu8k : 2015-01-15 VeriSign Sarl +xn--3pxu8k + +// xn--42c2d9a : 2015-01-15 VeriSign Sarl +xn--42c2d9a + +// xn--45q11c : 2013-11-21 Zodiac Scorpio Limited +xn--45q11c + +// xn--4gbrim : 2013-10-04 Suhub Electronic Establishment +xn--4gbrim + +// xn--55qw42g : 2013-11-08 China Organizational Name Administration Center +xn--55qw42g + +// xn--55qx5d : 2013-11-14 Computer Network Information Center of Chinese Academy of Sciences （China Internet Network Information Center） +xn--55qx5d + +// xn--5su34j936bgsg : 2015-09-03 Shangri‐La International Hotel Management Limited +xn--5su34j936bgsg + +// xn--5tzm5g : 2014-12-22 Global Website TLD Asia Limited +xn--5tzm5g + +// xn--6frz82g : 2013-09-23 Afilias Limited +xn--6frz82g + +// xn--6qq986b3xl : 2013-09-13 Tycoon Treasure Limited +xn--6qq986b3xl + +// xn--80adxhks : 2013-12-19 Foundation for Assistance for Internet Technologies and Infrastructure Development (FAITID) +xn--80adxhks + +// xn--80aqecdr1a : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication) +xn--80aqecdr1a + +// xn--80asehdb : 2013-07-14 CORE Association +xn--80asehdb + +// xn--80aswg : 2013-07-14 CORE Association +xn--80aswg + +// xn--8y0a063a : 2015-03-26 China United Network Communications Corporation Limited +xn--8y0a063a + +// xn--9dbq2a : 2015-01-15 VeriSign Sarl +xn--9dbq2a + +// xn--9et52u : 2014-06-12 RISE VICTORY LIMITED +xn--9et52u + +// xn--9krt00a : 2015-03-12 Sina Corporation +xn--9krt00a + +// xn--b4w605ferd : 2014-08-07 Temasek Holdings (Private) Limited +xn--b4w605ferd + +// xn--bck1b9a5dre4c : 2015-02-26 Amazon EU S.à r.l. +xn--bck1b9a5dre4c + +// xn--c1avg : 2013-11-14 Public Interest Registry +xn--c1avg + +// xn--c2br7g : 2015-01-15 VeriSign Sarl +xn--c2br7g + +// xn--cck2b3b : 2015-02-26 Amazon EU S.à r.l. +xn--cck2b3b + +// xn--cg4bki : 2013-09-27 SAMSUNG SDS CO., LTD +xn--cg4bki + +// xn--czr694b : 2014-01-16 Dot Trademark TLD Holding Company Limited +xn--czr694b + +// xn--czrs0t : 2013-12-19 Wild Island, LLC +xn--czrs0t + +// xn--czru2d : 2013-11-21 Zodiac Capricorn Limited +xn--czru2d + +// xn--d1acj3b : 2013-11-20 The Foundation for Network Initiatives “The Smart Internet” +xn--d1acj3b + +// xn--eckvdtc9d : 2014-12-18 Amazon EU S.à r.l. +xn--eckvdtc9d + +// xn--efvy88h : 2014-08-22 Xinhua News Agency Guangdong Branch 新华通讯社广东分社 +xn--efvy88h + +// xn--estv75g : 2015-02-19 Industrial and Commercial Bank of China Limited +xn--estv75g + +// xn--fct429k : 2015-04-09 Amazon EU S.à r.l. +xn--fct429k + +// xn--fhbei : 2015-01-15 VeriSign Sarl +xn--fhbei + +// xn--fiq228c5hs : 2013-09-08 TLD REGISTRY LIMITED +xn--fiq228c5hs + +// xn--fiq64b : 2013-10-14 CITIC Group Corporation +xn--fiq64b + +// xn--fjq720a : 2014-05-22 Will Bloom, LLC +xn--fjq720a + +// xn--flw351e : 2014-07-31 Charleston Road Registry Inc. +xn--flw351e + +// xn--fzys8d69uvgm : 2015-05-14 PCCW Enterprises Limited +xn--fzys8d69uvgm + +// xn--g2xx48c : 2015-01-30 Minds + Machines Group Limited +xn--g2xx48c + +// xn--gckr3f0f : 2015-02-26 Amazon EU S.à r.l. +xn--gckr3f0f + +// xn--gk3at1e : 2015-10-08 Amazon EU S.à r.l. +xn--gk3at1e + +// xn--hxt814e : 2014-05-15 Zodiac Libra Limited +xn--hxt814e + +// xn--i1b6b1a6a2e : 2013-11-14 Public Interest Registry +xn--i1b6b1a6a2e + +// xn--imr513n : 2014-12-11 Dot Trademark TLD Holding Company Limited +xn--imr513n + +// xn--io0a7i : 2013-11-14 Computer Network Information Center of Chinese Academy of Sciences （China Internet Network Information Center） +xn--io0a7i + +// xn--j1aef : 2015-01-15 VeriSign Sarl +xn--j1aef + +// xn--jlq61u9w7b : 2015-01-08 Nokia Corporation +xn--jlq61u9w7b + +// xn--jvr189m : 2015-02-26 Amazon EU S.à r.l. +xn--jvr189m + +// xn--kcrx77d1x4a : 2014-11-07 Koninklijke Philips N.V. +xn--kcrx77d1x4a + +// xn--kpu716f : 2014-12-22 Richemont DNS Inc. +xn--kpu716f + +// xn--kput3i : 2014-02-13 Beijing RITT-Net Technology Development Co., Ltd +xn--kput3i + +// xn--mgba3a3ejt : 2014-11-20 Aramco Services Company +xn--mgba3a3ejt + +// xn--mgba7c0bbn0a : 2015-05-14 Crescent Holding GmbH +xn--mgba7c0bbn0a + +// xn--mgbaakc7dvf : 2015-09-03 Emirates Telecommunications Corporation (trading as Etisalat) +xn--mgbaakc7dvf + +// xn--mgbab2bd : 2013-10-31 CORE Association +xn--mgbab2bd + +// xn--mgbb9fbpob : 2014-12-18 GreenTech Consultancy Company W.L.L. +xn--mgbb9fbpob + +// xn--mgbca7dzdo : 2015-07-30 Abu Dhabi Systems and Information Centre +xn--mgbca7dzdo + +// xn--mgbi4ecexp : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication) +xn--mgbi4ecexp + +// xn--mgbt3dhd : 2014-09-04 Asia Green IT System Bilgisayar San. ve Tic. Ltd. Sti. +xn--mgbt3dhd + +// xn--mk1bu44c : 2015-01-15 VeriSign Sarl +xn--mk1bu44c + +// xn--mxtq1m : 2014-03-06 Net-Chinese Co., Ltd. +xn--mxtq1m + +// xn--ngbc5azd : 2013-07-13 International Domain Registry Pty. Ltd. +xn--ngbc5azd + +// xn--ngbe9e0a : 2014-12-04 Kuwait Finance House +xn--ngbe9e0a + +// xn--ngbrx : 2015-11-12 League of Arab States +xn--ngbrx + +// xn--nqv7f : 2013-11-14 Public Interest Registry +xn--nqv7f + +// xn--nqv7fs00ema : 2013-11-14 Public Interest Registry +xn--nqv7fs00ema + +// xn--nyqy26a : 2014-11-07 Stable Tone Limited +xn--nyqy26a + +// xn--p1acf : 2013-12-12 Rusnames Limited +xn--p1acf + +// xn--pbt977c : 2014-12-22 Richemont DNS Inc. +xn--pbt977c + +// xn--pssy2u : 2015-01-15 VeriSign Sarl +xn--pssy2u + +// xn--q9jyb4c : 2013-09-17 Charleston Road Registry Inc. +xn--q9jyb4c + +// xn--qcka1pmc : 2014-07-31 Charleston Road Registry Inc. +xn--qcka1pmc + +// xn--rhqv96g : 2013-09-11 Stable Tone Limited +xn--rhqv96g + +// xn--rovu88b : 2015-02-26 Amazon EU S.à r.l. +xn--rovu88b + +// xn--ses554g : 2014-01-16 +xn--ses554g + +// xn--t60b56a : 2015-01-15 VeriSign Sarl +xn--t60b56a + +// xn--tckwe : 2015-01-15 VeriSign Sarl +xn--tckwe + +// xn--tiq49xqyj : 2015-10-21 Pontificium Consilium de Comunicationibus Socialibus (PCCS) (Pontifical Council for Social Communication) +xn--tiq49xqyj + +// xn--unup4y : 2013-07-14 Spring Fields, LLC +xn--unup4y + +// xn--vermgensberater-ctb : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG +xn--vermgensberater-ctb + +// xn--vermgensberatung-pwb : 2014-06-23 Deutsche Vermögensberatung Aktiengesellschaft DVAG +xn--vermgensberatung-pwb + +// xn--vhquv : 2013-08-27 Dash McCook, LLC +xn--vhquv + +// xn--vuq861b : 2014-10-16 Beijing Tele-info Network Technology Co., Ltd. +xn--vuq861b + +// xn--w4r85el8fhu5dnra : 2015-04-30 Kerry Trading Co. Limited +xn--w4r85el8fhu5dnra + +// xn--w4rs40l : 2015-07-30 Kerry Trading Co. Limited +xn--w4rs40l + +// xn--xhq521b : 2013-11-14 Guangzhou YU Wei Information Technology Co., Ltd. +xn--xhq521b + +// xn--zfr164b : 2013-11-08 China Organizational Name Administration Center +xn--zfr164b + +// xperia : 2015-05-14 Sony Mobile Communications AB +xperia + +// xyz : 2013-12-05 XYZ.COM LLC +xyz + +// yachts : 2014-01-09 DERYachts, LLC +yachts + +// yahoo : 2015-04-02 Yahoo! Domain Services Inc. +yahoo + +// yamaxun : 2014-12-18 Amazon EU S.à r.l. +yamaxun + +// yandex : 2014-04-10 YANDEX, LLC +yandex + +// yodobashi : 2014-11-20 YODOBASHI CAMERA CO.,LTD. +yodobashi + +// yoga : 2014-05-29 Top Level Domain Holdings Limited +yoga + +// yokohama : 2013-12-12 GMO Registry, Inc. +yokohama + +// you : 2015-04-09 Amazon EU S.à r.l. +you + +// youtube : 2014-05-01 Charleston Road Registry Inc. +youtube + +// yun : 2015-01-08 QIHOO 360 TECHNOLOGY CO. LTD. +yun + +// zappos : 2015-06-25 Amazon EU S.à r.l. +zappos + +// zara : 2014-11-07 Industria de Diseño Textil, S.A. (INDITEX, S.A.) +zara + +// zero : 2014-12-18 Amazon EU S.à r.l. +zero + +// zip : 2014-05-08 Charleston Road Registry Inc. +zip + +// zippo : 2015-07-02 Zadco Company +zippo + +// zone : 2013-11-14 Outer Falls, LLC +zone + +// zuerich : 2014-11-07 Kanton Zürich (Canton of Zurich) +zuerich + + +// ===END ICANN DOMAINS=== +// ===BEGIN PRIVATE DOMAINS=== +// (Note: these are in alphabetical order by company name) + +// 1GB LLC : https://www.1gb.ua/ +// Submitted by 1GB LLC +cc.ua +inf.ua +ltd.ua + +// AgileBits Inc : https://agilebits.com +// Submitted by Roustem Karimov +1password.ca +1password.com +1password.eu + +// Agnat sp. z o.o. : https://domena.pl +// Submitted by Przemyslaw Plewa +beep.pl + +// Alces Software Ltd : http://alces-software.com +// Submitted by Mark J. Titorenko +*.compute.estate +*.alces.network + +// alwaysdata : https://www.alwaysdata.com +// Submitted by Cyril +alwaysdata.net + +// Amazon CloudFront : https://aws.amazon.com/cloudfront/ +// Submitted by Donavan Miller +cloudfront.net + +// Amazon Elastic Compute Cloud : https://aws.amazon.com/ec2/ +// Submitted by Luke Wells +*.compute.amazonaws.com +*.compute-1.amazonaws.com +*.compute.amazonaws.com.cn +us-east-1.amazonaws.com + +// Amazon Elastic Beanstalk : https://aws.amazon.com/elasticbeanstalk/ +// Submitted by Luke Wells +cn-north-1.eb.amazonaws.com.cn +elasticbeanstalk.com +ap-northeast-1.elasticbeanstalk.com +ap-northeast-2.elasticbeanstalk.com +ap-south-1.elasticbeanstalk.com +ap-southeast-1.elasticbeanstalk.com +ap-southeast-2.elasticbeanstalk.com +ca-central-1.elasticbeanstalk.com +eu-central-1.elasticbeanstalk.com +eu-west-1.elasticbeanstalk.com +eu-west-2.elasticbeanstalk.com +eu-west-3.elasticbeanstalk.com +sa-east-1.elasticbeanstalk.com +us-east-1.elasticbeanstalk.com +us-east-2.elasticbeanstalk.com +us-gov-west-1.elasticbeanstalk.com +us-west-1.elasticbeanstalk.com +us-west-2.elasticbeanstalk.com + +// Amazon Elastic Load Balancing : https://aws.amazon.com/elasticloadbalancing/ +// Submitted by Luke Wells +*.elb.amazonaws.com +*.elb.amazonaws.com.cn + +// Amazon S3 : https://aws.amazon.com/s3/ +// Submitted by Luke Wells +s3.amazonaws.com +s3-ap-northeast-1.amazonaws.com +s3-ap-northeast-2.amazonaws.com +s3-ap-south-1.amazonaws.com +s3-ap-southeast-1.amazonaws.com +s3-ap-southeast-2.amazonaws.com +s3-ca-central-1.amazonaws.com +s3-eu-central-1.amazonaws.com +s3-eu-west-1.amazonaws.com +s3-eu-west-2.amazonaws.com +s3-eu-west-3.amazonaws.com +s3-external-1.amazonaws.com +s3-fips-us-gov-west-1.amazonaws.com +s3-sa-east-1.amazonaws.com +s3-us-gov-west-1.amazonaws.com +s3-us-east-2.amazonaws.com +s3-us-west-1.amazonaws.com +s3-us-west-2.amazonaws.com +s3.ap-northeast-2.amazonaws.com +s3.ap-south-1.amazonaws.com +s3.cn-north-1.amazonaws.com.cn +s3.ca-central-1.amazonaws.com +s3.eu-central-1.amazonaws.com +s3.eu-west-2.amazonaws.com +s3.eu-west-3.amazonaws.com +s3.us-east-2.amazonaws.com +s3.dualstack.ap-northeast-1.amazonaws.com +s3.dualstack.ap-northeast-2.amazonaws.com +s3.dualstack.ap-south-1.amazonaws.com +s3.dualstack.ap-southeast-1.amazonaws.com +s3.dualstack.ap-southeast-2.amazonaws.com +s3.dualstack.ca-central-1.amazonaws.com +s3.dualstack.eu-central-1.amazonaws.com +s3.dualstack.eu-west-1.amazonaws.com +s3.dualstack.eu-west-2.amazonaws.com +s3.dualstack.eu-west-3.amazonaws.com +s3.dualstack.sa-east-1.amazonaws.com +s3.dualstack.us-east-1.amazonaws.com +s3.dualstack.us-east-2.amazonaws.com +s3-website-us-east-1.amazonaws.com +s3-website-us-west-1.amazonaws.com +s3-website-us-west-2.amazonaws.com +s3-website-ap-northeast-1.amazonaws.com +s3-website-ap-southeast-1.amazonaws.com +s3-website-ap-southeast-2.amazonaws.com +s3-website-eu-west-1.amazonaws.com +s3-website-sa-east-1.amazonaws.com +s3-website.ap-northeast-2.amazonaws.com +s3-website.ap-south-1.amazonaws.com +s3-website.ca-central-1.amazonaws.com +s3-website.eu-central-1.amazonaws.com +s3-website.eu-west-2.amazonaws.com +s3-website.eu-west-3.amazonaws.com +s3-website.us-east-2.amazonaws.com + +// Amune : https://amune.org/ +// Submitted by Team Amune +t3l3p0rt.net +tele.amune.org + +// Aptible : https://www.aptible.com/ +// Submitted by Thomas Orozco +on-aptible.com + +// Asociación Amigos de la Informática "Euskalamiga" : http://encounter.eus/ +// Submitted by Hector Martin +user.party.eus + +// Association potager.org : https://potager.org/ +// Submitted by Lunar +pimienta.org +poivron.org +potager.org +sweetpepper.org + +// ASUSTOR Inc. : http://www.asustor.com +// Submitted by Vincent Tseng +myasustor.com + +// AVM : https://avm.de +// Submitted by Andreas Weise +myfritz.net + +// AW AdvisorWebsites.com Software Inc : https://advisorwebsites.com +// Submitted by James Kennedy +*.awdev.ca +*.advisor.ws + +// backplane : https://www.backplane.io +// Submitted by Anthony Voutas +backplaneapp.io + +// BetaInABox +// Submitted by Adrian +betainabox.com + +// BinaryLane : http://www.binarylane.com +// Submitted by Nathan O'Sullivan +bnr.la + +// Boomla : https://boomla.com +// Submitted by Tibor Halter +boomla.net + +// Boxfuse : https://boxfuse.com +// Submitted by Axel Fontaine +boxfuse.io + +// bplaced : https://www.bplaced.net/ +// Submitted by Miroslav Bozic +square7.ch +bplaced.com +bplaced.de +square7.de +bplaced.net +square7.net + +// BrowserSafetyMark +// Submitted by Dave Tharp +browsersafetymark.io + +// callidomus : https://www.callidomus.com/ +// Submitted by Marcus Popp +mycd.eu + +// CentralNic : http://www.centralnic.com/names/domains +// Submitted by registry +ae.org +ar.com +br.com +cn.com +com.de +com.se +de.com +eu.com +gb.com +gb.net +hu.com +hu.net +jp.net +jpn.com +kr.com +mex.com +no.com +qc.com +ru.com +sa.com +se.com +se.net +uk.com +uk.net +us.com +uy.com +za.bz +za.com + +// Africa.com Web Solutions Ltd : https://registry.africa.com +// Submitted by Gavin Brown +africa.com + +// iDOT Services Limited : http://www.domain.gr.com +// Submitted by Gavin Brown +gr.com + +// Radix FZC : http://domains.in.net +// Submitted by Gavin Brown +in.net + +// US REGISTRY LLC : http://us.org +// Submitted by Gavin Brown +us.org + +// co.com Registry, LLC : https://registry.co.com +// Submitted by Gavin Brown +co.com + +// c.la : http://www.c.la/ +c.la + +// certmgr.org : https://certmgr.org +// Submitted by B. Blechschmidt +certmgr.org + +// Citrix : https://citrix.com +// Submitted by Alex Stoddard +xenapponazure.com + +// ClearVox : http://www.clearvox.nl/ +// Submitted by Leon Rowland +virtueeldomein.nl + +// Cloud66 : https://www.cloud66.com/ +// Submitted by Khash Sajadi +c66.me +cloud66.ws + +// CloudAccess.net : https://www.cloudaccess.net/ +// Submitted by Pawel Panek +jdevcloud.com +wpdevcloud.com +cloudaccess.host +freesite.host +cloudaccess.net + +// cloudControl : https://www.cloudcontrol.com/ +// Submitted by Tobias Wilken +cloudcontrolled.com +cloudcontrolapp.com + +// co.ca : http://registry.co.ca/ +co.ca + +// i-registry s.r.o. : http://www.i-registry.cz/ +// Submitted by Martin Semrad +co.cz + +// CDN77.com : http://www.cdn77.com +// Submitted by Jan Krpes +c.cdn77.org +cdn77-ssl.net +r.cdn77.net +rsc.cdn77.org +ssl.origin.cdn77-secure.org + +// Cloud DNS Ltd : http://www.cloudns.net +// Submitted by Aleksander Hristov +cloudns.asia +cloudns.biz +cloudns.club +cloudns.cc +cloudns.eu +cloudns.in +cloudns.info +cloudns.org +cloudns.pro +cloudns.pw +cloudns.us + +// CoDNS B.V. +co.nl +co.no + +// Combell.com : https://www.combell.com +// Submitted by Thomas Wouters +webhosting.be +hosting-cluster.nl + +// COSIMO GmbH : http://www.cosimo.de +// Submitted by Rene Marticke +dyn.cosidns.de +dynamisches-dns.de +dnsupdater.de +internet-dns.de +l-o-g-i-n.de +dynamic-dns.info +feste-ip.net +knx-server.net +static-access.net + +// Craynic, s.r.o. : http://www.craynic.com/ +// Submitted by Ales Krajnik +realm.cz + +// Cryptonomic : https://cryptonomic.net/ +// Submitted by Andrew Cady +*.cryptonomic.net + +// Cupcake : https://cupcake.io/ +// Submitted by Jonathan Rudenberg +cupcake.is + +// cyon GmbH : https://www.cyon.ch/ +// Submitted by Dominic Luechinger +cyon.link +cyon.site + +// Daplie, Inc : https://daplie.com +// Submitted by AJ ONeal +daplie.me +localhost.daplie.me + +// Dansk.net : http://www.dansk.net/ +// Submitted by Anani Voule +biz.dk +co.dk +firm.dk +reg.dk +store.dk + +// Debian : https://www.debian.org/ +// Submitted by Peter Palfrader / Debian Sysadmin Team +debian.net + +// deSEC : https://desec.io/ +// Submitted by Peter Thomassen +dedyn.io + +// DNShome : https://www.dnshome.de/ +// Submitted by Norbert Auler +dnshome.de + +// DrayTek Corp. : https://www.draytek.com/ +// Submitted by Paul Fang +drayddns.com + +// DreamHost : http://www.dreamhost.com/ +// Submitted by Andrew Farmer +dreamhosters.com + +// Drobo : http://www.drobo.com/ +// Submitted by Ricardo Padilha +mydrobo.com + +// Drud Holdings, LLC. : https://www.drud.com/ +// Submitted by Kevin Bridges +drud.io +drud.us + +// DuckDNS : http://www.duckdns.org/ +// Submitted by Richard Harper +duckdns.org + +// dy.fi : http://dy.fi/ +// Submitted by Heikki Hannikainen +dy.fi +tunk.org + +// DynDNS.com : http://www.dyndns.com/services/dns/dyndns/ +dyndns-at-home.com +dyndns-at-work.com +dyndns-blog.com +dyndns-free.com +dyndns-home.com +dyndns-ip.com +dyndns-mail.com +dyndns-office.com +dyndns-pics.com +dyndns-remote.com +dyndns-server.com +dyndns-web.com +dyndns-wiki.com +dyndns-work.com +dyndns.biz +dyndns.info +dyndns.org +dyndns.tv +at-band-camp.net +ath.cx +barrel-of-knowledge.info +barrell-of-knowledge.info +better-than.tv +blogdns.com +blogdns.net +blogdns.org +blogsite.org +boldlygoingnowhere.org +broke-it.net +buyshouses.net +cechire.com +dnsalias.com +dnsalias.net +dnsalias.org +dnsdojo.com +dnsdojo.net +dnsdojo.org +does-it.net +doesntexist.com +doesntexist.org +dontexist.com +dontexist.net +dontexist.org +doomdns.com +doomdns.org +dvrdns.org +dyn-o-saur.com +dynalias.com +dynalias.net +dynalias.org +dynathome.net +dyndns.ws +endofinternet.net +endofinternet.org +endoftheinternet.org +est-a-la-maison.com +est-a-la-masion.com +est-le-patron.com +est-mon-blogueur.com +for-better.biz +for-more.biz +for-our.info +for-some.biz +for-the.biz +forgot.her.name +forgot.his.name +from-ak.com +from-al.com +from-ar.com +from-az.net +from-ca.com +from-co.net +from-ct.com +from-dc.com +from-de.com +from-fl.com +from-ga.com +from-hi.com +from-ia.com +from-id.com +from-il.com +from-in.com +from-ks.com +from-ky.com +from-la.net +from-ma.com +from-md.com +from-me.org +from-mi.com +from-mn.com +from-mo.com +from-ms.com +from-mt.com +from-nc.com +from-nd.com +from-ne.com +from-nh.com +from-nj.com +from-nm.com +from-nv.com +from-ny.net +from-oh.com +from-ok.com +from-or.com +from-pa.com +from-pr.com +from-ri.com +from-sc.com +from-sd.com +from-tn.com +from-tx.com +from-ut.com +from-va.com +from-vt.com +from-wa.com +from-wi.com +from-wv.com +from-wy.com +ftpaccess.cc +fuettertdasnetz.de +game-host.org +game-server.cc +getmyip.com +gets-it.net +go.dyndns.org +gotdns.com +gotdns.org +groks-the.info +groks-this.info +ham-radio-op.net +here-for-more.info +hobby-site.com +hobby-site.org +home.dyndns.org +homedns.org +homeftp.net +homeftp.org +homeip.net +homelinux.com +homelinux.net +homelinux.org +homeunix.com +homeunix.net +homeunix.org +iamallama.com +in-the-band.net +is-a-anarchist.com +is-a-blogger.com +is-a-bookkeeper.com +is-a-bruinsfan.org +is-a-bulls-fan.com +is-a-candidate.org +is-a-caterer.com +is-a-celticsfan.org +is-a-chef.com +is-a-chef.net +is-a-chef.org +is-a-conservative.com +is-a-cpa.com +is-a-cubicle-slave.com +is-a-democrat.com +is-a-designer.com +is-a-doctor.com +is-a-financialadvisor.com +is-a-geek.com +is-a-geek.net +is-a-geek.org +is-a-green.com +is-a-guru.com +is-a-hard-worker.com +is-a-hunter.com +is-a-knight.org +is-a-landscaper.com +is-a-lawyer.com +is-a-liberal.com +is-a-libertarian.com +is-a-linux-user.org +is-a-llama.com +is-a-musician.com +is-a-nascarfan.com +is-a-nurse.com +is-a-painter.com +is-a-patsfan.org +is-a-personaltrainer.com +is-a-photographer.com +is-a-player.com +is-a-republican.com +is-a-rockstar.com +is-a-socialist.com +is-a-soxfan.org +is-a-student.com +is-a-teacher.com +is-a-techie.com +is-a-therapist.com +is-an-accountant.com +is-an-actor.com +is-an-actress.com +is-an-anarchist.com +is-an-artist.com +is-an-engineer.com +is-an-entertainer.com +is-by.us +is-certified.com +is-found.org +is-gone.com +is-into-anime.com +is-into-cars.com +is-into-cartoons.com +is-into-games.com +is-leet.com +is-lost.org +is-not-certified.com +is-saved.org +is-slick.com +is-uberleet.com +is-very-bad.org +is-very-evil.org +is-very-good.org +is-very-nice.org +is-very-sweet.org +is-with-theband.com +isa-geek.com +isa-geek.net +isa-geek.org +isa-hockeynut.com +issmarterthanyou.com +isteingeek.de +istmein.de +kicks-ass.net +kicks-ass.org +knowsitall.info +land-4-sale.us +lebtimnetz.de +leitungsen.de +likes-pie.com +likescandy.com +merseine.nu +mine.nu +misconfused.org +mypets.ws +myphotos.cc +neat-url.com +office-on-the.net +on-the-web.tv +podzone.net +podzone.org +readmyblog.org +saves-the-whales.com +scrapper-site.net +scrapping.cc +selfip.biz +selfip.com +selfip.info +selfip.net +selfip.org +sells-for-less.com +sells-for-u.com +sells-it.net +sellsyourhome.org +servebbs.com +servebbs.net +servebbs.org +serveftp.net +serveftp.org +servegame.org +shacknet.nu +simple-url.com +space-to-rent.com +stuff-4-sale.org +stuff-4-sale.us +teaches-yoga.com +thruhere.net +traeumtgerade.de +webhop.biz +webhop.info +webhop.net +webhop.org +worse-than.tv +writesthisblog.com + +// ddnss.de : https://www.ddnss.de/ +// Submitted by Robert Niedziela +ddnss.de +dyn.ddnss.de +dyndns.ddnss.de +dyndns1.de +dyn-ip24.de +home-webserver.de +dyn.home-webserver.de +myhome-server.de +ddnss.org + +// Definima : http://www.definima.com/ +// Submitted by Maxence Bitterli +definima.net +definima.io + +// Dynu.com : https://www.dynu.com/ +// Submitted by Sue Ye +ddnsfree.com +ddnsgeek.com +giize.com +gleeze.com +kozow.com +loseyourip.com +ooguy.com +theworkpc.com +casacam.net +dynu.net +accesscam.org +camdvr.org +freeddns.org +mywire.org +webredirect.org +myddns.rocks +blogsite.xyz + +// dynv6 : https://dynv6.com +// Submitted by Dominik Menke +dynv6.net + +// E4YOU spol. s.r.o. : https://e4you.cz/ +// Submitted by Vladimir Dudr +e4.cz + +// Enalean SAS: https://www.enalean.com +// Submitted by Thomas Cottier +mytuleap.com + +// Enonic : http://enonic.com/ +// Submitted by Erik Kaareng-Sunde +enonic.io +customer.enonic.io + +// EU.org https://eu.org/ +// Submitted by Pierre Beyssac +eu.org +al.eu.org +asso.eu.org +at.eu.org +au.eu.org +be.eu.org +bg.eu.org +ca.eu.org +cd.eu.org +ch.eu.org +cn.eu.org +cy.eu.org +cz.eu.org +de.eu.org +dk.eu.org +edu.eu.org +ee.eu.org +es.eu.org +fi.eu.org +fr.eu.org +gr.eu.org +hr.eu.org +hu.eu.org +ie.eu.org +il.eu.org +in.eu.org +int.eu.org +is.eu.org +it.eu.org +jp.eu.org +kr.eu.org +lt.eu.org +lu.eu.org +lv.eu.org +mc.eu.org +me.eu.org +mk.eu.org +mt.eu.org +my.eu.org +net.eu.org +ng.eu.org +nl.eu.org +no.eu.org +nz.eu.org +paris.eu.org +pl.eu.org +pt.eu.org +q-a.eu.org +ro.eu.org +ru.eu.org +se.eu.org +si.eu.org +sk.eu.org +tr.eu.org +uk.eu.org +us.eu.org + +// Evennode : http://www.evennode.com/ +// Submitted by Michal Kralik +eu-1.evennode.com +eu-2.evennode.com +eu-3.evennode.com +eu-4.evennode.com +us-1.evennode.com +us-2.evennode.com +us-3.evennode.com +us-4.evennode.com + +// eDirect Corp. : https://hosting.url.com.tw/ +// Submitted by C.S. chang +twmail.cc +twmail.net +twmail.org +mymailer.com.tw +url.tw + +// Facebook, Inc. +// Submitted by Peter Ruibal +apps.fbsbx.com + +// FAITID : https://faitid.org/ +// Submitted by Maxim Alzoba +// https://www.flexireg.net/stat_info +ru.net +adygeya.ru +bashkiria.ru +bir.ru +cbg.ru +com.ru +dagestan.ru +grozny.ru +kalmykia.ru +kustanai.ru +marine.ru +mordovia.ru +msk.ru +mytis.ru +nalchik.ru +nov.ru +pyatigorsk.ru +spb.ru +vladikavkaz.ru +vladimir.ru +abkhazia.su +adygeya.su +aktyubinsk.su +arkhangelsk.su +armenia.su +ashgabad.su +azerbaijan.su +balashov.su +bashkiria.su +bryansk.su +bukhara.su +chimkent.su +dagestan.su +east-kazakhstan.su +exnet.su +georgia.su +grozny.su +ivanovo.su +jambyl.su +kalmykia.su +kaluga.su +karacol.su +karaganda.su +karelia.su +khakassia.su +krasnodar.su +kurgan.su +kustanai.su +lenug.su +mangyshlak.su +mordovia.su +msk.su +murmansk.su +nalchik.su +navoi.su +north-kazakhstan.su +nov.su +obninsk.su +penza.su +pokrovsk.su +sochi.su +spb.su +tashkent.su +termez.su +togliatti.su +troitsk.su +tselinograd.su +tula.su +tuva.su +vladikavkaz.su +vladimir.su +vologda.su + +// Fancy Bits, LLC : http://getchannels.com +// Submitted by Aman Gupta +channelsdvr.net + +// Fastly Inc. : http://www.fastly.com/ +// Submitted by Fastly Security +fastlylb.net +map.fastlylb.net +freetls.fastly.net +map.fastly.net +a.prod.fastly.net +global.prod.fastly.net +a.ssl.fastly.net +b.ssl.fastly.net +global.ssl.fastly.net + +// Featherhead : https://featherhead.xyz/ +// Submitted by Simon Menke +fhapp.xyz + +// Fedora : https://fedoraproject.org/ +// submitted by Patrick Uiterwijk +fedorainfracloud.org +fedorapeople.org +cloud.fedoraproject.org +app.os.fedoraproject.org +app.os.stg.fedoraproject.org + +// Filegear Inc. : https://www.filegear.com +// Submitted by Jason Zhu +filegear.me + +// Firebase, Inc. +// Submitted by Chris Raynor +firebaseapp.com + +// Flynn : https://flynn.io +// Submitted by Jonathan Rudenberg +flynnhub.com +flynnhosting.net + +// Freebox : http://www.freebox.fr +// Submitted by Romain Fliedel +freebox-os.com +freeboxos.com +fbx-os.fr +fbxos.fr +freebox-os.fr +freeboxos.fr + +// Futureweb OG : http://www.futureweb.at +// Submitted by Andreas Schnederle-Wagner +*.futurecms.at +futurehosting.at +futuremailing.at +*.ex.ortsinfo.at +*.kunden.ortsinfo.at +*.statics.cloud + +// GDS : https://www.gov.uk/service-manual/operations/operating-servicegovuk-subdomains +// Submitted by David Illsley +service.gov.uk + +// GitHub, Inc. +// Submitted by Patrick Toomey +github.io +githubusercontent.com + +// GitLab, Inc. +// Submitted by Alex Hanselka +gitlab.io + +// UKHomeOffice : https://www.gov.uk/government/organisations/home-office +// Submitted by Jon Shanks +homeoffice.gov.uk + +// GlobeHosting, Inc. +// Submitted by Zoltan Egresi +ro.im +shop.ro + +// GoIP DNS Services : http://www.goip.de +// Submitted by Christian Poulter +goip.de + +// Google, Inc. +// Submitted by Eduardo Vela +*.0emm.com +appspot.com +blogspot.ae +blogspot.al +blogspot.am +blogspot.ba +blogspot.be +blogspot.bg +blogspot.bj +blogspot.ca +blogspot.cf +blogspot.ch +blogspot.cl +blogspot.co.at +blogspot.co.id +blogspot.co.il +blogspot.co.ke +blogspot.co.nz +blogspot.co.uk +blogspot.co.za +blogspot.com +blogspot.com.ar +blogspot.com.au +blogspot.com.br +blogspot.com.by +blogspot.com.co +blogspot.com.cy +blogspot.com.ee +blogspot.com.eg +blogspot.com.es +blogspot.com.mt +blogspot.com.ng +blogspot.com.tr +blogspot.com.uy +blogspot.cv +blogspot.cz +blogspot.de +blogspot.dk +blogspot.fi +blogspot.fr +blogspot.gr +blogspot.hk +blogspot.hr +blogspot.hu +blogspot.ie +blogspot.in +blogspot.is +blogspot.it +blogspot.jp +blogspot.kr +blogspot.li +blogspot.lt +blogspot.lu +blogspot.md +blogspot.mk +blogspot.mr +blogspot.mx +blogspot.my +blogspot.nl +blogspot.no +blogspot.pe +blogspot.pt +blogspot.qa +blogspot.re +blogspot.ro +blogspot.rs +blogspot.ru +blogspot.se +blogspot.sg +blogspot.si +blogspot.sk +blogspot.sn +blogspot.td +blogspot.tw +blogspot.ug +blogspot.vn +cloudfunctions.net +cloud.goog +codespot.com +googleapis.com +googlecode.com +pagespeedmobilizer.com +publishproxy.com +withgoogle.com +withyoutube.com + +// Hashbang : https://hashbang.sh +hashbang.sh + +// Hasura : https://hasura.io +// Submitted by Shahidh K Muhammed +hasura-app.io + +// Hepforge : https://www.hepforge.org +// Submitted by David Grellscheid +hepforge.org + +// Heroku : https://www.heroku.com/ +// Submitted by Tom Maher +herokuapp.com +herokussl.com + +// Ici la Lune : http://www.icilalune.com/ +// Submitted by Simon Morvan +moonscale.net + +// iki.fi +// Submitted by Hannu Aronsson +iki.fi + +// info.at : http://www.info.at/ +biz.at +info.at + +// info.cx : http://info.cx +// Submitted by Jacob Slater +info.cx + +// Interlegis : http://www.interlegis.leg.br +// Submitted by Gabriel Ferreira +ac.leg.br +al.leg.br +am.leg.br +ap.leg.br +ba.leg.br +ce.leg.br +df.leg.br +es.leg.br +go.leg.br +ma.leg.br +mg.leg.br +ms.leg.br +mt.leg.br +pa.leg.br +pb.leg.br +pe.leg.br +pi.leg.br +pr.leg.br +rj.leg.br +rn.leg.br +ro.leg.br +rr.leg.br +rs.leg.br +sc.leg.br +se.leg.br +sp.leg.br +to.leg.br + +// intermetrics GmbH : https://pixolino.com/ +// Submitted by Wolfgang Schwarz +pixolino.com + +// IPiFony Systems, Inc. : https://www.ipifony.com/ +// Submitted by Matthew Hardeman +ipifony.net + +// Joyent : https://www.joyent.com/ +// Submitted by Brian Bennett +*.triton.zone +*.cns.joyent.com + +// JS.ORG : http://dns.js.org +// Submitted by Stefan Keim +js.org + +// Keyweb AG : https://www.keyweb.de +// Submitted by Martin Dannehl +keymachine.de + +// KnightPoint Systems, LLC : http://www.knightpoint.com/ +// Submitted by Roy Keene +knightpoint.systems + +// .KRD : http://nic.krd/data/krd/Registration%20Policy.pdf +co.krd +edu.krd + +// LCube - Professional hosting e.K. : https://www.lcube-webhosting.de +// Submitted by Lars Laehn +git-repos.de +lcube-server.de +svn-repos.de + +// linkyard ldt: https://www.linkyard.ch/ +// Submitted by Mario Siegenthaler +linkyard.cloud +linkyard-cloud.ch + +// LiquidNet Ltd : http://www.liquidnetlimited.com/ +// Submitted by Victor Velchev +we.bs + +// Lukanet Ltd : https://lukanet.com +// Submitted by Anton Avramov +barsy.bg +barsyonline.com +barsy.de +barsy.eu +barsy.in +barsy.net +barsy.online +barsy.support + +// Magento Commerce +// Submitted by Damien Tournoud +*.magentosite.cloud + +// Mail.Ru Group : https://hb.cldmail.ru +// Submitted by Ilya Zaretskiy +hb.cldmail.ru + +// MetaCentrum, CESNET z.s.p.o. : https://www.metacentrum.cz/en/ +// Submitted by Zdeněk Šustr +cloud.metacentrum.cz +custom.metacentrum.cz + +// Meteor Development Group : https://www.meteor.com/hosting +// Submitted by Pierre Carrier +meteorapp.com +eu.meteorapp.com + +// Michau Enterprises Limited : http://www.co.pl/ +co.pl + +// Microsoft : http://microsoft.com +// Submitted by Barry Dorrans +azurewebsites.net +azure-mobile.net +cloudapp.net + +// Mozilla Foundation : https://mozilla.org/ +// Submitted by glob +bmoattachments.org + +// MSK-IX : https://www.msk-ix.ru/ +// Submitted by Khannanov Roman +net.ru +org.ru +pp.ru + +// Netlify : https://www.netlify.com +// Submitted by Jessica Parsons +bitballoon.com +netlify.com + +// Neustar Inc. +// Submitted by Trung Tran +4u.com + +// ngrok : https://ngrok.com/ +// Submitted by Alan Shreve +ngrok.io + +// Nimbus Hosting Ltd. : https://www.nimbushosting.co.uk/ +// Submitted by Nicholas Ford +nh-serv.co.uk + +// NFSN, Inc. : https://www.NearlyFreeSpeech.NET/ +// Submitted by Jeff Wheelhouse +nfshost.com + +// nsupdate.info : https://www.nsupdate.info/ +// Submitted by Thomas Waldmann +nsupdate.info +nerdpol.ovh + +// No-IP.com : https://noip.com/ +// Submitted by Deven Reza +blogsyte.com +brasilia.me +cable-modem.org +ciscofreak.com +collegefan.org +couchpotatofries.org +damnserver.com +ddns.me +ditchyourip.com +dnsfor.me +dnsiskinky.com +dvrcam.info +dynns.com +eating-organic.net +fantasyleague.cc +geekgalaxy.com +golffan.us +health-carereform.com +homesecuritymac.com +homesecuritypc.com +hopto.me +ilovecollege.info +loginto.me +mlbfan.org +mmafan.biz +myactivedirectory.com +mydissent.net +myeffect.net +mymediapc.net +mypsx.net +mysecuritycamera.com +mysecuritycamera.net +mysecuritycamera.org +net-freaks.com +nflfan.org +nhlfan.net +no-ip.ca +no-ip.co.uk +no-ip.net +noip.us +onthewifi.com +pgafan.net +point2this.com +pointto.us +privatizehealthinsurance.net +quicksytes.com +read-books.org +securitytactics.com +serveexchange.com +servehumour.com +servep2p.com +servesarcasm.com +stufftoread.com +ufcfan.org +unusualperson.com +workisboring.com +3utilities.com +bounceme.net +ddns.net +ddnsking.com +gotdns.ch +hopto.org +myftp.biz +myftp.org +myvnc.com +no-ip.biz +no-ip.info +no-ip.org +noip.me +redirectme.net +servebeer.com +serveblog.net +servecounterstrike.com +serveftp.com +servegame.com +servehalflife.com +servehttp.com +serveirc.com +serveminecraft.net +servemp3.com +servepics.com +servequake.com +sytes.net +webhop.me +zapto.org + +// NodeArt : https://nodeart.io +// Submitted by Konstantin Nosov +stage.nodeart.io + +// Nodum B.V. : https://nodum.io/ +// Submitted by Wietse Wind +nodum.co +nodum.io + +// NYC.mn : http://www.information.nyc.mn +// Submitted by Matthew Brown +nyc.mn + +// NymNom : https://nymnom.com/ +// Submitted by Dave McCormack +nom.ae +nom.ai +nom.al +nym.by +nym.bz +nom.cl +nom.gd +nom.gl +nym.gr +nom.gt +nom.hn +nom.im +nym.kz +nym.la +nom.li +nym.li +nym.lt +nym.lu +nym.me +nom.mk +nym.mx +nom.nu +nym.nz +nym.pe +nym.pt +nom.pw +nom.qa +nom.rs +nom.si +nym.sk +nym.su +nym.sx +nym.tw +nom.ug +nom.uy +nom.vc +nom.vg + +// Octopodal Solutions, LLC. : https://ulterius.io/ +// Submitted by Andrew Sampson +cya.gg + +// One Fold Media : http://www.onefoldmedia.com/ +// Submitted by Eddie Jones +nid.io + +// OpenCraft GmbH : http://opencraft.com/ +// Submitted by Sven Marnach +opencraft.hosting + +// Opera Software, A.S.A. +// Submitted by Yngve Pettersen +operaunite.com + +// OutSystems +// Submitted by Duarte Santos +outsystemscloud.com + +// OwnProvider : http://www.ownprovider.com +// Submitted by Jan Moennich +ownprovider.com + +// oy.lc +// Submitted by Charly Coste +oy.lc + +// Pagefog : https://pagefog.com/ +// Submitted by Derek Myers +pgfog.com + +// Pagefront : https://www.pagefronthq.com/ +// Submitted by Jason Kriss +pagefrontapp.com + +// .pl domains (grandfathered) +art.pl +gliwice.pl +krakow.pl +poznan.pl +wroc.pl +zakopane.pl + +// Pantheon Systems, Inc. : https://pantheon.io/ +// Submitted by Gary Dylina +pantheonsite.io +gotpantheon.com + +// Peplink | Pepwave : http://peplink.com/ +// Submitted by Steve Leung +mypep.link + +// Planet-Work : https://www.planet-work.com/ +// Submitted by Frédéric VANNIÈRE +on-web.fr + +// Platform.sh : https://platform.sh +// Submitted by Nikola Kotur +*.platform.sh +*.platformsh.site + +// prgmr.com : https://prgmr.com/ +// Submitted by Sarah Newman +xen.prgmr.com + +// priv.at : http://www.nic.priv.at/ +// Submitted by registry +priv.at + +// Protonet GmbH : http://protonet.io +// Submitted by Martin Meier +protonet.io + +// Publication Presse Communication SARL : https://ppcom.fr +// Submitted by Yaacov Akiba Slama +chirurgiens-dentistes-en-france.fr +byen.site + +// QA2 +// Submitted by Daniel Dent (https://www.danieldent.com/) +qa2.com + +// QNAP System Inc : https://www.qnap.com +// Submitted by Nick Chang +dev-myqnapcloud.com +alpha-myqnapcloud.com +myqnapcloud.com + +// Quip : https://quip.com +// Submitted by Patrick Linehan +*.quipelements.com + +// Qutheory LLC : http://qutheory.io +// Submitted by Jonas Schwartz +vapor.cloud +vaporcloud.io + +// Rackmaze LLC : https://www.rackmaze.com +// Submitted by Kirill Pertsev +rackmaze.com +rackmaze.net + +// Red Hat, Inc. OpenShift : https://openshift.redhat.com/ +// Submitted by Tim Kramer +rhcloud.com + +// Resin.io : https://resin.io +// Submitted by Tim Perry +resindevice.io +devices.resinstaging.io + +// RethinkDB : https://www.rethinkdb.com/ +// Submitted by Chris Kastorff +hzc.io + +// Revitalised Limited : http://www.revitalised.co.uk +// Submitted by Jack Price +wellbeingzone.eu +ptplus.fit +wellbeingzone.co.uk + +// Sandstorm Development Group, Inc. : https://sandcats.io/ +// Submitted by Asheesh Laroia +sandcats.io + +// SBE network solutions GmbH : https://www.sbe.de/ +// Submitted by Norman Meilick +logoip.de +logoip.com + +// schokokeks.org GbR : https://schokokeks.org/ +// Submitted by Hanno Böck +schokokeks.net + +// Scry Security : http://www.scrysec.com +// Submitted by Shante Adam +scrysec.com + +// Securepoint GmbH : https://www.securepoint.de +// Submitted by Erik Anders +firewall-gateway.com +firewall-gateway.de +my-gateway.de +my-router.de +spdns.de +spdns.eu +firewall-gateway.net +my-firewall.org +myfirewall.org +spdns.org + +// SensioLabs, SAS : https://sensiolabs.com/ +// Submitted by Fabien Potencier +*.s5y.io +*.sensiosite.cloud + +// Service Online LLC : http://drs.ua/ +// Submitted by Serhii Bulakh +biz.ua +co.ua +pp.ua + +// ShiftEdit : https://shiftedit.net/ +// Submitted by Adam Jimenez +shiftedit.io + +// Shopblocks : http://www.shopblocks.com/ +// Submitted by Alex Bowers +myshopblocks.com + +// SinaAppEngine : http://sae.sina.com.cn/ +// Submitted by SinaAppEngine +1kapp.com +appchizi.com +applinzi.com +sinaapp.com +vipsinaapp.com + +// Skyhat : http://www.skyhat.io +// Submitted by Shante Adam +bounty-full.com +alpha.bounty-full.com +beta.bounty-full.com + +// staticland : https://static.land +// Submitted by Seth Vincent +static.land +dev.static.land +sites.static.land + +// SourceLair PC : https://www.sourcelair.com +// Submitted by Antonis Kalipetis +apps.lair.io +*.stolos.io + +// SpaceKit : https://www.spacekit.io/ +// Submitted by Reza Akhavan +spacekit.io + +// Stackspace : https://www.stackspace.io/ +// Submitted by Lina He +stackspace.space + +// Storj Labs Inc. : https://storj.io/ +// Submitted by Philip Hutchins +storj.farm + +// Sub 6 Limited: http://www.sub6.com +// Submitted by Dan Miller +temp-dns.com + +// Synology, Inc. : https://www.synology.com/ +// Submitted by Rony Weng +diskstation.me +dscloud.biz +dscloud.me +dscloud.mobi +dsmynas.com +dsmynas.net +dsmynas.org +familyds.com +familyds.net +familyds.org +i234.me +myds.me +synology.me +vpnplus.to + +// TAIFUN Software AG : http://taifun-software.de +// Submitted by Bjoern Henke +taifun-dns.de + +// TASK geographical domains (www.task.gda.pl/uslugi/dns) +gda.pl +gdansk.pl +gdynia.pl +med.pl +sopot.pl + +// Thingdust AG : https://thingdust.com/ +// Submitted by Adrian Imboden +cust.dev.thingdust.io +cust.disrec.thingdust.io +cust.prod.thingdust.io +cust.testing.thingdust.io + +// TownNews.com : http://www.townnews.com +// Submitted by Dustin Ward +bloxcms.com +townnews-staging.com + +// TrafficPlex GmbH : https://www.trafficplex.de/ +// Submitted by Phillipp Röll +12hp.at +2ix.at +4lima.at +lima-city.at +12hp.ch +2ix.ch +4lima.ch +lima-city.ch +trafficplex.cloud +de.cool +12hp.de +2ix.de +4lima.de +lima-city.de +1337.pictures +clan.rip +lima-city.rocks +webspace.rocks +lima.zone + +// TransIP : htts://www.transip.nl +// Submitted by Rory Breuk +*.transurl.be +*.transurl.eu +*.transurl.nl + +// TuxFamily : http://tuxfamily.org +// Submitted by TuxFamily administrators +tuxfamily.org + +// TwoDNS : https://www.twodns.de/ +// Submitted by TwoDNS-Support +dd-dns.de +diskstation.eu +diskstation.org +dray-dns.de +draydns.de +dyn-vpn.de +dynvpn.de +mein-vigor.de +my-vigor.de +my-wan.de +syno-ds.de +synology-diskstation.de +synology-ds.de + +// Uberspace : https://uberspace.de +// Submitted by Moritz Werner +uber.space + +// UDR Limited : http://www.udr.hk.com +// Submitted by registry +hk.com +hk.org +ltd.hk +inc.hk + +// .US +// Submitted by Ed Moore +lib.de.us + +// VeryPositive SIA : http://very.lv +// Submitted by Danko Aleksejevs +2038.io + +// Viprinet Europe GmbH : http://www.viprinet.com +// Submitted by Simon Kissel +router.management + +// Virtual-Info : https://www.virtual-info.info/ +// Submitted by Adnan RIHAN +v-info.info + +// WeDeploy by Liferay, Inc. : https://www.wedeploy.com +// Submitted by Henrique Vicente +wedeploy.io +wedeploy.me +wedeploy.sh + +// Western Digital Technologies, Inc : https://www.wdc.com +// Submitted by Jung Jin +remotewd.com + +// Wikimedia Labs : https://wikitech.wikimedia.org +// Submitted by Yuvi Panda +wmflabs.org + +// XS4ALL Internet bv : https://www.xs4all.nl/ +// Submitted by Daniel Mostertman +cistron.nl +demon.nl +xs4all.space + +// YesCourse Pty Ltd : https://yescourse.com +// Submitted by Atul Bhouraskar +official.academy + +// Yola : https://www.yola.com/ +// Submitted by Stefano Rivera +yolasite.com + +// Yombo : https://yombo.net +// Submitted by Mitch Schwenk +ybo.faith +yombo.me +homelink.one +ybo.party +ybo.review +ybo.science +ybo.trade + +// ZaNiC : http://www.za.net/ +// Submitted by registry +za.net +za.org + +// Zeit, Inc. : https://zeit.domains/ +// Submitted by Olli Vanhoja +now.sh + +// ===END PRIVATE DOMAINS=== +END_BUILTIN_DATA +1; diff --git a/lib/lib/IO/Socket/SSL/Utils.pm b/lib/lib/IO/Socket/SSL/Utils.pm new file mode 100644 index 0000000..9a766ce --- /dev/null +++ b/lib/lib/IO/Socket/SSL/Utils.pm @@ -0,0 +1,743 @@ + +package IO::Socket::SSL::Utils; +use strict; +use warnings; +use Carp 'croak'; +use Net::SSLeay; + +# old versions of Exporter do not export 'import' yet +require Exporter; +*import = \&Exporter::import; + +our $VERSION = '2.014'; +our @EXPORT = qw( + PEM_file2cert PEM_string2cert PEM_cert2file PEM_cert2string + PEM_file2key PEM_string2key PEM_key2file PEM_key2string + KEY_free CERT_free + KEY_create_rsa CERT_asHash CERT_create +); + +sub PEM_file2cert { + my $file = shift; + my $bio = Net::SSLeay::BIO_new_file($file,'r') or + croak "cannot read $file: $!"; + my $cert = Net::SSLeay::PEM_read_bio_X509($bio); + Net::SSLeay::BIO_free($bio); + $cert or croak "cannot parse $file as PEM X509 cert: ". + Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()); + return $cert; +} + +sub PEM_cert2file { + my ($cert,$file) = @_; + my $string = Net::SSLeay::PEM_get_string_X509($cert) + or croak("cannot get string from cert"); + open( my $fh,'>',$file ) or croak("cannot write $file: $!"); + print $fh $string; +} + +sub PEM_string2cert { + my $string = shift; + my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem()); + Net::SSLeay::BIO_write($bio,$string); + my $cert = Net::SSLeay::PEM_read_bio_X509($bio); + Net::SSLeay::BIO_free($bio); + $cert or croak "cannot parse string as PEM X509 cert: ". + Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()); + return $cert; +} + +sub PEM_cert2string { + my $cert = shift; + return Net::SSLeay::PEM_get_string_X509($cert) + || croak("cannot get string from cert"); +} + +sub PEM_file2key { + my $file = shift; + my $bio = Net::SSLeay::BIO_new_file($file,'r') or + croak "cannot read $file: $!"; + my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio); + Net::SSLeay::BIO_free($bio); + $key or croak "cannot parse $file as PEM private key: ". + Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()); + return $key; +} + +sub PEM_key2file { + my ($key,$file) = @_; + my $string = Net::SSLeay::PEM_get_string_PrivateKey($key) + or croak("cannot get string from key"); + open( my $fh,'>',$file ) or croak("cannot write $file: $!"); + print $fh $string; +} + +sub PEM_string2key { + my $string = shift; + my $bio = Net::SSLeay::BIO_new( Net::SSLeay::BIO_s_mem()); + Net::SSLeay::BIO_write($bio,$string); + my $key = Net::SSLeay::PEM_read_bio_PrivateKey($bio); + Net::SSLeay::BIO_free($bio); + $key or croak "cannot parse string as PEM private key: ". + Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error()); + return $key; +} + +sub PEM_key2string { + my $key = shift; + return Net::SSLeay::PEM_get_string_PrivateKey($key) + || croak("cannot get string from key"); +} + +sub CERT_free { + my $cert = shift or return; + Net::SSLeay::X509_free($cert); +} + +sub KEY_free { + my $key = shift or return; + Net::SSLeay::EVP_PKEY_free($key); +} + +sub KEY_create_rsa { + my $bits = shift || 2048; + my $key = Net::SSLeay::EVP_PKEY_new(); + my $rsa = Net::SSLeay::RSA_generate_key($bits, 0x10001); # 0x10001 = RSA_F4 + Net::SSLeay::EVP_PKEY_assign_RSA($key,$rsa); + return $key; +} + +if (defined &Net::SSLeay::EC_KEY_generate_key) { + push @EXPORT,'KEY_create_ec'; + *KEY_create_ec = sub { + my $curve = shift || 'prime256v1'; + 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); + return $key; + } +} + +# extract information from cert +my %gen2i = qw( OTHERNAME 0 EMAIL 1 DNS 2 X400 3 DIRNAME 4 EDIPARTY 5 URI 6 IP 7 RID 8 ); +my %i2gen = reverse %gen2i; +sub CERT_asHash { + my $cert = shift; + my $digest_name = shift || 'sha256'; + + my %hash = ( + version => Net::SSLeay::X509_get_version($cert), + not_before => _asn1t2t(Net::SSLeay::X509_get_notBefore($cert)), + not_after => _asn1t2t(Net::SSLeay::X509_get_notAfter($cert)), + serial => Net::SSLeay::P_ASN1_INTEGER_get_dec( + Net::SSLeay::X509_get_serialNumber($cert)), + signature_alg => Net::SSLeay::OBJ_obj2txt ( + Net::SSLeay::P_X509_get_signature_alg($cert)), + crl_uri => [ Net::SSLeay::P_X509_get_crl_distribution_points($cert) ], + keyusage => [ Net::SSLeay::P_X509_get_key_usage($cert) ], + extkeyusage => { + oid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,0) ], + nid => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,1) ], + sn => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,2) ], + ln => [ Net::SSLeay::P_X509_get_ext_key_usage($cert,3) ], + }, + "pubkey_digest_$digest_name" => Net::SSLeay::X509_pubkey_digest( + $cert,_digest($digest_name)), + "x509_digest_$digest_name" => Net::SSLeay::X509_digest( + $cert,_digest($digest_name)), + "fingerprint_$digest_name" => Net::SSLeay::X509_get_fingerprint( + $cert,$digest_name), + ); + + my $subj = Net::SSLeay::X509_get_subject_name($cert); + my %subj; + for ( 0..Net::SSLeay::X509_NAME_entry_count($subj)-1 ) { + my $e = Net::SSLeay::X509_NAME_get_entry($subj,$_); + my $o = Net::SSLeay::X509_NAME_ENTRY_get_object($e); + $subj{ Net::SSLeay::OBJ_obj2txt($o) } = + Net::SSLeay::P_ASN1_STRING_get( + Net::SSLeay::X509_NAME_ENTRY_get_data($e)); + } + $hash{subject} = \%subj; + + if ( my @names = Net::SSLeay::X509_get_subjectAltNames($cert) ) { + my $alt = $hash{subjectAltNames} = []; + while (my ($t,$v) = splice(@names,0,2)) { + $t = $i2gen{$t} || die "unknown type $t in subjectAltName"; + if ( $t eq 'IP' ) { + if (length($v) == 4) { + $v = join('.',unpack("CCCC",$v)); + } elsif ( length($v) == 16 ) { + my @v = unpack("nnnnnnnn",$v); + my ($best0,$last0); + for(my $i=0;$i<@v;$i++) { + if ($v[$i] == 0) { + if ($last0) { + $last0->[1] = $i; + $last0->[2]++; + $best0 = $last0 if ++$last0->[2]>$best0->[2]; + } else { + $last0 = [ $i,$i,0 ]; + $best0 ||= $last0; + } + } else { + $last0 = undef; + } + } + if ($best0) { + $v = ''; + $v .= join(':', map { sprintf( "%x",$_) } @v[0..$best0->[0]-1]) if $best0->[0]>0; + $v .= '::'; + $v .= join(':', map { sprintf( "%x",$_) } @v[$best0->[1]+1..$#v]) if $best0->[1]<$#v; + } else { + $v = join(':', map { sprintf( "%x",$_) } @v); + } + } + } + push @$alt,[$t,$v] + } + } + + my $issuer = Net::SSLeay::X509_get_issuer_name($cert); + my %issuer; + for ( 0..Net::SSLeay::X509_NAME_entry_count($issuer)-1 ) { + my $e = Net::SSLeay::X509_NAME_get_entry($issuer,$_); + my $o = Net::SSLeay::X509_NAME_ENTRY_get_object($e); + $issuer{ Net::SSLeay::OBJ_obj2txt($o) } = + Net::SSLeay::P_ASN1_STRING_get( + Net::SSLeay::X509_NAME_ENTRY_get_data($e)); + } + $hash{issuer} = \%issuer; + + my @ext; + for( 0..Net::SSLeay::X509_get_ext_count($cert)-1 ) { + my $e = Net::SSLeay::X509_get_ext($cert,$_); + my $o = Net::SSLeay::X509_EXTENSION_get_object($e); + my $nid = Net::SSLeay::OBJ_obj2nid($o); + push @ext, { + oid => Net::SSLeay::OBJ_obj2txt($o), + nid => ( $nid > 0 ) ? $nid : undef, + sn => ( $nid > 0 ) ? Net::SSLeay::OBJ_nid2sn($nid) : undef, + critical => Net::SSLeay::X509_EXTENSION_get_critical($e), + data => Net::SSLeay::X509V3_EXT_print($e), + } + } + $hash{ext} = \@ext; + + if ( defined(&Net::SSLeay::P_X509_get_ocsp_uri)) { + $hash{ocsp_uri} = [ Net::SSLeay::P_X509_get_ocsp_uri($cert) ]; + } else { + $hash{ocsp_uri} = []; + for( @ext ) { + $_->{sn} or next; + $_->{sn} eq 'authorityInfoAccess' or next; + push @{ $hash{ocsp_uri}}, $_->{data} =~m{\bOCSP - URI:(\S+)}g; + } + } + + return \%hash; +} + +sub CERT_create { + my %args = @_%2 ? %{ shift() } : @_; + + my $cert = Net::SSLeay::X509_new(); + my $digest_name = delete $args{digest} || 'sha256'; + + Net::SSLeay::ASN1_INTEGER_set( + Net::SSLeay::X509_get_serialNumber($cert), + delete $args{serial} || rand(2**32), + ); + + # version default to 2 (V3) + Net::SSLeay::X509_set_version($cert, + delete $args{version} || 2 ); + + # not_before default to now + Net::SSLeay::ASN1_TIME_set( + Net::SSLeay::X509_get_notBefore($cert), + delete $args{not_before} || time() + ); + + # not_after default to now+365 days + Net::SSLeay::ASN1_TIME_set( + Net::SSLeay::X509_get_notAfter($cert), + delete $args{not_after} || time() + 365*86400 + ); + + # set subject + my $subj_e = Net::SSLeay::X509_get_subject_name($cert); + my $subj = delete $args{subject} || { + organizationName => 'IO::Socket::SSL', + commonName => 'IO::Socket::SSL Test' + }; + while ( my ($k,$v) = each %$subj ) { + # Not everything we get is nice - try with MBSTRING_UTF8 first and if it + # fails try V_ASN1_T61STRING and finally V_ASN1_OCTET_STRING + Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,0x1000,$v,-1,0) + or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,20,$v,-1,0) + or Net::SSLeay::X509_NAME_add_entry_by_txt($subj_e,$k,4,$v,-1,0) + or croak("failed to add entry for $k - ". + Net::SSLeay::ERR_error_string(Net::SSLeay::ERR_get_error())); + } + + my @ext = ( + &Net::SSLeay::NID_subject_key_identifier => 'hash', + &Net::SSLeay::NID_authority_key_identifier => 'keyid', + ); + if ( my $altsubj = delete $args{subjectAltNames} ) { + push @ext, + &Net::SSLeay::NID_subject_alt_name => + join(',', map { "$_->[0]:$_->[1]" } @$altsubj) + } + + my $key = delete $args{key} || KEY_create_rsa(); + Net::SSLeay::X509_set_pubkey($cert,$key); + + my $is = delete $args{issuer}; + my $issuer_cert = delete $args{issuer_cert} || $is && $is->[0] || $cert; + my $issuer_key = delete $args{issuer_key} || $is && $is->[1] || $key; + + my %purpose; + if (my $p = delete $args{purpose}) { + if (!ref($p)) { + $purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0 + while $p =~m{([+-]?)(\w+)}g; + } elsif (ref($p) eq 'ARRAY') { + for(@$p) { + m{^([+-]?)(\w+)$} or die "invalid entry in purpose: $_"; + $purpose{lc($2)} = (!$1 || $1 eq '+') ? 1:0 + } + } else { + while( my ($k,$v) = each %$p) { + $purpose{lc($k)} = ($v && $v ne '-')?1:0; + } + } + } + if (delete $args{CA}) { + # add defaults for CA + %purpose = ( + ca => 1, sslca => 1, emailca => 1, objca => 1, + %purpose + ); + } + if (!%purpose) { + %purpose = (server => 1, client => 1); + } + + my (%key_usage,%ext_key_usage,%cert_type,%basic_constraints); + + my %dS = ( digitalSignature => \%key_usage ); + my %kE = ( keyEncipherment => \%key_usage ); + my %CA = ( 'CA:TRUE' => \%basic_constraints, %dS, keyCertSign => \%key_usage ); + my @disable; + for( + [ client => { %dS, %kE, clientAuth => \%ext_key_usage, client => \%cert_type } ], + [ server => { %dS, %kE, serverAuth => \%ext_key_usage, server => \%cert_type } ], + [ email => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ], + [ objsign => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ], + + [ CA => { %CA }], + [ sslCA => { %CA, sslCA => \%cert_type }], + [ emailCA => { %CA, emailCA => \%cert_type }], + [ objCA => { %CA, objCA => \%cert_type }], + + [ emailProtection => { %dS, %kE, emailProtection => \%ext_key_usage, email => \%cert_type } ], + [ codeSigning => { %dS, %kE, codeSigning => \%ext_key_usage, objsign => \%cert_type } ], + + [ timeStamping => { timeStamping => \%ext_key_usage } ], + [ digitalSignature => { digitalSignature => \%key_usage } ], + [ nonRepudiation => { nonRepudiation => \%key_usage } ], + [ keyEncipherment => { keyEncipherment => \%key_usage } ], + [ dataEncipherment => { dataEncipherment => \%key_usage } ], + [ keyAgreement => { keyAgreement => \%key_usage } ], + [ keyCertSign => { keyCertSign => \%key_usage } ], + [ cRLSign => { cRLSign => \%key_usage } ], + [ encipherOnly => { encipherOnly => \%key_usage } ], + [ decipherOnly => { decipherOnly => \%key_usage } ], + [ clientAuth => { clientAuth => \%ext_key_usage } ], + [ serverAuth => { serverAuth => \%ext_key_usage } ], + ) { + exists $purpose{lc($_->[0])} or next; + if (delete $purpose{lc($_->[0])}) { + while (my($k,$h) = each %{$_->[1]}) { + $h->{$k} = 1; + } + } else { + push @disable, $_->[1]; + } + } + die "unknown purpose ".join(",",keys %purpose) if %purpose; + for(@disable) { + while (my($k,$h) = each %$_) { + delete $h->{$k}; + } + } + + if (%basic_constraints) { + push @ext,&Net::SSLeay::NID_basic_constraints, + => join(",",'critical', sort keys %basic_constraints); + } else { + push @ext, &Net::SSLeay::NID_basic_constraints => 'critical,CA:FALSE'; + } + push @ext,&Net::SSLeay::NID_key_usage + => join(",",'critical', sort keys %key_usage) if %key_usage; + push @ext,&Net::SSLeay::NID_netscape_cert_type + => join(",",sort keys %cert_type) if %cert_type; + push @ext,&Net::SSLeay::NID_ext_key_usage + => join(",",sort keys %ext_key_usage) if %ext_key_usage; + Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, @ext); + + my %have_ext; + for(my $i=0;$i<@ext;$i+=2) { + $have_ext{ $ext[$i] }++ + } + for my $ext (@{ $args{ext} || [] }) { + my $nid = $ext->{nid} + || $ext->{sn} && Net::SSLeay::OBJ_sn2nid($ext->{sn}) + || croak "cannot determine NID of extension"; + $have_ext{$nid} and next; + my $val = $ext->{data}; + if ($nid == 177) { + # authorityInfoAccess: + # OpenSSL i2v does not output the same way as expected by i2v :( + for (split(/\n/,$val)) { + s{ - }{;}; # "OCSP - URI:..." -> "OCSP;URI:..." + $_ = "critical,$_" if $ext->{critical}; + Net::SSLeay::P_X509_add_extensions($cert,$issuer_cert,$nid,$_); + } + } else { + $val = "critical,$val" if $ext->{critical}; + Net::SSLeay::P_X509_add_extensions($cert, $issuer_cert, $nid, $val); + } + } + + Net::SSLeay::X509_set_issuer_name($cert, + Net::SSLeay::X509_get_subject_name($issuer_cert)); + Net::SSLeay::X509_sign($cert,$issuer_key,_digest($digest_name)); + + return ($cert,$key); +} + + + +if ( defined &Net::SSLeay::ASN1_TIME_timet ) { + *_asn1t2t = \&Net::SSLeay::ASN1_TIME_timet +} else { + require Time::Local; + my %mon2i = qw( + Jan 0 Feb 1 Mar 2 Apr 3 May 4 Jun 5 + Jul 6 Aug 7 Sep 8 Oct 9 Nov 10 Dec 11 + ); + *_asn1t2t = sub { + my $t = Net::SSLeay::P_ASN1_TIME_put2string( shift ); + my ($mon,$d,$h,$m,$s,$y,$tz) = split(/[\s:]+/,$t); + defined( $mon = $mon2i{$mon} ) or die "invalid month in $t"; + $tz ||= $y =~s{^(\d+)([A-Z]\S*)}{$1} && $2; + if ( ! $tz ) { + return Time::Local::timelocal($s,$m,$h,$d,$mon,$y) + } elsif ( $tz eq 'GMT' ) { + return Time::Local::timegm($s,$m,$h,$d,$mon,$y) + } else { + die "unexpected TZ $tz from ASN1_TIME_print"; + } + } +} + +{ + my %digest; + sub _digest { + my $digest_name = shift; + return $digest{$digest_name} ||= do { + Net::SSLeay::SSLeay_add_ssl_algorithms(); + Net::SSLeay::EVP_get_digestbyname($digest_name) + or die "Digest algorithm $digest_name is not available"; + }; + } +} + + +1; + +__END__ + +=head1 NAME + +IO::Socket::SSL::Utils -- loading, storing, creating certificates and keys + +=head1 SYNOPSIS + + use IO::Socket::SSL::Utils; + my $cert = PEM_file2cert('cert.pem'); # load certificate from file + my $string = PEM_cert2string($cert); # convert certificate to PEM string + CERT_free($cert); # free memory within OpenSSL + + my $key = KEY_create_rsa(2048); # create new 2048-bit RSA key + PEM_string2file($key,"key.pem"); # and write it to file + KEY_free($key); # free memory within OpenSSL + + +=head1 DESCRIPTION + +This module provides various utility functions to work with certificates and +private keys, shielding some of the complexity of the underlying Net::SSLeay and +OpenSSL. + +=head1 FUNCTIONS + +=over 4 + +=item * + +Functions converting between string or file and certificates and keys. +They croak if the operation cannot be completed. + +=over 8 + +=item PEM_file2cert(file) -> cert + +=item PEM_cert2file(cert,file) + +=item PEM_string2cert(string) -> cert + +=item PEM_cert2string(cert) -> string + +=item PEM_file2key(file) -> key + +=item PEM_key2file(key,file) + +=item PEM_string2key(string) -> key + +=item PEM_key2string(key) -> string + +=back + +=item * + +Functions for cleaning up. +Each loaded or created cert and key must be freed to not leak memory. + +=over 8 + +=item CERT_free(cert) + +=item KEY_free(key) + +=back + +=item * KEY_create_rsa(bits) -> key + +Creates an RSA key pair, bits defaults to 2048. + +=item * KEY_create_ec(curve) -> key + +Creates an EC key, curve defaults to C. + +=item * CERT_asHash(cert,[digest_algo]) -> hash + +Extracts the information from the certificate into a hash and uses the given +digest_algo (default: SHA-256) to determine digest of pubkey and cert. +The resulting hash contains: + +=over 8 + +=item subject + +Hash with the parts of the subject, e.g. commonName, countryName, +organizationName, stateOrProvinceName, localityName. + +=item subjectAltNames + +Array with list of alternative names. Each entry in the list is of +C<[type,value]>, where C can be OTHERNAME, EMAIL, DNS, X400, DIRNAME, +EDIPARTY, URI, IP or RID. + +=item issuer + +Hash with the parts of the issuer, e.g. commonName, countryName, +organizationName, stateOrProvinceName, localityName. + +=item not_before, not_after + +The time frame, where the certificate is valid, as time_t, e.g. can be converted +with localtime or similar functions. + +=item serial + +The serial number + +=item crl_uri + +List of URIs for CRL distribution. + +=item ocsp_uri + +List of URIs for revocation checking using OCSP. + +=item keyusage + +List of keyUsage information in the certificate. + +=item extkeyusage + +List of extended key usage information from the certificate. Each entry in +this list consists of a hash with oid, nid, ln and sn. + +=item pubkey_digest_xxx + +Binary digest of the pubkey using the given digest algorithm, e.g. +pubkey_digest_sha256 if (the default) SHA-256 was used. + +=item x509_digest_xxx + +Binary digest of the X.509 certificate using the given digest algorithm, e.g. +x509_digest_sha256 if (the default) SHA-256 was used. + +=item fingerprint_xxx + +Fingerprint of the certificate using the given digest algorithm, e.g. +fingerprint_sha256 if (the default) SHA-256 was used. Contrary to digest_* this +is an ASCII string with a list if hexadecimal numbers, e.g. +"73:59:75:5C:6D...". + +=item signature_alg + +Algorithm used to sign certificate, e.g. C. + +=item ext + +List of extensions. +Each entry in the list is a hash with oid, nid, sn, critical flag (boolean) and +data (string representation given by X509V3_EXT_print). + +=item version + +Certificate version, usually 2 (x509v3) + +=back + +=item * CERT_create(hash) -> (cert,key) + +Creates a certificate based on the given hash. +If the issuer is not specified the certificate will be self-signed. +The following keys can be given: + +=over 8 + +=item subject + +Hash with the parts of the subject, e.g. commonName, countryName, ... as +described in C. +Default points to IO::Socket::SSL. + +=item not_before + +A time_t value when the certificate starts to be valid. Defaults to current +time. + +=item not_after + +A time_t value when the certificate ends to be valid. Defaults to current +time plus one 365 days. + +=item serial + +The serial number. If not given a random number will be used. + +=item version + +The version of the certificate, default 2 (x509v3). + +=item CA true|false + +If true declare certificate as CA, defaults to false. + +=item purpose string|array|hash + +Set the purpose of the certificate. +The different purposes can be given as a string separated by non-word character, +as array or hash. With string or array each purpose can be prefixed with '+' +(enable) or '-' (disable) and same can be done with the value when given as a +hash. By default enabling the purpose is assumed. + +If the CA option is given and true the defaults "ca,sslca,emailca,objca" are +assumed, but can be overridden with explicit purpose. +If the CA option is given and false the defaults "server,client" are assumed. +If no CA option and no purpose is given it defaults to "server,client". + +Purpose affects basicConstraints, keyUsage, extKeyUsage and netscapeCertType. +The following purposes are defined (case is not important): + + client + server + email + objsign + + CA + sslCA + emailCA + objCA + + emailProtection + codeSigning + timeStamping + + digitalSignature + nonRepudiation + keyEncipherment + dataEncipherment + keyAgreement + keyCertSign + cRLSign + encipherOnly + decipherOnly + +Examples: + + # root-CA for SSL certificates + purpose => 'sslCA' # or CA => 1 + + # server certificate and CA (typically self-signed) + purpose => 'sslCA,server' + + # client certificate + purpose => 'client', + + +=item ext [{ sn => .., data => ... }, ... ] + +List of extensions. The type of the extension can be specified as name with +C or as NID with C and the data with C. These data must be in the +same syntax as expected within openssl.cnf, e.g. something like +C. Additionally the critical flag can be set with +C 1>. + +=item key key + +use given key as key for certificate, otherwise a new one will be generated and +returned + +=item issuer_cert cert + +set issuer for new certificate + +=item issuer_key key + +sign new certificate with given key + +=item issuer [ cert, key ] + +Instead of giving issuer_key and issuer_cert as separate arguments they can be +given both together. + +=item digest algorithm + +specify the algorithm used to sign the certificate, default SHA-256. + +=back + +=back + +=head1 AUTHOR + +Steffen Ullrich diff --git a/lib/lib/IO/Socket/Socks.pm b/lib/lib/IO/Socket/Socks.pm new file mode 100644 index 0000000..7f6d0dd --- /dev/null +++ b/lib/lib/IO/Socket/Socks.pm @@ -0,0 +1,2606 @@ +package IO::Socket::Socks; + +use strict; +use IO::Select; +use Socket; +use Errno qw(EWOULDBLOCK EAGAIN EINPROGRESS ETIMEDOUT ECONNABORTED); +use Carp; +use vars qw( $SOCKET_CLASS @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $SOCKS_ERROR $SOCKS5_RESOLVE $SOCKS4_RESOLVE $SOCKS_DEBUG %CODES ); +require Exporter; + +$VERSION = '0.74'; + +use constant { + SOCKS_WANT_READ => 20, + SOCKS_WANT_WRITE => 21, + ESOCKSPROTO => exists &Errno::EPROTO ? &Errno::EPROTO : 7000, +}; + +@ISA = ('Exporter', $SOCKET_CLASS||''); + +tie $SOCKET_CLASS, 'IO::Socket::Socks::SocketClassVar', $SOCKET_CLASS; +unless ($SOCKET_CLASS) { + if (eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.36) }) { + $SOCKET_CLASS = 'IO::Socket::IP'; + } + else { + $SOCKET_CLASS = 'IO::Socket::INET'; + } +} + +@EXPORT = qw( $SOCKS_ERROR SOCKS_WANT_READ SOCKS_WANT_WRITE ESOCKSPROTO ); +@EXPORT_OK = qw( + SOCKS5_VER + SOCKS4_VER + ADDR_IPV4 + ADDR_DOMAINNAME + ADDR_IPV6 + CMD_CONNECT + CMD_BIND + CMD_UDPASSOC + AUTHMECH_ANON + AUTHMECH_USERPASS + AUTHMECH_INVALID + AUTHREPLY_SUCCESS + AUTHREPLY_FAILURE + ISS_UNKNOWN_ADDRESS + ISS_BAD_VERSION + ISS_CANT_RESOLVE + REPLY_SUCCESS + REPLY_GENERAL_FAILURE + REPLY_CONN_NOT_ALLOWED + REPLY_NETWORK_UNREACHABLE + REPLY_HOST_UNREACHABLE + REPLY_CONN_REFUSED + REPLY_TTL_EXPIRED + REPLY_CMD_NOT_SUPPORTED + REPLY_ADDR_NOT_SUPPORTED + REQUEST_GRANTED + REQUEST_FAILED + REQUEST_REJECTED_IDENTD + REQUEST_REJECTED_USERID +); +%EXPORT_TAGS = (constants => [ 'SOCKS_WANT_READ', 'SOCKS_WANT_WRITE', @EXPORT_OK ]); +tie $SOCKS_ERROR, 'IO::Socket::Socks::ReadOnlyVar', IO::Socket::Socks::Error->new(); + +$SOCKS5_RESOLVE = 1; +$SOCKS4_RESOLVE = 0; +$SOCKS_DEBUG = $ENV{SOCKS_DEBUG}; + +use constant { + SOCKS5_VER => 5, + SOCKS4_VER => 4, + + ADDR_IPV4 => 1, + ADDR_DOMAINNAME => 3, + ADDR_IPV6 => 4, + + CMD_CONNECT => 1, + CMD_BIND => 2, + CMD_UDPASSOC => 3, + + AUTHMECH_ANON => 0, + + #AUTHMECH_GSSAPI => 1, + AUTHMECH_USERPASS => 2, + AUTHMECH_INVALID => 255, + + AUTHREPLY_SUCCESS => 0, + AUTHREPLY_FAILURE => 10, # to not intersect with other socks5 constants + + ISS_UNKNOWN_ADDRESS => 500, + ISS_BAD_VERSION => 501, + ISS_CANT_RESOLVE => 502, +}; + +$CODES{AUTHMECH}->[AUTHMECH_INVALID] = "No valid auth mechanisms"; +$CODES{AUTHREPLY}->[AUTHREPLY_FAILURE] = "Failed to authenticate"; + +# socks5 +use constant { + REPLY_SUCCESS => 0, + REPLY_GENERAL_FAILURE => 1, + REPLY_CONN_NOT_ALLOWED => 2, + REPLY_NETWORK_UNREACHABLE => 3, + REPLY_HOST_UNREACHABLE => 4, + REPLY_CONN_REFUSED => 5, + REPLY_TTL_EXPIRED => 6, + REPLY_CMD_NOT_SUPPORTED => 7, + REPLY_ADDR_NOT_SUPPORTED => 8, +}; + +$CODES{REPLY}->{&REPLY_SUCCESS} = "Success"; +$CODES{REPLY}->{&REPLY_GENERAL_FAILURE} = "General failure"; +$CODES{REPLY}->{&REPLY_CONN_NOT_ALLOWED} = "Not allowed"; +$CODES{REPLY}->{&REPLY_NETWORK_UNREACHABLE} = "Network unreachable"; +$CODES{REPLY}->{&REPLY_HOST_UNREACHABLE} = "Host unreachable"; +$CODES{REPLY}->{&REPLY_CONN_REFUSED} = "Connection refused"; +$CODES{REPLY}->{&REPLY_TTL_EXPIRED} = "TTL expired"; +$CODES{REPLY}->{&REPLY_CMD_NOT_SUPPORTED} = "Command not supported"; +$CODES{REPLY}->{&REPLY_ADDR_NOT_SUPPORTED} = "Address not supported"; + +# socks4 +use constant { + REQUEST_GRANTED => 90, + REQUEST_FAILED => 91, + REQUEST_REJECTED_IDENTD => 92, + REQUEST_REJECTED_USERID => 93, +}; + +$CODES{REPLY}->{&REQUEST_GRANTED} = "request granted"; +$CODES{REPLY}->{&REQUEST_FAILED} = "request rejected or failed"; +$CODES{REPLY}->{&REQUEST_REJECTED_IDENTD} = "request rejected because SOCKS server cannot connect to identd on the client"; +$CODES{REPLY}->{&REQUEST_REJECTED_USERID} = "request rejected because the client program and identd report different user-ids"; + +# queue +use constant { + Q_SUB => 0, + Q_ARGS => 1, + Q_BUF => 2, + Q_READS => 3, + Q_SENDS => 4, + Q_OKCB => 5, + Q_DEBUGS => 6, +}; + +our $CAN_CHANGE_SOCKET = 1; +sub new_from_fd { + my ($class, $sock, %arg) = @_; + + bless $sock, $class; + + $sock->autoflush(1); + if (exists $arg{Timeout}) { + ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; + } + + scalar(%arg) or return $sock; + + # do not allow to create new socket + local $CAN_CHANGE_SOCKET = 0; + $sock->configure(\%arg) || $SOCKS_ERROR == SOCKS_WANT_WRITE || return; + $sock; +} + +*new_from_socket = \&new_from_fd; + +sub start_SOCKS { + my ($class, $sock, %arg) = @_; + + bless $sock, $class; + + $sock->autoflush(1); + if (exists $arg{Timeout}) { + ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; + } + + ${*$sock}->{SOCKS} = { RequireAuth => 0 }; + + $SOCKS_ERROR->set(); + return $sock->command(%arg) ? $sock : undef; +} + +sub socket { + my $self = shift; + + return $self unless $CAN_CHANGE_SOCKET; + return $self->SUPER::socket(@_); +} + +sub configure { + my $self = shift; + my $args = shift; + + $self->_configure($args) + or return; + + ${*$self}->{SOCKS}->{ProxyAddr} = ( + exists($args->{ProxyAddr}) + ? delete($args->{ProxyAddr}) + : undef + ); + + ${*$self}->{SOCKS}->{ProxyPort} = ( + exists($args->{ProxyPort}) + ? delete($args->{ProxyPort}) + : undef + ); + + ${*$self}->{SOCKS}->{COMMAND} = []; + + if (exists($args->{Listen})) { + $args->{LocalAddr} = ${*$self}->{SOCKS}->{ProxyAddr}; + $args->{LocalPort} = ${*$self}->{SOCKS}->{ProxyPort}; + $args->{Reuse} = 1; + ${*$self}->{SOCKS}->{Listen} = 1; + } + elsif (${*$self}->{SOCKS}->{ProxyAddr} && ${*$self}->{SOCKS}->{ProxyPort}) { + $args->{PeerAddr} = ${*$self}->{SOCKS}->{ProxyAddr}; + $args->{PeerPort} = ${*$self}->{SOCKS}->{ProxyPort}; + } + + unless (defined ${*$self}->{SOCKS}->{TCP}) { + $args->{Proto} = "tcp"; + $args->{Type} = SOCK_STREAM; + } + elsif (!defined $args->{Proto}) { + $args->{Proto} = "udp"; + $args->{Type} = SOCK_DGRAM; + } + + $SOCKS_ERROR->set(); + unless ($self->SUPER::configure($args)) { + if ($SOCKS_ERROR == undef) { + $SOCKS_ERROR->set($!, $@); + } + return; + } + + return $self; +} + +sub _configure { + my $self = shift; + my $args = shift; + + ${*$self}->{SOCKS}->{Version} = ( + exists($args->{SocksVersion}) + ? ( + $args->{SocksVersion} == 4 + || $args->{SocksVersion} == 5 + || ( exists $args->{Listen} + && ref $args->{SocksVersion} eq 'ARRAY' + && _validate_multi_version($args->{SocksVersion})) + ? delete($args->{SocksVersion}) + : croak("Unsupported socks version specified. Should be 4 or 5") + ) + : 5 + ); + + ${*$self}->{SOCKS}->{AuthType} = ( + exists($args->{AuthType}) + ? delete($args->{AuthType}) + : "none" + ); + + ${*$self}->{SOCKS}->{RequireAuth} = ( + exists($args->{RequireAuth}) + ? delete($args->{RequireAuth}) + : 0 + ); + + ${*$self}->{SOCKS}->{UserAuth} = ( + exists($args->{UserAuth}) + ? delete($args->{UserAuth}) + : undef + ); + + ${*$self}->{SOCKS}->{Username} = ( + exists($args->{Username}) ? delete($args->{Username}) + : ( + (${*$self}->{SOCKS}->{AuthType} eq "none") ? undef + : croak("If you set AuthType to userpass, then you must provide a username.") + ) + ); + + ${*$self}->{SOCKS}->{Password} = ( + exists($args->{Password}) ? delete($args->{Password}) + : ( + (${*$self}->{SOCKS}->{AuthType} eq "none") ? undef + : croak("If you set AuthType to userpass, then you must provide a password.") + ) + ); + + ${*$self}->{SOCKS}->{Debug} = ( + exists($args->{SocksDebug}) + ? delete($args->{SocksDebug}) + : $SOCKS_DEBUG + ); + + ${*$self}->{SOCKS}->{Resolve} = ( + exists($args->{SocksResolve}) + ? delete($args->{SocksResolve}) + : undef + ); + + ${*$self}->{SOCKS}->{AuthMethods} = [ 0, 0, 0 ]; + ${*$self}->{SOCKS}->{AuthMethods}->[AUTHMECH_ANON] = 1 + unless ${*$self}->{SOCKS}->{RequireAuth}; + + #${*$self}->{SOCKS}->{AuthMethods}->[AUTHMECH_GSSAPI] = 1 + # if (${*$self}->{SOCKS}->{AuthType} eq "gssapi"); + ${*$self}->{SOCKS}->{AuthMethods}->[AUTHMECH_USERPASS] = 1 + if ( + (!exists($args->{Listen}) && (${*$self}->{SOCKS}->{AuthType} eq "userpass")) + || (exists($args->{Listen}) + && defined(${*$self}->{SOCKS}->{UserAuth})) + ); + + if (exists($args->{BindAddr}) && exists($args->{BindPort})) { + ${*$self}->{SOCKS}->{CmdAddr} = delete($args->{BindAddr}); + ${*$self}->{SOCKS}->{CmdPort} = delete($args->{BindPort}); + ${*$self}->{SOCKS}->{Bind} = 1; + } + elsif (exists($args->{UdpAddr}) && exists($args->{UdpPort})) { + if (${*$self}->{SOCKS}->{Version} == 4) { + croak("Socks v4 doesn't support UDP association"); + } + ${*$self}->{SOCKS}->{CmdAddr} = delete($args->{UdpAddr}); + ${*$self}->{SOCKS}->{CmdPort} = delete($args->{UdpPort}); + ${*$self}->{SOCKS}->{TCP} = __PACKAGE__->new( # TCP backend for UDP socket + Timeout => $args->{Timeout}, + Proto => 'tcp', + PeerAddr => $args->{ProxyAddr}, + PeerPort => $args->{ProxyPort}, + exists $args->{Blocking} ? + (Blocking => $args->{Blocking}) : () + ) or return; + } + elsif (exists($args->{ConnectAddr}) && exists($args->{ConnectPort})) { + ${*$self}->{SOCKS}->{CmdAddr} = delete($args->{ConnectAddr}); + ${*$self}->{SOCKS}->{CmdPort} = delete($args->{ConnectPort}); + } + + return 1; +} + +sub version { + my $self = shift; + return ${*$self}->{SOCKS}->{Version}; +} + +sub connect { + my $self = shift; + + croak("Undefined IO::Socket::Socks object passed to connect.") + unless defined($self); + + my $ok = + defined(${*$self}->{SOCKS}->{TCP}) + ? 1 + : $self->SUPER::connect(@_); + + if (($! == EINPROGRESS || $! == EWOULDBLOCK) && + (${*$self}->{SOCKS}->{TCP} || $self)->blocking == 0) { + ${*$self}->{SOCKS}->{_in_progress} = 1; + $SOCKS_ERROR->set(SOCKS_WANT_WRITE, 'Socks want write'); + } + elsif (!$ok) { + $SOCKS_ERROR->set($!, $@ = "Connection to proxy failed: $!"); + return; + } + else { + # connect() may be called several times by SUPER class + $SOCKS_ERROR->set(); + } + + return $ok # proxy address was not specified, so do not make socks handshake + unless ${*$self}->{SOCKS}->{ProxyAddr} && ${*$self}->{SOCKS}->{ProxyPort}; + + $self->_connect(); +} + +sub _connect { + my $self = shift; + ${*$self}->{SOCKS}->{ready} = 0; + + if (${*$self}->{SOCKS}->{Version} == 4) { + ${*$self}->{SOCKS}->{queue} = [ + + # [sub, [@args], buf, [@reads], sends_cnt] + [ '_socks4_connect_command', [ ${*$self}->{SOCKS}->{Bind} ? CMD_BIND : CMD_CONNECT ], undef, [], 0 ], + [ '_socks4_connect_reply', [], undef, [], 0 ] + ]; + } + else { + ${*$self}->{SOCKS}->{queue} = [ + [ '_socks5_connect', [], undef, [], 0 ], + [ '_socks5_connect_if_auth', [], undef, [], 0 ], + [ + '_socks5_connect_command', + [ + ${*$self}->{SOCKS}->{Bind} ? CMD_BIND + : ${*$self}->{SOCKS}->{TCP} ? CMD_UDPASSOC + : CMD_CONNECT + ], + undef, + [], + 0 + ], + [ '_socks5_connect_reply', [], undef, [], 0 ] + ]; + } + + if (delete ${*$self}->{SOCKS}->{_in_progress}) { # socket connection not estabilished yet + if ($self->isa('IO::Socket::IP')) { + # IO::Socket::IP requires multiple connect calls + # when performing non-blocking multi-homed connect + unshift @{ ${*$self}->{SOCKS}->{queue} }, ['_socket_connect', [], undef, [], 0]; + + # IO::Socket::IP::connect() returns false for non-blocking connections in progress + # IO::Socket::INET::connect() returns true for non-blocking connections in progress + # LOL + return; # connect() return value + } + } + else { + defined($self->_run_queue()) + or return; + } + + return $self; +} + +sub _socket_connect { + my $self = shift; + my $sock = ${*$self}->{SOCKS}->{TCP} || $self; + + return 1 if $sock->SUPER::connect(); + if ($! == EINPROGRESS || $! == EWOULDBLOCK) { + $SOCKS_ERROR->set(SOCKS_WANT_WRITE, 'Socks want write'); + return -1; + } + + $SOCKS_ERROR->set($!, $@ = "Connection to proxy failed: $!"); + return; +} + +sub _run_queue { + # run tasks from queue, return undef on error, -1 if one of the task + # returned not completed because of the possible blocking on network operation + my $self = shift; + + my $retval; + my $sub; + + while (my $elt = ${*$self}->{SOCKS}->{queue}[0]) { + $sub = $elt->[Q_SUB]; + $retval = $self->$sub(@{ $elt->[Q_ARGS] }); + unless (defined $retval) { + ${*$self}->{SOCKS}->{queue} = []; + ${*$self}->{SOCKS}->{queue_results} = {}; + last; + } + + last if ($retval == -1); + ${*$self}->{SOCKS}->{queue_results}{$sub} = $retval; + if ($elt->[Q_OKCB]) { + $elt->[Q_OKCB]->(); + } + shift @{ ${*$self}->{SOCKS}->{queue} }; + } + + if (defined($retval) && !@{ ${*$self}->{SOCKS}->{queue} }) { + ${*$self}->{SOCKS}->{queue_results} = {}; + ${*$self}->{SOCKS}->{ready} = $SOCKS_ERROR ? 0 : 1; + } + + return $retval; +} + +sub ready { + my $self = shift; + + $self->_run_queue(); + return ${*$self}->{SOCKS}->{ready}; +} + +sub _socks5_connect { + my $self = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + my $sock = + defined(${*$self}->{SOCKS}->{TCP}) + ? ${*$self}->{SOCKS}->{TCP} + : $self; + + #-------------------------------------------------------------------------- + # Send the auth mechanisms + #-------------------------------------------------------------------------- + # +----+----------+----------+ + # |VER | NMETHODS | METHODS | + # +----+----------+----------+ + # | 1 | 1 | 1 to 255 | + # +----+----------+----------+ + + my $nmethods = 0; + my $methods; + foreach my $method (0 .. $#{ ${*$self}->{SOCKS}->{AuthMethods} }) { + if (${*$self}->{SOCKS}->{AuthMethods}->[$method] == 1) { + $methods .= pack('C', $method); + $nmethods++; + } + } + + my $reply; + $reply = $sock->_socks_send(pack('CCa*', SOCKS5_VER, $nmethods, $methods), ++$sends) + or return _fail($reply); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => SOCKS5_VER, + nmethods => $nmethods, + methods => join('', unpack("C$nmethods", $methods)) + ); + $debug->show('Client Send: '); + } + + #-------------------------------------------------------------------------- + # Read the reply + #-------------------------------------------------------------------------- + # +----+--------+ + # |VER | METHOD | + # +----+--------+ + # | 1 | 1 | + # +----+--------+ + + $reply = $sock->_socks_read(2, ++$reads) + or return _fail($reply); + + my ($version, $auth_method) = unpack('CC', $reply); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => $version, + method => $auth_method + ); + $debug->show('Client Recv: '); + } + + if ($auth_method == AUTHMECH_INVALID) { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(AUTHMECH_INVALID, $@ = $CODES{AUTHMECH}->[$auth_method]); + return; + } + + return $auth_method; +} + +sub _socks5_connect_if_auth { + my $self = shift; + if (${*$self}->{SOCKS}->{queue_results}{'_socks5_connect'} != AUTHMECH_ANON) { + unshift @{ ${*$self}->{SOCKS}->{queue} }, [ '_socks5_connect_auth', [], undef, [], 0 ]; + (${*$self}->{SOCKS}->{queue}[0], ${*$self}->{SOCKS}->{queue}[1]) = (${*$self}->{SOCKS}->{queue}[1], ${*$self}->{SOCKS}->{queue}[0]); + } + + 1; +} + +sub _socks5_connect_auth { + # rfc1929 + my $self = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + my $sock = + defined(${*$self}->{SOCKS}->{TCP}) + ? ${*$self}->{SOCKS}->{TCP} + : $self; + + #-------------------------------------------------------------------------- + # Send the auth + #-------------------------------------------------------------------------- + # +----+------+----------+------+----------+ + # |VER | ULEN | UNAME | PLEN | PASSWD | + # +----+------+----------+------+----------+ + # | 1 | 1 | 1 to 255 | 1 | 1 to 255 | + # +----+------+----------+------+----------+ + + my $uname = ${*$self}->{SOCKS}->{Username}; + my $passwd = ${*$self}->{SOCKS}->{Password}; + my $ulen = length($uname); + my $plen = length($passwd); + my $reply; + $reply = $sock->_socks_send(pack("CCa${ulen}Ca*", 1, $ulen, $uname, $plen, $passwd), ++$sends) + or return _fail($reply); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => 1, + ulen => $ulen, + uname => $uname, + plen => $plen, + passwd => $passwd + ); + $debug->show('Client Send: '); + } + + #-------------------------------------------------------------------------- + # Read the reply + #-------------------------------------------------------------------------- + # +----+--------+ + # |VER | STATUS | + # +----+--------+ + # | 1 | 1 | + # +----+--------+ + + $reply = $sock->_socks_read(2, ++$reads) + or return _fail($reply); + + my ($ver, $status) = unpack('CC', $reply); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => $ver, + status => $status + ); + $debug->show('Client Recv: '); + } + + if ($status != AUTHREPLY_SUCCESS) { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(AUTHREPLY_FAILURE, $@ = "Authentication failed with SOCKS5 proxy"); + return; + } + + return 1; +} + +sub _socks5_connect_command { + my $self = shift; + my $command = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + my $resolve = defined(${*$self}->{SOCKS}->{Resolve}) ? ${*$self}->{SOCKS}->{Resolve} : $SOCKS5_RESOLVE; + my $sock = + defined(${*$self}->{SOCKS}->{TCP}) + ? ${*$self}->{SOCKS}->{TCP} + : $self; + + #-------------------------------------------------------------------------- + # Send the command + #-------------------------------------------------------------------------- + # +----+-----+-------+------+----------+----------+ + # |VER | CMD | RSV | ATYP | DST.ADDR | DST.PORT | + # +----+-----+-------+------+----------+----------+ + # | 1 | 1 | X'00' | 1 | Variable | 2 | + # +----+-----+-------+------+----------+----------+ + + my ($atyp, $dstaddr) = $resolve ? (ADDR_DOMAINNAME, ${*$self}->{SOCKS}->{CmdAddr}) : _resolve(${*$self}->{SOCKS}->{CmdAddr}) + or $SOCKS_ERROR->set(ISS_CANT_RESOLVE, $@ = "Can't resolve `" . ${*$self}->{SOCKS}->{CmdAddr} . "'"), return; + my $hlen = length($dstaddr) if $resolve; + my $dstport = pack('n', ${*$self}->{SOCKS}->{CmdPort}); + my $reply; + $reply = $sock->_socks_send(pack('C4', SOCKS5_VER, $command, 0, $atyp) . (defined($hlen) ? pack('C', $hlen) : '') . $dstaddr . $dstport, ++$sends) + or return _fail($reply); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => SOCKS5_VER, + cmd => $command, + rsv => 0, + atyp => $atyp + ); + $debug->add(hlen => $hlen) if defined $hlen; + $debug->add( + dstaddr => $resolve ? $dstaddr : _addr_ntoa($dstaddr, $atyp), + dstport => ${*$self}->{SOCKS}->{CmdPort} + ); + $debug->show('Client Send: '); + } + + return 1; +} + +sub _socks5_connect_reply { + my $self = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + my $sock = + defined(${*$self}->{SOCKS}->{TCP}) + ? ${*$self}->{SOCKS}->{TCP} + : $self; + + #-------------------------------------------------------------------------- + # Read the reply + #-------------------------------------------------------------------------- + # +----+-----+-------+------+----------+----------+ + # |VER | REP | RSV | ATYP | BND.ADDR | BND.PORT | + # +----+-----+-------+------+----------+----------+ + # | 1 | 1 | X'00' | 1 | Variable | 2 | + # +----+-----+-------+------+----------+----------+ + + my $reply; + $reply = $sock->_socks_read(4, ++$reads) + or return _fail($reply); + + my ($ver, $rep, $rsv, $atyp) = unpack('C4', $reply); + + if ($debug) { + $debug->add( + ver => $ver, + rep => $rep, + rsv => $rsv, + atyp => $atyp + ); + } + + my ($bndaddr, $bndport); + + if ($atyp == ADDR_DOMAINNAME) { + length($reply = $sock->_socks_read(1, ++$reads)) + or return _fail($reply); + + my $hlen = unpack('C', $reply); + $bndaddr = $sock->_socks_read($hlen, ++$reads) + or return _fail($bndaddr); + + if ($debug) { + $debug->add(hlen => $hlen); + } + } + elsif ($atyp == ADDR_IPV4) { + $bndaddr = $sock->_socks_read(4, ++$reads) + or return _fail($bndaddr); + } + elsif ($atyp == ADDR_IPV6) { + $bndaddr = $sock->_socks_read(16, ++$reads) + or return _fail($bndaddr); + } + else { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(ISS_UNKNOWN_ADDRESS, $@ = "Unsupported address type returned by socks server: $atyp"); + return; + } + + $reply = $sock->_socks_read(2, ++$reads) + or return _fail($reply); + $bndport = unpack('n', $reply); + + ${*$self}->{SOCKS}->{DstAddrType} = $atyp; + ${*$self}->{SOCKS}->{DstAddr} = $bndaddr; + ${*$self}->{SOCKS}->{DstPort} = $bndport; + + if ($debug && !$self->_debugged(++$debugs)) { + my ($addr) = $self->dst; + $debug->add( + bndaddr => $addr, + bndport => $bndport + ); + $debug->show('Client Recv: '); + } + + if ($rep != REPLY_SUCCESS) { + $! = ESOCKSPROTO; + unless (exists $CODES{REPLY}->{$rep}) { + $rep = REPLY_GENERAL_FAILURE; + } + $SOCKS_ERROR->set($rep, $@ = $CODES{REPLY}->{$rep}); + return; + } + + return 1; +} + + +sub _socks4_connect_command { + # http://ss5.sourceforge.net/socks4.protocol.txt + # http://ss5.sourceforge.net/socks4A.protocol.txt + my $self = shift; + my $command = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + my $resolve = defined(${*$self}->{SOCKS}->{Resolve}) ? ${*$self}->{SOCKS}->{Resolve} : $SOCKS4_RESOLVE; + + #-------------------------------------------------------------------------- + # Send the command + #-------------------------------------------------------------------------- + # +-----+-----+----------+---------------+----------+------+ + # | VER | CMD | DST.PORT | DST.ADDR | USERID | NULL | + # +-----+-----+----------+---------------+----------+------+ + # | 1 | 1 | 2 | 4 | variable | 1 | + # +-----+-----+----------+---------------+----------+------+ + + my $dstaddr = $resolve ? inet_aton('0.0.0.1') : inet_aton(${*$self}->{SOCKS}->{CmdAddr}) + or $SOCKS_ERROR->set(ISS_CANT_RESOLVE, $@ = "Can't resolve `" . ${*$self}->{SOCKS}->{CmdAddr} . "'"), return; + my $dstport = pack('n', ${*$self}->{SOCKS}->{CmdPort}); + my $userid = ${*$self}->{SOCKS}->{Username} || ''; + my $dsthost = ''; + if ($resolve) { # socks4a + $dsthost = ${*$self}->{SOCKS}->{CmdAddr} . pack('C', 0); + } + + my $reply; + $reply = $self->_socks_send(pack('CC', SOCKS4_VER, $command) . $dstport . $dstaddr . $userid . pack('C', 0) . $dsthost, ++$sends) + or return _fail($reply); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => SOCKS4_VER, + cmd => $command, + dstport => ${*$self}->{SOCKS}->{CmdPort}, + dstaddr => length($dstaddr) == 4 ? inet_ntoa($dstaddr) : undef, + userid => $userid, + null => 0 + ); + if ($dsthost) { + $debug->add( + dsthost => ${*$self}->{SOCKS}->{CmdAddr}, + null => 0 + ); + } + $debug->show('Client Send: '); + } + + return 1; +} + +sub _socks4_connect_reply { + my $self = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + + #-------------------------------------------------------------------------- + # Read the reply + #-------------------------------------------------------------------------- + # +-----+-----+----------+---------------+ + # | VER | REP | BND.PORT | BND.ADDR | + # +-----+-----+----------+---------------+ + # | 1 | 1 | 2 | 4 | + # +-----+-----+----------+---------------+ + + my $reply; + $reply = $self->_socks_read(8, ++$reads) + or return _fail($reply); + + my ($ver, $rep, $bndport) = unpack('CCn', $reply); + substr($reply, 0, 4) = ''; + + ${*$self}->{SOCKS}->{DstAddrType} = ADDR_IPV4; + ${*$self}->{SOCKS}->{DstAddr} = $reply; + ${*$self}->{SOCKS}->{DstPort} = $bndport; + + if ($debug && !$self->_debugged(++$debugs)) { + my ($addr) = $self->dst; + + $debug->add( + ver => $ver, + rep => $rep, + bndport => $bndport, + bndaddr => $addr + ); + $debug->show('Client Recv: '); + } + + if ($rep != REQUEST_GRANTED) { + $! = ESOCKSPROTO; + unless (exists $CODES{REPLY}->{$rep}) { + $rep = REQUEST_FAILED; + } + $SOCKS_ERROR->set($rep, $@ = $CODES{REPLY}->{$rep}); + return; + } + + return 1; +} + +sub accept { + my $self = shift; + + croak("Undefined IO::Socket::Socks object passed to accept.") + unless defined($self); + + if (${*$self}->{SOCKS}->{Listen}) { + my $client = $self->SUPER::accept(@_); + + if (!$client) { + if ($! == EAGAIN || $! == EWOULDBLOCK) { + $SOCKS_ERROR->set(SOCKS_WANT_READ, "Socks want read"); + } + else { + $SOCKS_ERROR->set($!, $@ = "Proxy accept new client failed: $!"); + } + return; + } + + my $ver = + ref ${*$self}->{SOCKS}->{Version} + ? @{ ${*$self}->{SOCKS}->{Version} } > 1 + ? ${*$self}->{SOCKS}->{Version} + : ${*$self}->{SOCKS}->{Version}->[0] + : ${*$self}->{SOCKS}->{Version}; + + # inherit some socket parameters + ${*$client}->{SOCKS}->{Debug} = ${*$self}->{SOCKS}->{Debug}; + ${*$client}->{SOCKS}->{Version} = $ver; + ${*$client}->{SOCKS}->{AuthMethods} = ${*$self}->{SOCKS}->{AuthMethods}; + ${*$client}->{SOCKS}->{UserAuth} = ${*$self}->{SOCKS}->{UserAuth}; + ${*$client}->{SOCKS}->{Resolve} = ${*$self}->{SOCKS}->{Resolve}; + ${*$client}->{SOCKS}->{ready} = 0; + $client->blocking($self->blocking); # temporarily + + if (ref $ver) { + ${*$client}->{SOCKS}->{queue} = [ [ '_socks_accept', [], undef, [], 0 ] ]; + } + elsif ($ver == 4) { + ${*$client}->{SOCKS}->{queue} = [ [ '_socks4_accept_command', [], undef, [], 0 ] ]; + + } + else { + ${*$client}->{SOCKS}->{queue} = [ + [ '_socks5_accept', [], undef, [], 0 ], + [ '_socks5_accept_if_auth', [], undef, [], 0 ], + [ '_socks5_accept_command', [], undef, [], 0 ] + ]; + } + + defined($client->_run_queue()) + or return; + + $client->blocking(1); # new socket should be in blocking mode + return $client; + } + else { + ${*$self}->{SOCKS}->{ready} = 0; + if ({*$self}->{SOCKS}->{Version} == 4) { + push @{ ${*$self}->{SOCKS}->{queue} }, [ '_socks4_connect_reply', [], undef, [], 0 ]; + } + else { + push @{ ${*$self}->{SOCKS}->{queue} }, [ '_socks5_connect_reply', [], undef, [], 0 ]; + } + + defined($self->_run_queue()) + or return; + + return $self; + } +} + +sub _socks_accept { + # when 4 and 5 version allowed + my $self = shift; + + my $request; + $request = $self->_socks_read(1, 0) + or return _fail($request); + + my $ver = unpack('C', $request); + if ($ver == 4) { + ${*$self}->{SOCKS}->{Version} = 4; + push @{ ${*$self}->{SOCKS}->{queue} }, [ '_socks4_accept_command', [$ver], undef, [], 0 ]; + } + elsif ($ver == 5) { + ${*$self}->{SOCKS}->{Version} = 5; + push @{ ${*$self}->{SOCKS}->{queue} }, + [ '_socks5_accept', [$ver], undef, [], 0 ], + [ '_socks5_accept_if_auth', [], undef, [], 0 ], + [ '_socks5_accept_command', [], undef, [], 0 ]; + } + else { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(ISS_BAD_VERSION, $@ = "Socks version should be 4 or 5, $ver recieved"); + return; + } + + 1; +} + +sub _socks5_accept { + my ($self, $ver) = @_; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + + #-------------------------------------------------------------------------- + # Read the auth mechanisms + #-------------------------------------------------------------------------- + # +----+----------+----------+ + # |VER | NMETHODS | METHODS | + # +----+----------+----------+ + # | 1 | 1 | 1 to 255 | + # +----+----------+----------+ + + my $request; + $request = $self->_socks_read($ver ? 1 : 2, ++$reads) + or return _fail($request); + + unless ($ver) { + $ver = unpack('C', $request); + } + my $nmethods = unpack('C', substr($request, -1, 1)); + + $request = $self->_socks_read($nmethods, ++$reads) + or return _fail($request); + + my @methods = unpack('C' x $nmethods, $request); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => $ver, + nmethods => $nmethods, + methods => join('', @methods) + ); + $debug->show('Server Recv: '); + } + + if ($ver != SOCKS5_VER) { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(ISS_BAD_VERSION, $@ = "Socks version should be 5, $ver recieved"); + return; + } + + if ($nmethods == 0) { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(AUTHMECH_INVALID, $@ = "No auth methods sent"); + return; + } + + my $authmech; + + foreach my $method (@methods) { + if (${*$self}->{SOCKS}->{AuthMethods}->[$method] == 1) { + $authmech = $method; + last; + } + } + + if (!defined($authmech)) { + $authmech = AUTHMECH_INVALID; + } + + #-------------------------------------------------------------------------- + # Send the reply + #-------------------------------------------------------------------------- + # +----+--------+ + # |VER | METHOD | + # +----+--------+ + # | 1 | 1 | + # +----+--------+ + + $request = $self->_socks_send(pack('CC', SOCKS5_VER, $authmech), ++$sends) + or return _fail($request); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => SOCKS5_VER, + method => $authmech + ); + $debug->show('Server Send: '); + } + + if ($authmech == AUTHMECH_INVALID) { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(AUTHMECH_INVALID, $@ = "No available auth methods"); + return; + } + + return $authmech; +} + +sub _socks5_accept_if_auth { + my $self = shift; + + if (${*$self}->{SOCKS}->{queue_results}{'_socks5_accept'} == AUTHMECH_USERPASS) { + unshift @{ ${*$self}->{SOCKS}->{queue} }, [ '_socks5_accept_auth', [], undef, [], 0 ]; + (${*$self}->{SOCKS}->{queue}[0], ${*$self}->{SOCKS}->{queue}[1]) = (${*$self}->{SOCKS}->{queue}[1], ${*$self}->{SOCKS}->{queue}[0]); + } + + 1; +} + +sub _socks5_accept_auth { + my $self = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + + #-------------------------------------------------------------------------- + # Read the auth + #-------------------------------------------------------------------------- + # +----+------+----------+------+----------+ + # |VER | ULEN | UNAME | PLEN | PASSWD | + # +----+------+----------+------+----------+ + # | 1 | 1 | 1 to 255 | 1 | 1 to 255 | + # +----+------+----------+------+----------+ + + my $request; + $request = $self->_socks_read(2, ++$reads) + or return _fail($request); + + my ($ver, $ulen) = unpack('CC', $request); + $request = $self->_socks_read($ulen + 1, ++$reads) + or return _fail($request); + + my $uname = substr($request, 0, $ulen); + my $plen = unpack('C', substr($request, $ulen)); + my $passwd; + $passwd = $self->_socks_read($plen, ++$reads) + or return _fail($passwd); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => $ver, + ulen => $ulen, + uname => $uname, + plen => $plen, + passwd => $passwd + ); + $debug->show('Server Recv: '); + } + + my $status = 1; + if (defined(${*$self}->{SOCKS}->{UserAuth})) { + $status = &{ ${*$self}->{SOCKS}->{UserAuth} }($uname, $passwd); + } + + #-------------------------------------------------------------------------- + # Send the reply + #-------------------------------------------------------------------------- + # +----+--------+ + # |VER | STATUS | + # +----+--------+ + # | 1 | 1 | + # +----+--------+ + + $status = $status ? AUTHREPLY_SUCCESS : 1; #XXX AUTHREPLY_FAILURE broken + $request = $self->_socks_send(pack('CC', 1, $status), ++$sends) + or return _fail($request); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => 1, + status => $status + ); + $debug->show('Server Send: '); + } + + if ($status != AUTHREPLY_SUCCESS) { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(AUTHREPLY_FAILURE, $@ = "Authentication failed with SOCKS5 proxy"); + return; + } + + return 1; +} + +sub _socks5_accept_command { + my $self = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + + @{ ${*$self}->{SOCKS}->{COMMAND} } = (); + + #-------------------------------------------------------------------------- + # Read the command + #-------------------------------------------------------------------------- + # +----+-----+-------+------+----------+----------+ + # |VER | CMD | RSV | ATYP | DST.ADDR | DST.PORT | + # +----+-----+-------+------+----------+----------+ + # | 1 | 1 | X'00' | 1 | Variable | 2 | + # +----+-----+-------+------+----------+----------+ + + my $request; + $request = $self->_socks_read(4, ++$reads) + or return _fail($request); + + my ($ver, $cmd, $rsv, $atyp) = unpack('CCCC', $request); + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => $ver, + cmd => $cmd, + rsv => $rsv, + atyp => $atyp + ); + } + + my $dstaddr; + if ($atyp == ADDR_DOMAINNAME) { + length($request = $self->_socks_read(1, ++$reads)) + or return _fail($request); + + my $hlen = unpack('C', $request); + $dstaddr = $self->_socks_read($hlen, ++$reads) + or return _fail($dstaddr); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add(hlen => $hlen); + } + } + elsif ($atyp == ADDR_IPV4) { + $request = $self->_socks_read(4, ++$reads) + or return _fail($request); + + $dstaddr = length($request) == 4 ? inet_ntoa($request) : undef; + } + elsif ($atyp == ADDR_IPV6) { + $request = $self->_socks_read(16, ++$reads) + or return _fail($request); + + $dstaddr = length($request) == 16 ? Socket::inet_ntop(AF_INET6, $request) : undef; + } + else { # unknown address type - how many bytes to read? + push @{${*$self}->{SOCKS}->{queue}}, [ + '_socks5_accept_command_reply', [ REPLY_ADDR_NOT_SUPPORTED, '0.0.0.0', 0 ], undef, [], 0, + sub { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(REPLY_ADDR_NOT_SUPPORTED, $@ = $CODES{REPLY}->{REPLY_ADDR_NOT_SUPPORTED}); + } + ]; + + return 0; + } + + $request = $self->_socks_read(2, ++$reads) + or return _fail($request); + + my $dstport = unpack('n', $request); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + dstaddr => $dstaddr, + dstport => $dstport + ); + $debug->show('Server Recv: '); + } + + @{ ${*$self}->{SOCKS}->{COMMAND} } = ($cmd, $dstaddr, $dstport, $atyp); + + return 1; +} + +sub _socks5_accept_command_reply { + my $self = shift; + my $reply = shift; + my $host = shift; + my $port = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my $resolve = defined(${*$self}->{SOCKS}->{Resolve}) ? ${*$self}->{SOCKS}->{Resolve} : $SOCKS5_RESOLVE; + my ($reads, $sends, $debugs) = (0, 0, 0); + + if (!defined($reply) || !defined($host) || !defined($port)) { + croak("You must provide a reply, host, and port on the command reply."); + } + + #-------------------------------------------------------------------------- + # Send the reply + #-------------------------------------------------------------------------- + # +----+-----+-------+------+----------+----------+ + # |VER | REP | RSV | ATYP | BND.ADDR | BND.PORT | + # +----+-----+-------+------+----------+----------+ + # | 1 | 1 | X'00' | 1 | Variable | 2 | + # +----+-----+-------+------+----------+----------+ + + my ($atyp, $bndaddr) = $resolve ? _resolve($host) : (ADDR_DOMAINNAME, $host) + or $SOCKS_ERROR->set(ISS_CANT_RESOLVE, $@ = "Can't resolve `$host'"), return; + my $hlen = $resolve ? undef : length($bndaddr); + my $rc; + $rc = $self->_socks_send(pack('CCCC', SOCKS5_VER, $reply, 0, $atyp) . ($resolve ? '' : pack('C', $hlen)) . $bndaddr . pack('n', $port), ++$sends) + or return _fail($rc); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => SOCKS5_VER, + rep => $reply, + rsv => 0, + atyp => $atyp + ); + $debug->add(hlen => $hlen) unless $resolve; + $debug->add( + bndaddr => $resolve ? _addr_ntoa($bndaddr, $atyp) : $bndaddr, + bndport => $port + ); + $debug->show('Server Send: '); + } + + 1; +} + +sub _socks4_accept_command { + my ($self, $ver) = @_; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my $resolve = defined(${*$self}->{SOCKS}->{Resolve}) ? ${*$self}->{SOCKS}->{Resolve} : $SOCKS4_RESOLVE; + my ($reads, $sends, $debugs) = (0, 0, 0); + + @{ ${*$self}->{SOCKS}->{COMMAND} } = (); + + #-------------------------------------------------------------------------- + # Read the auth mechanisms + #-------------------------------------------------------------------------- + # +-----+-----+----------+---------------+----------+------+ + # | VER | CMD | DST.PORT | DST.ADDR | USERID | NULL | + # +-----+-----+----------+---------------+----------+------+ + # | 1 | 1 | 2 | 4 | variable | 1 | + # +-----+-----+----------+---------------+----------+------+ + + my $request; + $request = $self->_socks_read($ver ? 7 : 8, ++$reads) + or return _fail($request); + + unless ($ver) { + $ver = unpack('C', $request); + substr($request, 0, 1) = ''; + } + + my ($cmd, $dstport) = unpack('Cn', $request); + substr($request, 0, 3) = ''; + my $dstaddr = length($request) == 4 ? inet_ntoa($request) : undef; + + my $userid = ''; + my $c; + + while (1) { + length($c = $self->_socks_read(1, ++$reads)) + or return _fail($c); + + if ($c ne "\0") { + $userid .= $c; + } + else { + last; + } + } + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => $ver, + cmd => $cmd, + dstport => $dstport, + dstaddr => $dstaddr, + userid => $userid, + null => 0 + ); + } + + my $atyp = ADDR_IPV4; + + if ($resolve && $dstaddr =~ /^0\.0\.0\.[1-9]/) { # socks4a + $dstaddr = ''; + $atyp = ADDR_DOMAINNAME; + + while (1) { + length($c = $self->_socks_read(1, ++$reads)) + or return _fail($c); + + if ($c ne "\0") { + $dstaddr .= $c; + } + else { + last; + } + } + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + dsthost => $dstaddr, + null => 0 + ); + } + } + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->show('Server Recv: '); + } + + if (defined(${*$self}->{SOCKS}->{UserAuth})) { + unless (&{ ${*$self}->{SOCKS}->{UserAuth} }($userid)) { + push @{${*$self}->{SOCKS}->{queue}}, [ + '_socks4_accept_command_reply', [ REQUEST_REJECTED_USERID, '0.0.0.0', 0 ], undef, [], 0, + sub { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(REQUEST_REJECTED_USERID, $@ = 'Authentication failed with SOCKS4 proxy'); + } + ]; + + return 0; + } + } + + if ($ver != SOCKS4_VER) { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(ISS_BAD_VERSION, $@ = "Socks version should be 4, $ver recieved"); + return; + } + + @{ ${*$self}->{SOCKS}->{COMMAND} } = ($cmd, $dstaddr, $dstport, $atyp); + + return 1; +} + +sub _socks4_accept_command_reply { + my $self = shift; + my $reply = shift; + my $host = shift; + my $port = shift; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my ($reads, $sends, $debugs) = (0, 0, 0); + + if (!defined($reply) || !defined($host) || !defined($port)) { + croak("You must provide a reply, host, and port on the command reply."); + } + + #-------------------------------------------------------------------------- + # Send the reply + #-------------------------------------------------------------------------- + # +-----+-----+----------+---------------+ + # | VER | REP | BND.PORT | BND.ADDR | + # +-----+-----+----------+---------------+ + # | 1 | 1 | 2 | 4 | + # +-----+-----+----------+---------------+ + + my $bndaddr = inet_aton($host) + or $SOCKS_ERROR->set(ISS_CANT_RESOLVE, $@ = "Can't resolve `$host'"), return; + my $rc; + $rc = $self->_socks_send(pack('CCna*', 0, $reply, $port, $bndaddr), ++$sends) + or return _fail($rc); + + if ($debug && !$self->_debugged(++$debugs)) { + $debug->add( + ver => 0, + rep => $reply, + bndport => $port, + bndaddr => length($bndaddr) == 4 ? inet_ntoa($bndaddr) : undef + ); + $debug->show('Server Send: '); + } + + 1; +} + +sub command { + my $self = shift; + + unless (exists ${*$self}->{SOCKS}->{RequireAuth}) # TODO: find more correct way + { + return ${*$self}->{SOCKS}->{COMMAND}; + } + else { + my @keys = qw(Version AuthType RequireAuth UserAuth Username Password + Debug Resolve AuthMethods CmdAddr CmdPort Bind TCP); + + my %tmp; + $tmp{$_} = ${*$self}->{SOCKS}->{$_} for @keys; + + my %args = @_; + $self->_configure(\%args); + + if ($self->_connect()) { + return 1; + } + + ${*$self}->{SOCKS}->{$_} = $tmp{$_} for @keys; + return 0; + } +} + +sub command_reply { + my $self = shift; + ${*$self}->{SOCKS}->{ready} = 0; + + if (${*$self}->{SOCKS}->{Version} == 4) { + ${*$self}->{SOCKS}->{queue} = [ [ '_socks4_accept_command_reply', [@_], undef, [], 0 ] ]; + } + else { + ${*$self}->{SOCKS}->{queue} = [ [ '_socks5_accept_command_reply', [@_], undef, [], 0 ] ]; + } + + $self->_run_queue(); +} + +sub dst { + my $self = shift; + my ($addr, $port, $atype) = @{ ${*$self}->{SOCKS} }{qw/DstAddr DstPort DstAddrType/}; + return (_addr_ntoa($addr, $atype), $port, $atype); +} + +sub send { + my $self = shift; + + unless (defined ${*$self}->{SOCKS}->{TCP}) { + return $self->SUPER::send(@_); + } + + my ($msg, $flags, $peer) = @_; + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + my $resolve = defined(${*$self}->{SOCKS}->{Resolve}) ? ${*$self}->{SOCKS}->{Resolve} : $SOCKS5_RESOLVE; + + croak "send: Cannot determine peer address" + unless defined $peer; + + my ($dstport, $dstaddr, $dstaddr_type); + if (ref $peer eq 'ARRAY') { + $dstaddr = $peer->[0]; + $dstport = $peer->[1]; + $dstaddr_type = ADDR_DOMAINNAME; + } + else { + unless (($dstport, $dstaddr, $dstaddr_type) = eval { (unpack_sockaddr_in($peer), ADDR_IPV4) }) { + ($dstport, $dstaddr, $dstaddr_type) = ((unpack_sockaddr_in6($peer))[ 0, 1 ], ADDR_IPV6); + } + } + + my ($sndaddr, $sndport, $sndaddr_type) = $self->dst; + if (($sndaddr eq '0.0.0.0' && $sndaddr_type == ADDR_IPV4) || ($sndaddr eq '::' && $sndaddr_type == ADDR_IPV6)) { + $sndaddr = ${*$self}->{SOCKS}->{ProxyAddr}; + $sndaddr_type = ADDR_DOMAINNAME; + } + if ($sndaddr_type == ADDR_DOMAINNAME) { + ($sndaddr_type, $sndaddr) = _resolve($sndaddr) + or $SOCKS_ERROR->set(ISS_CANT_RESOLVE, $@ = "Can't resolve `$sndaddr'"), return; + } + else { + $sndaddr = ${*$self}->{SOCKS}->{DstAddr}; + } + + $peer = $sndaddr_type == ADDR_IPV4 ? pack_sockaddr_in($sndport, $sndaddr) : pack_sockaddr_in6($sndport, $sndaddr); + + my $hlen; + if ($dstaddr_type == ADDR_DOMAINNAME) { + if ($resolve) { + $hlen = length $dstaddr; + } + else { + ($dstaddr_type, $dstaddr) = _resolve($dstaddr) + or $SOCKS_ERROR->set(ISS_CANT_RESOLVE, $@ = "Can't resolve `$dstaddr'"), return; + } + } + + my $msglen = $debug ? length($msg) : 0; + + # we need to add socks header to the message + # +----+------+------+----------+----------+----------+ + # |RSV | FRAG | ATYP | DST.ADDR | DST.PORT | DATA | + # +----+------+------+----------+----------+----------+ + # | 2 | 1 | 1 | Variable | 2 | Variable | + # +----+------+------+----------+----------+----------+ + $msg = pack('C4', 0, 0, 0, $dstaddr_type) . (defined $hlen ? pack('C', $hlen) : '') . $dstaddr . pack('n', $dstport) . $msg; + + if ($debug) { + $debug->add( + rsv => '00', + frag => '0', + atyp => $dstaddr_type + ); + $debug->add(hlen => $hlen) if defined $hlen; + $debug->add( + dstaddr => defined $hlen ? $dstaddr : _addr_ntoa($dstaddr, $dstaddr_type), + dstport => $dstport, + data => "...($msglen)" + ); + $debug->show('Client Send: '); + } + + $self->SUPER::send($msg, $flags, $peer); +} + +sub recv { + my $self = shift; + + unless (defined ${*$self}->{SOCKS}->{TCP}) { + return $self->SUPER::recv(@_); + } + + my $debug = IO::Socket::Socks::Debug->new() if ${*$self}->{SOCKS}->{Debug}; + + defined($self->SUPER::recv($_[0], $_[1] + 262, $_[2])) + or return; + + # we need to remove socks header from the message + # +----+------+------+----------+----------+----------+ + # |RSV | FRAG | ATYP | DST.ADDR | DST.PORT | DATA | + # +----+------+------+----------+----------+----------+ + # | 2 | 1 | 1 | Variable | 2 | Variable | + # +----+------+------+----------+----------+----------+ + my $rsv = join('', unpack('C2', $_[0])); + substr($_[0], 0, 2) = ''; + + my ($frag, $atyp) = unpack('C2', $_[0]); + substr($_[0], 0, 2) = ''; + + if ($debug) { + $debug->add( + rsv => $rsv, + frag => $frag, + atyp => $atyp + ); + } + + my $dstaddr; + if ($atyp == ADDR_DOMAINNAME) { + my $hlen = unpack('C', $_[0]); + $dstaddr = substr($_[0], 1, $hlen); + substr($_[0], 0, $hlen + 1) = ''; + + if ($debug) { + $debug->add(hlen => $hlen); + } + } + elsif ($atyp == ADDR_IPV4) { + $dstaddr = substr($_[0], 0, 4); + substr($_[0], 0, 4) = ''; + } + elsif ($atyp == ADDR_IPV6) { + $dstaddr = substr($_[0], 0, 16); + substr($_[0], 0, 16) = ''; + } + else { + $! = ESOCKSPROTO; + $SOCKS_ERROR->set(ISS_UNKNOWN_ADDRESS, $@ = "Unsupported address type returned by socks server: $atyp"); + return; + } + + my $dstport = unpack('n', $_[0]); + substr($_[0], 0, 2) = ''; + + if ($debug) { + $debug->add( + dstaddr => _addr_ntoa($dstaddr, $atyp), + dstport => $dstport, + data => "...(" . length($_[0]) . ")" + ); + $debug->show('Client Recv: '); + } + + return pack_sockaddr_in($dstport, $dstaddr) if $atyp == ADDR_IPV4; + return pack_sockaddr_in6($dstport, $dstaddr) if $atyp == ADDR_IPV6; + return [ $dstaddr, $dstport ]; +} + +#+----------------------------------------------------------------------------- +#| Helper Functions +#+----------------------------------------------------------------------------- +sub _socks_send { + my $self = shift; + my $data = shift; + my $numb = shift; + + local $SIG{PIPE} = 'IGNORE'; + $SOCKS_ERROR->set(); + + my $rc; + my $writed = 0; + my $blocking = ${*$self}{io_socket_timeout} ? $self->blocking(0) : $self->blocking; + + unless ($blocking || ${*$self}{io_socket_timeout}) { + if (${*$self}->{SOCKS}->{queue}[0][Q_SENDS] >= $numb) { # already sent + return 1; + } + + if (defined ${*$self}->{SOCKS}->{queue}[0][Q_BUF]) { # some chunk already sent + substr($data, 0, ${*$self}->{SOCKS}->{queue}[0][Q_BUF]) = ''; + } + + while (length $data) { + $rc = $self->syswrite($data); + if (defined $rc) { + if ($rc > 0) { + ${*$self}->{SOCKS}->{queue}[0][Q_BUF] += $rc; + substr($data, 0, $rc) = ''; + } + else { # XXX: socket closed? if smth writed, but not all? + last; + } + } + elsif ($! == EWOULDBLOCK || $! == EAGAIN) { + $SOCKS_ERROR->set(SOCKS_WANT_WRITE, 'Socks want write'); + return undef; + } + else { + $SOCKS_ERROR->set($!, $@ = "send: $!"); + last; + } + } + + $writed = int(${*$self}->{SOCKS}->{queue}[0][Q_BUF]); + ${*$self}->{SOCKS}->{queue}[0][Q_BUF] = undef; + ${*$self}->{SOCKS}->{queue}[0][Q_SENDS]++; + return $writed; + } + + my $selector = IO::Select->new($self); + my $start = time(); + + while (1) { + if (${*$self}{io_socket_timeout} && time() - $start >= ${*$self}{io_socket_timeout}) { + $! = ETIMEDOUT; + last; + } + + unless ($selector->can_write(1)) { # socket couldn't accept data for now, check if timeout expired and try again + next; + } + + $rc = $self->syswrite($data); + if ($rc > 0) { # reduce our message + $writed += $rc; + substr($data, 0, $rc) = ''; + if (length($data) == 0) { # all data successfully writed + last; + } + } + else { # some error in the socket; will return false + $SOCKS_ERROR->set($!, $@ = "send: $!") unless defined $rc; + last; + } + } + + $self->blocking(1) if $blocking; + + return $writed; +} + +sub _socks_read { + my $self = shift; + my $length = shift || 1; + my $numb = shift; + + $SOCKS_ERROR->set(); + my $data = ''; + my ($buf, $rc); + my $blocking = $self->blocking; + + # non-blocking read + unless ($blocking || ${*$self}{io_socket_timeout}) { # no timeout should be specified for non-blocking connect + if (defined ${*$self}->{SOCKS}->{queue}[0][Q_READS][$numb]) { # already readed + return ${*$self}->{SOCKS}->{queue}[0][Q_READS][$numb]; + } + + if (defined ${*$self}->{SOCKS}->{queue}[0][Q_BUF]) { # some chunk already readed + $data = ${*$self}->{SOCKS}->{queue}[0][Q_BUF]; + $length -= length $data; + } + + while ($length > 0) { + $rc = $self->sysread($buf, $length); + if (defined $rc) { + if ($rc > 0) { + $length -= $rc; + $data .= $buf; + } + else { # XXX: socket closed, if smth readed but not all? + last; + } + } + elsif ($! == EWOULDBLOCK || $! == EAGAIN) { # no data to read + if (length $data) { # save already readed data in the queue buffer + ${*$self}->{SOCKS}->{queue}[0][Q_BUF] = $data; + } + $SOCKS_ERROR->set(SOCKS_WANT_READ, 'Socks want read'); + return undef; + } + else { + $SOCKS_ERROR->set($!, $@ = "read: $!"); + last; + } + } + + ${*$self}->{SOCKS}->{queue}[0][Q_BUF] = undef; + ${*$self}->{SOCKS}->{queue}[0][Q_READS][$numb] = $data; + return $data; + } + + # blocking read + my $selector = IO::Select->new($self); + my $start = time(); + + while ($length > 0) { + if (${*$self}{io_socket_timeout} && time() - $start >= ${*$self}{io_socket_timeout}) { + $! = ETIMEDOUT; + last; + } + + unless ($selector->can_read(1)) { # no data in socket for now, check if timeout expired and try again + next; + } + + $rc = $self->sysread($buf, $length); + if (defined $rc && $rc > 0) { # reduce limit and modify buffer + $length -= $rc; + $data .= $buf; + } + else { # EOF or error in the socket + $SOCKS_ERROR->set($!, $@ = "read: $!") unless defined $rc; + last; # TODO handle unexpected EOF more correct + } + } + + # XXX it may return incomplete $data if timed out. Could it break smth? + return $data; +} + +sub _debugged { + my ($self, $debugs) = @_; + + if (${*$self}->{SOCKS}->{queue}[0][Q_DEBUGS] >= $debugs) { + return 1; + } + + ${*$self}->{SOCKS}->{queue}[0][Q_DEBUGS] = $debugs; + return 0; +} + +sub _fail { + if (!@_ || defined($_[0])) { + $SOCKS_ERROR->set(ECONNABORTED, $@ = 'Socket closed by remote side') if $SOCKS_ERROR == undef; + return; + } + + return -1; +} + +sub _validate_multi_version { + my $multi_ver = shift; + + if (@$multi_ver == 1) { + return $multi_ver->[0] == 4 || $multi_ver->[0] == 5; + } + + if (@$multi_ver == 2) { + return + $multi_ver->[0] != $multi_ver->[1] + && ($multi_ver->[0] == 4 || $multi_ver->[0] == 5) + && ($multi_ver->[1] == 4 || $multi_ver->[1] == 5); + } + + return; +} + +sub _resolve { + my $addr = shift; + my ($err, @res) = Socket::getaddrinfo($addr, undef, { protocol => Socket::IPPROTO_TCP, socktype => Socket::SOCK_STREAM }); + return if $err; + + for my $r (@res) { + if ($r->{family} == PF_INET) { + return (ADDR_IPV4, (unpack_sockaddr_in($r->{addr}))[1]); + } + } + + return (ADDR_IPV6, (unpack_sockaddr_in6($res[0]{addr}))[1]); +} + +sub _addr_ntoa { + my ($addr, $atype) = @_; + + return inet_ntoa($addr) if ($atype == ADDR_IPV4); + return Socket::inet_ntop(AF_INET6, $addr) if ($atype == ADDR_IPV6); + return $addr; +} + +############################################################################### +#+----------------------------------------------------------------------------- +#| Helper Package to bring some magic in $SOCKS_ERROR +#+----------------------------------------------------------------------------- +############################################################################### + +package IO::Socket::Socks::Error; + +use overload + '==' => \&num_eq, + '!=' => sub { !num_eq(@_) }, + '""' => \&as_str, + '0+' => \&as_num; + +sub new { + my ($class, $num, $str) = @_; + + my $self = { + num => $num, + str => $str, + }; + + bless $self, $class; +} + +sub set { + my ($self, $num, $str) = @_; + + $self->{num} = defined $num ? int($num) : $num; + $self->{str} = $str; +} + +sub as_str { + my $self = shift; + return $self->{str}; +} + +sub as_num { + my $self = shift; + return $self->{num}; +} + +sub num_eq { + my ($self, $num) = @_; + + unless (defined $num) { + return !defined($self->{num}); + } + return $self->{num} == int($num); +} + +############################################################################### +#+----------------------------------------------------------------------------- +#| Helper Package to prevent modifications of $SOCKS_ERROR outside this package +#+----------------------------------------------------------------------------- +############################################################################### + +package IO::Socket::Socks::ReadOnlyVar; + +sub TIESCALAR { + my ($class, $value) = @_; + bless \$value, $class; +} + +sub FETCH { + my $self = shift; + return $$self; +} + +*STORE = *UNTIE = sub { Carp::croak 'Modification of readonly value attempted' }; + +############################################################################### +#+----------------------------------------------------------------------------- +#| Helper Package to handle assigning of $SOCKET_CLASS +#+----------------------------------------------------------------------------- +############################################################################### + +package IO::Socket::Socks::SocketClassVar; + +sub TIESCALAR { + my ($class, $value) = @_; + bless { v => $value }, $class; +} + +sub FETCH { + return $_[0]->{v}; +} + +sub STORE { + my ($self, $class) = @_; + + $self->{v} = $class; + eval "use $class; 1" or die $@; + $IO::Socket::Socks::ISA[1] = $class; +} + +sub UNTIE { + Carp::croak 'Untie of tied variable is denied'; +} + +############################################################################### +#+----------------------------------------------------------------------------- +#| Helper Package to display pretty debug messages +#+----------------------------------------------------------------------------- +############################################################################### + +package IO::Socket::Socks::Debug; + +sub new { + my ($class) = @_; + my $self = []; + + bless $self, $class; +} + +sub add { + my $self = shift; + push @{$self}, @_; +} + +sub show { + my ($self, $tag) = @_; + + $self->_separator($tag); + $self->_row(0, $tag); + $self->_separator($tag); + $self->_row(1, $tag); + $self->_separator($tag); + + print STDERR "\n"; + + @{$self} = (); +} + +sub _separator { + my $self = shift; + my $tag = shift; + my ($row1_len, $row2_len, $len); + + print STDERR $tag, '+'; + + for (my $i = 0 ; $i < @$self ; $i += 2) { + $row1_len = length($self->[$i]); + $row2_len = length($self->[ $i + 1 ]); + $len = ($row1_len > $row2_len ? $row1_len : $row2_len) + 2; + + print STDERR '-' x $len, '+'; + } + + print STDERR "\n"; +} + +sub _row { + my $self = shift; + my $row = shift; + my $tag = shift; + my ($row1_len, $row2_len, $len); + + print STDERR $tag, '|'; + + for (my $i = 0 ; $i < @$self ; $i += 2) { + $row1_len = length($self->[$i]); + $row2_len = length($self->[ $i + 1 ]); + $len = ($row1_len > $row2_len ? $row1_len : $row2_len); + + printf STDERR ' %-' . $len . 's |', $self->[ $i + $row ]; + } + + print STDERR "\n"; +} + +1; + +__END__ + +=head1 NAME + +IO::Socket::Socks - Provides a way to create socks client or server both 4 and 5 version. + +=head1 SYNOPSIS + +=head2 Client + + use IO::Socket::Socks; + + my $socks_client = IO::Socket::Socks->new( + ProxyAddr => "proxy host", + ProxyPort => "proxy port", + ConnectAddr => "remote host", + ConnectPort => "remote port", + ) or die $SOCKS_ERROR; + + print $socks_client "foo\n"; + $socks_client->close(); + +=head2 Server + + use IO::Socket::Socks ':constants'; + + my $socks_server = IO::Socket::Socks->new( + ProxyAddr => "localhost", + ProxyPort => 8000, + Listen => 1, + UserAuth => \&auth, + RequireAuth => 1 + ) or die $SOCKS_ERROR; + + while(1) { + my $client = $socks_server->accept(); + + unless ($client) { + print "ERROR: $SOCKS_ERROR\n"; + next; + } + + my $command = $client->command(); + if ($command->[0] == CMD_CONNECT) { + # Handle the CONNECT + $client->command_reply(REPLY_SUCCESS, addr, port); + } + + ... + #read from the client and send to the CONNECT address + ... + + $client->close(); + } + + sub auth { + my ($user, $pass) = @_; + + return 1 if $user eq "foo" && $pass eq "bar"; + return 0; + } + +=head1 DESCRIPTION + +C connects to a SOCKS proxy, tells it to open a +connection to a remote host/port when the object is created. The +object you receive can be used directly as a socket (with C interface) +for sending and receiving data from the remote host. In addition to create socks client +this module could be used to create socks server. See examples below. + +=head1 EXAMPLES + +For complete examples of socks 4/5 client and server see `examples' +subdirectory in the distribution. + +=head1 METHODS + +=head2 Socks Client + +=head3 new( %cfg ) + +=head3 new_from_socket($socket, %cfg) + +=head3 new_from_fd($socket, %cfg) + +Creates a new IO::Socket::Socks client object. new_from_socket() is the same as +new(), but allows one to create object from an existing and not connected socket +(new_from_fd is new_from_socket alias). To make IO::Socket::Socks object from +connected socket see C + +Both takes the following config hash: + + SocksVersion => 4 or 5. Default is 5 + + Timeout => connect/accept timeout + + Blocking => Since IO::Socket::Socks version 0.5 you can perform non-blocking connect/bind by + passing false value for this option. Default is true - blocking. See ready() + below for more details. + + SocksResolve => resolve host name to ip by proxy server or + not (will resolve by client). This + overrides value of $SOCKS4_RESOLVE or $SOCKS5_RESOLVE + variable. Boolean. + + SocksDebug => This will cause all of the SOCKS traffic to + be presented on the command line in a form + similar to the tables in the RFCs. This overrides value + of $SOCKS_DEBUG variable. Boolean. + + ProxyAddr => Hostname of the proxy + + ProxyPort => Port of the proxy + + ConnectAddr => Hostname of the remote machine + + ConnectPort => Port of the remote machine + + BindAddr => Hostname of the remote machine which will + connect to the proxy server after bind request + + BindPort => Port of the remote machine which will + connect to the proxy server after bind request + + UdpAddr => Expected address where datagrams will be sent. Fill it with address + of all zeros if address is not known at this moment. + Proxy server may use this information to limit access to the association. + + UdpPort => Expected port where datagrams will be sent. Use zero port + if port is not known at this moment. Proxy server may use this + information to limit access to the association. + + AuthType => What kind of authentication to support: + none - no authentication (default) + userpass - Username/Password. For socks5 + proxy only. + + RequireAuth => Do not send ANON as a valid auth mechanism. + For socks5 proxy only + + Username => For socks5 if AuthType is set to userpass, then + you must provide a username. For socks4 proxy with + this option you can specify userid. + + Password => If AuthType is set to userpass, then you must + provide a password. For socks5 proxy only. + +The following options should be specified: + + (ProxyAddr and ProxyPort) + (ConnectAddr and ConnectPort) or (BindAddr and BindPort) or (UdpAddr and UdpPort) + +Other options are facultative. + +=head3 +start_SOCKS($socket, %cfg) + +This is a class method to start socks handshake on already connected socket. This +will bless passed $socket to IO::Socket::Socks class. %cfg is like hash in the constructor. +Only options listed below makes sence: + + Timeout + ConnectAddr + ConnectPort + BindAddr + BindPort + UdpAddr + UdpPort + SocksVersion + SocksDebug + SocksResolve + AuthType + RequireAuth + Username + Password + AuthMethods + +On success this method will return same $socket, but as IO::Socket::Socks object. On failure it will +return undef (but socket will be still blessed to IO::Socket::Socks class). See example: + + use IO::Socket; + use IO::Socket::Socks; + + my $sock = IO::Socket::INET->new("$proxy_host:$proxy_port") or die $@; + $sock = IO::Socket::Socks->start_SOCKS($sock, ConnectAddr => "google.com", ConnectPort => 80) or die $SOCKS_ERROR; + +=head3 +version( ) + +Returns socks version for this socket + +=head3 +ready( ) + +Returns true when socket becomes ready to transfer data (socks handshake done), +false otherwise. This is useful for non-blocking connect/bind. When this method +returns false value you can determine what socks handshake need for with $SOCKS_ERROR +variable. It may need for read, then $SOCKS_ERROR will be SOCKS_WANT_READ or need for +write, then it will be SOCKS_WANT_WRITE. + +Example: + + use IO::Socket::Socks; + use IO::Select; + + my $sock = IO::Socket::Socks->new( + ProxyAddr => 'localhost', ProxyPort => 1080, ConnectAddr => 'mail.com', ConnectPort => 80, Blocking => 0 + ) or die $SOCKS_ERROR; + + my $sel = IO::Select->new($sock); + until ($sock->ready) { + if ($SOCKS_ERROR == SOCKS_WANT_READ) { + $sel->can_read(); + } + elsif ($SOCKS_ERROR == SOCKS_WANT_WRITE) { + $sel->can_write(); + } + else { + die $SOCKS_ERROR; + } + + # NOTE: when base class ($IO::Socket::Socks::SOCKET_CLASS) is IO::Socket::IP + # and you are using kqueue or epoll to check for readable/writable sockets + # you need to readd $sock to kqueue/epoll after each call to ready() (actually until socket will be connected to proxy server), + # because IO::Socket::IP may change internal socket of $sock for milti-homed hosts. + # There is no such problem when you are using select/poll + } + + # you may want to return socket to blocking state by $sock->blocking(1) + $sock->syswrite("I am ready"); + +=head3 +accept( ) + +Accept an incoming connection after bind request. On failed returns undef. +On success returns socket. No new socket created, returned socket is same +on which this method was called. Because accept(2) is not invoked on the +client side, socks server calls accept(2) and proxify all traffic via socket +opened by client bind request. You can call accept only once on IO::Socket::Socks +client socket. + +=head3 +command( %cfg ) + +Allows one to execute socks command on already opened socket. Thus you +can create socks chain. For example see L section. + +%cfg is like hash in the constructor. Only options listed below makes sence: + + ConnectAddr + ConnectPort + BindAddr + BindPort + UdpAddr + UdpPort + SocksVersion + SocksDebug + SocksResolve + AuthType + RequireAuth + Username + Password + AuthMethods + +Values of the other options (Timeout for example) inherited from the constructor. +Options like ProxyAddr and ProxyPort are not included. + +=head3 +dst( ) + +Return (host, port, address_type) of the remote host after connect/accept or socks server (host, port, address_type) +after bind/udpassoc. + +=head2 Socks Server + +=head3 new( %cfg ) + +=head3 new_from_socket($socket, %cfg) + +=head3 new_from_fd($socket, %cfg) + +Creates a new IO::Socket::Socks server object. new_from_socket() is the same as +new(), but allows one to create object from an existing socket (new_from_fd is new_from_socket alias). +Both takes the following config hash: + + SocksVersion => 4 for socks4, 5 for socks5 or [4,5] if you want accept both 4 and 5. Default is 5 + + Timeout => Timeout value for various operations + + Blocking => Since IO::Socket::Socks version 0.6 you can perform non-blocking accept by + passing false value for this option. Default is true - blocking. See ready() + below for more details. + + SocksResolve => For socks v5: return destination address to the client + in form of 4 bytes if true, otherwise in form of host + length and host name. + For socks v4: allow use socks4a protocol extension if + true and not otherwise. + This overrides value of $SOCKS4_RESOLVE or $SOCKS5_RESOLVE. + See also command_reply(). + + SocksDebug => This will cause all of the SOCKS traffic to + be presented on the command line in a form + similar to the tables in the RFCs. This overrides value + of $SOCKS_DEBUG variable. Boolean. + + ProxyAddr => Local host bind address + + ProxyPort => Local host bind port + + UserAuth => Reference to a function that returns 1 if client + allowed to use socks server, 0 otherwise. For + socks5 proxy it takes login and password as + arguments. For socks4 argument is userid. + + RequireAuth => Not allow anonymous access for socks5 proxy. + + Listen => Same as IO::Socket::INET listen option. Should be + specified as number > 0. + +The following options should be specified: + + Listen + ProxyAddr + ProxyPort + +Other options are facultative. + +=head3 accept( ) + +Accept an incoming connection and return a new IO::Socket::Socks +object that represents that connection. You must call command() +on this to find out what the incoming connection wants you to do, +and then call command_reply() to send back the reply. + +=head3 version( ) + +Returns socks version for socket. It is useful when your server +accepts both 4 and 5 version. Then you should know socks version +to make proper response. Just call C on socket received +after C. + +=head3 ready( ) + +After non-blocking accept you will get new client socket object, which may be +not ready to transfer data (if socks handshake is not done yet). ready() will return +true value when handshake will be done successfully and false otherwise. Note, socket +returned by accept() call will be always in blocking mode. So if your program can't +block you should set non-blocking mode for this socket before ready() call: $socket->blocking(0). +When ready() returns false value you can determine what socks handshake needs for with $SOCKS_ERROR +variable. It may need for read, then $SOCKS_ERROR will be SOCKS_WANT_READ or need for +write, then it will be SOCKS_WANT_WRITE. + +Example: + + use IO::Socket::Socks; + use IO::Select; + + my $server = IO::Socket::Socks->new(ProxyAddr => 'localhost', ProxyPort => 1080, Blocking => 0) + or die $@; + my $select = IO::Select->new($server); + $select->can_read(); # wait for client + + my $client = $server->accept() + or die "accept(): $! ($SOCKS_ERROR)"; + $client->blocking(0); # !!! + $select->add($client); + $select->remove($server); # no more connections + + while (1) { + if ($client->ready) { + my $command = $client->command; + + ... # do client command + + $client->command_reply(IO::Socket::Socks::REPLY_SUCCESS, $command->[1], $command->[2]); + + ... # transfer traffic + + last; + } + elsif ($SOCKS_ERROR == SOCKS_WANT_READ) { + $select->can_read(); + } + elsif ($SOCKS_ERROR == SOCKS_WANT_WRITE) { + $select->can_write(); + } + else { + die "Unexpected error: $SOCKS_ERROR"; + } + } + +=head3 command( ) + +After you call accept() the client has sent the command they want +you to process. This function should be called on the socket returned +by accept(). It returns a reference to an array with the following format: + + [ COMMAND, ADDRESS, PORT, ADDRESS TYPE ] + +=head3 command_reply( REPLY CODE, ADDRESS, PORT ) + +After you call command() the client needs to be told what the result +is. The REPLY CODE is one of the constants as follows (integer value): + + For socks v4 + REQUEST_GRANTED(90): request granted + REQUEST_FAILED(91): request rejected or failed + REQUEST_REJECTED_IDENTD(92): request rejected because SOCKS server cannot connect to identd on the client + REQUEST_REJECTED_USERID(93): request rejected because the client program and identd report different user-ids + + For socks v5 + REPLY_SUCCESS(0): Success + REPLY_GENERAL_FAILURE(1): General Failure + REPLY_CONN_NOT_ALLOWED(2): Connection Not Allowed + REPLY_NETWORK_UNREACHABLE(3): Network Unreachable + REPLY_HOST_UNREACHABLE(4): Host Unreachable + REPLY_CONN_REFUSED(5): Connection Refused + REPLY_TTL_EXPIRED(6): TTL Expired + REPLY_CMD_NOT_SUPPORTED(7): Command Not Supported + REPLY_ADDR_NOT_SUPPORTED(8): Address Not Supported + +HOST and PORT are the resulting host and port (where server socket responsible for this command bound). + +Note: for 5 version C will try to resolve passed address if +C has true value and passed address is domain name. To avoid this just pass ip address +(C<$socket-Esockhost>) instead of host name or turn off C for this server. For version 4 +passed host name will always be resolved to ip address even if C has false value. Because +this version doesn't support C
as domain name. + +=head1 VARIABLES + +=head2 $SOCKS_ERROR + +This scalar behaves like $! in that if undef is returned. C<$SOCKS_ERROR> is IO::Socket::Socks::Error +object with some overloaded operators. In string context this variable should contain a string reason for +the error. In numeric context it contains error code. + +=head2 $SOCKS4_RESOLVE + +If this variable has true value resolving of host names will be done +by proxy server, otherwise resolving will be done locally. Resolving +host by socks proxy version 4 is extension to the protocol also known +as socks4a. So, only socks4a proxy supports resolving of hostnames. +Default value of this variable is false. This variable is not importable. +See also `SocksResolve' parameter in the constructor. + +=head2 $SOCKS5_RESOLVE + +If this variable has true value resolving of host names will be done +by proxy server, otherwise resolving will be done locally. Note: some +bugous socks5 servers doesn't support resolving of host names. Default +value is true. This variable is not importable. +See also `SocksResolve' parameter in the constructor. + +=head2 $SOCKS_DEBUG + +Default value is $ENV{SOCKS_DEBUG}. If this variable has true value and +no SocksDebug option in the constructor specified, then SocksDebug will +has true value. This variable is not importable. + +=head2 $SOCKET_CLASS + +With this variable you can get/set base socket class for C. +By default it tries to use C 0.36+ as socket class. And falls +back to C if not available. You can set C<$IO::Socket::Socks::SOCKET_CLASS> +before loading of C and then it will not try to detect proper base class +itself. You can also set it after loading of C and this will automatically +update C<@ISA>, so you shouldn't worry about inheritance. + +=head1 CONSTANTS + +The following constants could be imported manually or using `:constants' tag: + + SOCKS5_VER + SOCKS4_VER + ADDR_IPV4 + ADDR_DOMAINNAME + ADDR_IPV6 + CMD_CONNECT + CMD_BIND + CMD_UDPASSOC + AUTHMECH_ANON + AUTHMECH_USERPASS + AUTHMECH_INVALID + AUTHREPLY_SUCCESS + AUTHREPLY_FAILURE + ISS_UNKNOWN_ADDRESS # address type sent by client/server not supported by I::S::S + ISS_BAD_VERSION # socks version sent by client/server != specified version + ISS_CANT_RESOLVE # I::S::S failed to resolve some host + REPLY_SUCCESS + REPLY_GENERAL_FAILURE + REPLY_CONN_NOT_ALLOWED + REPLY_NETWORK_UNREACHABLE + REPLY_HOST_UNREACHABLE + REPLY_CONN_REFUSED + REPLY_TTL_EXPIRED + REPLY_CMD_NOT_SUPPORTED + REPLY_ADDR_NOT_SUPPORTED + REQUEST_GRANTED + REQUEST_FAILED + REQUEST_REJECTED_IDENTD + REQUEST_REJECTED_USERID + SOCKS_WANT_READ + SOCKS_WANT_WRITE + ESOCKSPROTO + +SOCKS_WANT_READ, SOCKS_WANT_WRITE and ESOCKSPROTO are imported by default. + +=head1 IPv6 + +Since version 0.66 C supports IPv6 with help of L +0.36+. And will use C as base class if available. However you can +force set C<$SOCKET_CLASS = "IO::Socket::INET"> to use IPv4 only. See also +L + +=head1 FAQ + +=over + +=item How to determine is connection to socks server (client accept) failed or some protocol error +occurred? + +You can check $! variable. If $! == ESOCKSPROTO constant, then it was error in the protocol. Error +description could be found in $SOCKS_ERROR. + +=item How to determine which error in the protocol occurred? + +You should compare C<$SOCKS_ERROR> with constants below: + + AUTHMECH_INVALID + AUTHREPLY_FAILURE + ISS_UNKNOWN_ADDRESS + ISS_BAD_VERSION + REPLY_GENERAL_FAILURE + REPLY_CONN_NOT_ALLOWED + REPLY_NETWORK_UNREACHABLE + REPLY_HOST_UNREACHABLE + REPLY_CONN_REFUSED + REPLY_TTL_EXPIRED + REPLY_CMD_NOT_SUPPORTED + REPLY_ADDR_NOT_SUPPORTED + REQUEST_FAILED + REQUEST_REJECTED_IDENTD + REQUEST_REJECTED_USERID + +=back + +=head1 BUGS + +The following options are not implemented: + +=over + +=item GSSAPI authentication + +=item UDP server side support + +=back + +Patches are welcome. + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Original author is Ryan Eatmon + +Now maintained by Oleg G + +=head1 COPYRIGHT + +This module is free software, you can redistribute it and/or modify +it under the terms of LGPL. + +=cut diff --git a/lib/lib/IO/String.pm b/lib/lib/IO/String.pm new file mode 100644 index 0000000..4bc8e71 --- /dev/null +++ b/lib/lib/IO/String.pm @@ -0,0 +1,551 @@ +package IO::String; + +# Copyright 1998-2005 Gisle Aas. +# +# This library is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. + +require 5.005_03; +use strict; +use vars qw($VERSION $DEBUG $IO_CONSTANTS); +$VERSION = "1.08"; # $Date: 2005/12/05 12:00:47 $ + +use Symbol (); + +sub new +{ + my $class = shift; + my $self = bless Symbol::gensym(), ref($class) || $class; + tie *$self, $self; + $self->open(@_); + return $self; +} + +sub open +{ + my $self = shift; + return $self->new(@_) unless ref($self); + + if (@_) { + my $bufref = ref($_[0]) ? $_[0] : \$_[0]; + $$bufref = "" unless defined $$bufref; + *$self->{buf} = $bufref; + } + else { + my $buf = ""; + *$self->{buf} = \$buf; + } + *$self->{pos} = 0; + *$self->{lno} = 0; + return $self; +} + +sub pad +{ + my $self = shift; + my $old = *$self->{pad}; + *$self->{pad} = substr($_[0], 0, 1) if @_; + return "\0" unless defined($old) && length($old); + return $old; +} + +sub dump +{ + require Data::Dumper; + my $self = shift; + print Data::Dumper->Dump([$self], ['*self']); + print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']); + return; +} + +sub TIEHANDLE +{ + print "TIEHANDLE @_\n" if $DEBUG; + return $_[0] if ref($_[0]); + my $class = shift; + my $self = bless Symbol::gensym(), $class; + $self->open(@_); + return $self; +} + +sub DESTROY +{ + print "DESTROY @_\n" if $DEBUG; +} + +sub close +{ + my $self = shift; + delete *$self->{buf}; + delete *$self->{pos}; + delete *$self->{lno}; + undef *$self if $] eq "5.008"; # workaround for some bug + return 1; +} + +sub opened +{ + my $self = shift; + return defined *$self->{buf}; +} + +sub binmode +{ + my $self = shift; + return 1 unless @_; + # XXX don't know much about layers yet :-( + return 0; +} + +sub getc +{ + my $self = shift; + my $buf; + return $buf if $self->read($buf, 1); + return undef; +} + +sub ungetc +{ + my $self = shift; + $self->setpos($self->getpos() - 1); + return 1; +} + +sub eof +{ + my $self = shift; + return length(${*$self->{buf}}) <= *$self->{pos}; +} + +sub print +{ + my $self = shift; + if (defined $\) { + if (defined $,) { + $self->write(join($,, @_).$\); + } + else { + $self->write(join("",@_).$\); + } + } + else { + if (defined $,) { + $self->write(join($,, @_)); + } + else { + $self->write(join("",@_)); + } + } + return 1; +} +*printflush = \*print; + +sub printf +{ + my $self = shift; + print "PRINTF(@_)\n" if $DEBUG; + my $fmt = shift; + $self->write(sprintf($fmt, @_)); + return 1; +} + + +my($SEEK_SET, $SEEK_CUR, $SEEK_END); + +sub _init_seek_constants +{ + if ($IO_CONSTANTS) { + require IO::Handle; + $SEEK_SET = &IO::Handle::SEEK_SET; + $SEEK_CUR = &IO::Handle::SEEK_CUR; + $SEEK_END = &IO::Handle::SEEK_END; + } + else { + $SEEK_SET = 0; + $SEEK_CUR = 1; + $SEEK_END = 2; + } +} + + +sub seek +{ + my($self,$off,$whence) = @_; + my $buf = *$self->{buf} || return 0; + my $len = length($$buf); + my $pos = *$self->{pos}; + + _init_seek_constants() unless defined $SEEK_SET; + + if ($whence == $SEEK_SET) { $pos = $off } + elsif ($whence == $SEEK_CUR) { $pos += $off } + elsif ($whence == $SEEK_END) { $pos = $len + $off } + else { die "Bad whence ($whence)" } + print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG; + + $pos = 0 if $pos < 0; + $self->truncate($pos) if $pos > $len; # extend file + *$self->{pos} = $pos; + return 1; +} + +sub pos +{ + my $self = shift; + my $old = *$self->{pos}; + if (@_) { + my $pos = shift || 0; + my $buf = *$self->{buf}; + my $len = $buf ? length($$buf) : 0; + $pos = $len if $pos > $len; + *$self->{pos} = $pos; + } + return $old; +} + +sub getpos { shift->pos; } + +*sysseek = \&seek; +*setpos = \&pos; +*tell = \&getpos; + + + +sub getline +{ + my $self = shift; + my $buf = *$self->{buf} || return; + my $len = length($$buf); + my $pos = *$self->{pos}; + return if $pos >= $len; + + unless (defined $/) { # slurp + *$self->{pos} = $len; + return substr($$buf, $pos); + } + + unless (length $/) { # paragraph mode + # XXX slow&lazy implementation using getc() + my $para = ""; + my $eol = 0; + my $c; + while (defined($c = $self->getc)) { + if ($c eq "\n") { + $eol++; + next if $eol > 2; + } + elsif ($eol > 1) { + $self->ungetc($c); + last; + } + else { + $eol = 0; + } + $para .= $c; + } + return $para; # XXX wantarray + } + + my $idx = index($$buf,$/,$pos); + if ($idx < 0) { + # return rest of it + *$self->{pos} = $len; + $. = ++ *$self->{lno}; + return substr($$buf, $pos); + } + $len = $idx - $pos + length($/); + *$self->{pos} += $len; + $. = ++ *$self->{lno}; + return substr($$buf, $pos, $len); +} + +sub getlines +{ + die "getlines() called in scalar context\n" unless wantarray; + my $self = shift; + my($line, @lines); + push(@lines, $line) while defined($line = $self->getline); + return @lines; +} + +sub READLINE +{ + goto &getlines if wantarray; + goto &getline; +} + +sub input_line_number +{ + my $self = shift; + my $old = *$self->{lno}; + *$self->{lno} = shift if @_; + return $old; +} + +sub truncate +{ + my $self = shift; + my $len = shift || 0; + my $buf = *$self->{buf}; + if (length($$buf) >= $len) { + substr($$buf, $len) = ''; + *$self->{pos} = $len if $len < *$self->{pos}; + } + else { + $$buf .= ($self->pad x ($len - length($$buf))); + } + return 1; +} + +sub read +{ + my $self = shift; + my $buf = *$self->{buf}; + return undef unless $buf; + + my $pos = *$self->{pos}; + my $rem = length($$buf) - $pos; + my $len = $_[1]; + $len = $rem if $len > $rem; + return undef if $len < 0; + if (@_ > 2) { # read offset + substr($_[0],$_[2]) = substr($$buf, $pos, $len); + } + else { + $_[0] = substr($$buf, $pos, $len); + } + *$self->{pos} += $len; + return $len; +} + +sub write +{ + my $self = shift; + my $buf = *$self->{buf}; + return unless $buf; + + my $pos = *$self->{pos}; + my $slen = length($_[0]); + my $len = $slen; + my $off = 0; + if (@_ > 1) { + $len = $_[1] if $_[1] < $len; + if (@_ > 2) { + $off = $_[2] || 0; + die "Offset outside string" if $off > $slen; + if ($off < 0) { + $off += $slen; + die "Offset outside string" if $off < 0; + } + my $rem = $slen - $off; + $len = $rem if $rem < $len; + } + } + substr($$buf, $pos, $len) = substr($_[0], $off, $len); + *$self->{pos} += $len; + return $len; +} + +*sysread = \&read; +*syswrite = \&write; + +sub stat +{ + my $self = shift; + return unless $self->opened; + return 1 unless wantarray; + my $len = length ${*$self->{buf}}; + + return ( + undef, undef, # dev, ino + 0666, # filemode + 1, # links + $>, # user id + $), # group id + undef, # device id + $len, # size + undef, # atime + undef, # mtime + undef, # ctime + 512, # blksize + int(($len+511)/512) # blocks + ); +} + +sub FILENO { + return undef; # XXX perlfunc says this means the file is closed +} + +sub blocking { + my $self = shift; + my $old = *$self->{blocking} || 0; + *$self->{blocking} = shift if @_; + return $old; +} + +my $notmuch = sub { return }; + +*fileno = $notmuch; +*error = $notmuch; +*clearerr = $notmuch; +*sync = $notmuch; +*flush = $notmuch; +*setbuf = $notmuch; +*setvbuf = $notmuch; + +*untaint = $notmuch; +*autoflush = $notmuch; +*fcntl = $notmuch; +*ioctl = $notmuch; + +*GETC = \&getc; +*PRINT = \&print; +*PRINTF = \&printf; +*READ = \&read; +*WRITE = \&write; +*SEEK = \&seek; +*TELL = \&getpos; +*EOF = \&eof; +*CLOSE = \&close; +*BINMODE = \&binmode; + + +sub string_ref +{ + my $self = shift; + return *$self->{buf}; +} +*sref = \&string_ref; + +1; + +__END__ + +=head1 NAME + +IO::String - Emulate file interface for in-core strings + +=head1 SYNOPSIS + + use IO::String; + $io = IO::String->new; + $io = IO::String->new($var); + tie *IO, 'IO::String'; + + # read data + <$io>; + $io->getline; + read($io, $buf, 100); + + # write data + print $io "string\n"; + $io->print(@data); + syswrite($io, $buf, 100); + + select $io; + printf "Some text %s\n", $str; + + # seek + $pos = $io->getpos; + $io->setpos(0); # rewind + $io->seek(-30, -1); + seek($io, 0, 0); + +=head1 DESCRIPTION + +The C module provides the C interface for in-core +strings. An C object can be attached to a string, and +makes it possible to use the normal file operations for reading or +writing data, as well as for seeking to various locations of the string. +This is useful when you want to use a library module that only +provides an interface to file handles on data that you have in a string +variable. + +Note that perl-5.8 and better has built-in support for "in memory" +files, which are set up by passing a reference instead of a filename +to the open() call. The reason for using this module is that it +makes the code backwards compatible with older versions of Perl. + +The C module provides an interface compatible with +C as distributed with F, but the following methods +are not available: new_from_fd, fdopen, format_write, +format_page_number, format_lines_per_page, format_lines_left, +format_name, format_top_name. + +The following methods are specific to the C class: + +=over 4 + +=item $io = IO::String->new + +=item $io = IO::String->new( $string ) + +The constructor returns a newly-created C object. It +takes an optional argument, which is the string to read from or write +into. If no $string argument is given, then an internal buffer +(initially empty) is allocated. + +The C object returned is tied to itself. This means +that you can use most Perl I/O built-ins on it too: readline, <>, getc, +print, printf, syswrite, sysread, close. + +=item $io->open + +=item $io->open( $string ) + +Attaches an existing IO::String object to some other $string, or +allocates a new internal buffer (if no argument is given). The +position is reset to 0. + +=item $io->string_ref + +Returns a reference to the string that is attached to +the C object. Most useful when you let the C +create an internal buffer to write into. + +=item $io->pad + +=item $io->pad( $char ) + +Specifies the padding to use if +the string is extended by either the seek() or truncate() methods. It +is a single character and defaults to "\0". + +=item $io->pos + +=item $io->pos( $newpos ) + +Yet another interface for reading and setting the current read/write +position within the string (the normal getpos/setpos/tell/seek +methods are also available). The pos() method always returns the +old position, and if you pass it an argument it sets the new +position. + +There is (deliberately) a difference between the setpos() and seek() +methods in that seek() extends the string (with the specified +padding) if you go to a location past the end, whereas setpos() +just snaps back to the end. If truncate() is used to extend the string, +then it works as seek(). + +=back + +=head1 BUGS + +In Perl versions < 5.6, the TIEHANDLE interface was incomplete. +If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will +not do anything on an C handle. See L for +details. + +=head1 SEE ALSO + +L, L, L + +=head1 COPYRIGHT + +Copyright 1998-2005 Gisle Aas. + +This library is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut diff --git a/lib/lib/IO/Stringy.pm b/lib/lib/IO/Stringy.pm new file mode 100644 index 0000000..c97c1d1 --- /dev/null +++ b/lib/lib/IO/Stringy.pm @@ -0,0 +1,446 @@ +package IO::Stringy; + +use vars qw($VERSION); +$VERSION = "2.111"; + +1; +__END__ + + +=head1 NAME + +IO-stringy - I/O on in-core objects like strings and arrays + + +=head1 SYNOPSIS + + IO:: + ::AtomicFile adpO Write a file which is updated atomically ERYQ + ::Lines bdpO I/O handle to read/write to array of lines ERYQ + ::Scalar RdpO I/O handle to read/write to a string ERYQ + ::ScalarArray RdpO I/O handle to read/write to array of scalars ERYQ + ::Wrap RdpO Wrap old-style FHs in standard OO interface ERYQ + ::WrapTie adpO Tie your handles & retain full OO interface ERYQ + + +=head1 DESCRIPTION + +This toolkit primarily provides modules for performing both traditional +and object-oriented i/o) on things I than normal filehandles; +in particular, L, L, +and L. + +In the more-traditional IO::Handle front, we +have L +which may be used to painlessly create files which are updated +atomically. + +And in the "this-may-prove-useful" corner, we have L, +whose exported wraphandle() function will clothe anything that's not +a blessed object in an IO::Handle-like wrapper... so you can just +use OO syntax and stop worrying about whether your function's caller +handed you a string, a globref, or a FileHandle. + + +=head1 WARNINGS + +Perl's TIEHANDLE spec was incomplete prior to 5.005_57; +it was missing support for C, C, and C. +Attempting to use these functions with an IO::Scalar, IO::ScalarArray, +IO::Lines, etc. B prior to 5.005_57. +None of the relevant methods will be invoked by Perl; +and even worse, this kind of bug can lie dormant for a while. +If you turn warnings on (via C<$^W> or C), and you see +something like this... + + seek() on unopened file + +...then you are probably trying to use one of these functions +on one of our IO:: classes with an old Perl. The remedy is to simply +use the OO version; e.g.: + + $SH->seek(0,0); ### GOOD: will work on any 5.005 + seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond + + + +=head1 INSTALLATION + + +=head2 Requirements + +As of version 2.x, this toolkit requires Perl 5.005 for +the IO::Handle subclasses, and 5.005_57 or better is +B recommended. See L<"WARNINGS"> for details. + + +=head2 Directions + +Most of you already know the drill... + + perl Makefile.PL + make + make test + make install + +For everyone else out there... +if you've never installed Perl code before, or you're trying to use +this in an environment where your sysadmin or ISP won't let you do +interesting things, B since this module contains no binary +extensions, you can cheat. That means copying the directory tree +under my "./lib" directory into someplace where your script can "see" +it. For example, under Linux: + + cp -r IO-stringy-1.234/lib/* /path/to/my/perl/ + +Now, in your Perl code, do this: + + use lib "/path/to/my/perl"; + use IO::Scalar; ### or whatever + +Ok, now you've been told. At this point, anyone who whines about +not being given enough information gets an unflattering haiku +written about them in the next change log. I'll do it. +Don't think I won't. + + + +=head1 VERSION + +$Id: Stringy.pm,v 1.3 2005/02/10 21:24:05 dfs Exp $ + + + +=head1 TO DO + +=over 4 + +=item (2000/08/02) Finalize $/ support + +Graham Barr submitted this patch half a I ago; +Like a moron, I lost his message under a ton of others, +and only now have the experimental implementation done. + +Will the sudden sensitivity to $/ hose anyone out there? +I'm worried, so you have to enable it explicitly in 1.x. +It will be on by default in 2.x, though only IO::Scalar +has been implemented. + +=item (2001/08/08) Remove IO::WrapTie from new IO:: classes + +It's not needed. Backwards compatibility could be maintained +by having new_tie() be identical to new(). Heck, I'll bet +that IO::WrapTie should be reimplemented so the returned +object is just like an IO::Scalar in its use of globrefs. + + +=back + + + +=head1 CHANGE LOG + +=over 4 + + +=item Version 2.110 (2005/02/10) + +Maintainership taken over by DSKOLL + +Closed the following bugs at +https://rt.cpan.org/NoAuth/Bugs.html?Dist=IO-stringy: + +=item + +2208 IO::ScalarArray->getline does not return undef for EOF if undef($/) + +=item + +7132 IO-stringy/Makefile.PL bug - name should be module name + +=item + +11249 IO::Scalar flush shouldn't return undef + +=item + +2172 $\ (output record separator) not respected + +=item + +8605 IO::InnerFile::seek() should return 1 on success + +=item + +4798 *.html in lib/ + +=item + +4369 Improvement: handling of fixed-size reads in IO::Scalar + +(Actually, bug 4369 was closed in Version 2.109) + +=item Version 2.109 (2003/12/21) + +IO::Scalar::getline now works with ref to int. +I + + +=item Version 2.108 (2001/08/20) + +The terms-of-use have been placed in the distribution file "COPYING". +Also, small documentation tweaks were made. + + +=item Version 2.105 (2001/08/09) + +Added support for various seek() whences to IO::ScalarArray. + +Added support for consulting $/ in IO::Scalar and IO::ScalarArray. +The old C is not even an option. +Unsupported record separators will cause a croak(). + +Added a lot of regression tests to supoprt the above. + +Better on-line docs (hyperlinks to individual functions). + + +=item Version 2.103 (2001/08/08) + +After sober consideration I have reimplemented IO::Scalar::print() +so that it once again always seeks to the end of the string. +Benchmarks show the new implementation to be just as fast as +Juergen's contributed patch; until someone can convince me otherwise, +the current, safer implementation stays. + +I thought more about giving IO::Scalar two separate handles, +one for reading and one for writing, as suggested by Binkley. +His points about what tell() and eof() return are, I think, +show-stoppers for this feature. Even the manpages for stdio's fseek() +seem to imply a I file position indicator, not two. +So I think I will take this off the TO DO list. +B you can always have two handles open on the same +scalar, one which you only write to, and one which you only read from. +That should give the same effect. + + +=item Version 2.101 (2001/08/07) + +B +This is the initial release of the "IO::Scalar and friends are +now subclasses of IO::Handle". I'm flinging it against the wall. +Please tell me if the banana sticks. When it does, the banana +will be called 2.2x. + +First off, I, who +has provided an I service by patching IO::Scalar +and friends so that they (1) inherit from IO::Handle, (2) automatically +tie themselves so that the C objects can be used in native i/o +constructs, and (3) doing it so that the whole damn thing passes +its regression tests. As Doug knows, my globref Kung-Fu was not +up to the task; he graciously provided the patches. This has earned +him a seat at the L table, and the +right to have me address him as I. + +Performance of IO::Scalar::print() has been improved by as much as 2x +for lots of little prints, with the cost of forcing those +who print-then-seek-then-print to explicitly seek to end-of-string +before printing again. +I + +Added the COPYING file, which had been missing from prior versions. +I + +IO::Scalar consults $/ by default (1.x ignored it by default). +Yes, I still need to support IO::ScalarArray. + + +=item Version 1.221 (2001/08/07) + +I threatened in L<"INSTALLATION"> to write an unflattering haiku +about anyone who whined that I gave them insufficient information... +but it turns out that I left out a crucial direction. D'OH! +I + + Enough info there? + Here's unflattering haiku: + Forgot the line, "make"! ;-) + + + +=item Version 1.220 (2001/04/03) + +Added untested SEEK, TELL, and EOF methods to IO::Scalar +and IO::ScalarArray to support corresponding functions for +tied filehandles: untested, because I'm still running 5.00556 +and Perl is complaining about "tell() on unopened file". +I + +Removed not-fully-blank lines from modules; these were causing +lots of POD-related warnings. +I + + +=item Version 1.219 (2001/02/23) + +IO::Scalar objects can now be made sensitive to $/ . +Pains were taken to keep the fast code fast while adding this feature. +I + + +=item Version 1.218 (2001/02/23) + +IO::Scalar has a new sysseek() method. +I + +New "TO DO" section, because people who submit patches/ideas should +at least know that they're in the system... and that I won't lose +their stuff. Please read it. + +New entries in L<"AUTHOR">. +Please read those too. + + + +=item Version 1.216 (2000/09/28) + +B +I thought I'd remembered a problem with this ages ago, related to +the fact that these IO:: modules don't have "real" filehandles, +but the problem apparently isn't surfacing now. +If you suddenly encounter Perl warnings during global destruction +(especially if you're using tied filehandles), then please let me know! +I + +B +Apparently, the offset and the number-of-bytes arguments were, +for all practical purposes, I You were okay if +you did all your writing with print(), but boy was I a stupid bug! +I + + Newspaper headline + typeset by dyslexic man + loses urgency + + BABY EATS FISH is + simply not equivalent + to FISH EATS BABY + +B +I + + +=item Version 1.215 (2000/09/05) + +Added 'bool' overload to '""' overload, so object always evaluates +to true. (Whew. Glad I caught this before it went to CPAN.) + + +=item Version 1.214 (2000/09/03) + +Evaluating an IO::Scalar in a string context now yields +the underlying string. +I + + +=item Version 1.213 (2000/08/16) + +Minor documentation fixes. + + +=item Version 1.212 (2000/06/02) + +Fixed IO::InnerFile incompatibility with Perl5.004. +I + + +=item Version 1.210 (2000/04/17) + +Added flush() and other no-op methods. +I + + +=item Version 1.209 (2000/03/17) + +Small bug fixes. + + +=item Version 1.208 (2000/03/14) + +Incorporated a number of contributed patches and extensions, +mostly related to speed hacks, support for "offset", and +WRITE/CLOSE methods. +I + + + +=item Version 1.206 (1999/04/18) + +Added creation of ./testout when Makefile.PL is run. + + +=item Version 1.205 (1999/01/15) + +Verified for Perl5.005. + + +=item Version 1.202 (1998/04/18) + +New IO::WrapTie and IO::AtomicFile added. + + +=item Version 1.110 + +Added IO::WrapTie. + + +=item Version 1.107 + +Added IO::Lines, and made some bug fixes to IO::ScalarArray. +Also, added getc(). + + +=item Version 1.105 + +No real changes; just upgraded IO::Wrap to have a $VERSION string. + +=back + + + + +=head1 AUTHOR + +=over 4 + +=item Primary Maintainer + +Dianne Skoll (F). + +=item Original Author + +Eryq (F). +President, ZeeGee Software Inc (F). + +=item Co-Authors + +For all their bug reports and patch submissions, the following +are officially recognized: + + Richard Jones + B. K. Oxley (binkley) + Doru Petrescu + Doug Wilson (for picking up the ball I dropped, and doing tie() right) + + +=back + +Go to F for the latest downloads +and on-line documentation for this module. + +Enjoy. Yell if it breaks. + + +=cut diff --git a/lib/lib/IO/Uncompress/Adapter/UnLzma.pm b/lib/lib/IO/Uncompress/Adapter/UnLzma.pm new file mode 100644 index 0000000..6cd2292 --- /dev/null +++ b/lib/lib/IO/Uncompress/Adapter/UnLzma.pm @@ -0,0 +1,156 @@ +package IO::Uncompress::Adapter::UnLzma; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.081 qw(:Status); + +use Compress::Raw::Lzma 2.081 ; + +our ($VERSION, @ISA); +$VERSION = '2.081'; + +#@ISA = qw( Compress::Raw::UnLzma ); + + +sub mkUncompObject +{ + #my $CompressedLength = shift; + #my $UncompressedLength = shift; + #my $small = shift || 0; + #my $verbosity = shift || 0; + + my ($inflate, $status) = Compress::Raw::Lzma::AloneDecoder->new(AppendOutput => 1, + ConsumeInput => 1, + LimitOutput => 1); + + return (undef, "Could not create AloneDecoder object: $status", $status) + if $status != LZMA_OK ; + + return bless {'Inf' => $inflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ConsumesInput' => 1, + #'CompressedLen' => $CompressedLength || 0, + #'UncompressedLen' => $UncompressedLength || 0, + } ; + +} + +sub mkUncompZipObject +{ + my $properties = shift ; + #my $CompressedLength = shift; + #my $UncompressedLength = shift; + #my $small = shift || 0; + #my $verbosity = shift || 0; + + my ($inflate, $status) = Compress::Raw::Lzma::RawDecoder->new(AppendOutput => 1, + Properties => $properties, + ConsumeInput => 1, + LimitOutput => 1); + + return (undef, "Could not create RawDecoder object: $status", $status) + if $status != LZMA_OK ; + + return bless {'Inf' => $inflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ConsumesInput' => 1, + #'CompressedLen' => $CompressedLength || 0, + #'UncompressedLen' => $UncompressedLength || 0, + } ; + +} + +sub uncompr +{ + my $self = shift ; + my $from = shift ; + my $to = shift ; + my $eof = shift ; + + my $inf = $self->{Inf}; + my $status = $inf->code($from, $to); + $self->{ErrorNo} = $status; + + if ($status != LZMA_OK && $status != LZMA_STREAM_END ) + { + $self->{Error} = "Uncompression Error: $status"; + return STATUS_ERROR; + } + + return STATUS_ENDSTREAM if $status == LZMA_STREAM_END || + ($eof && length $$from == 0); + + return STATUS_OK if $status == LZMA_OK ; + return STATUS_ERROR ; +} + + +sub reset +{ + my $self = shift ; + + my ($inf, $status) = Compress::Raw::Lzma::AloneDecoder->new(AppendOutput => 1, + ConsumeInput => 1, + LimitOutput => 1); + $self->{ErrorNo} = ($status == LZMA_OK) ? 0 : $status ; + + if ($status != LZMA_OK) + { + $self->{Error} = "Cannot create UnLzma object: $status"; + return STATUS_ERROR; + } + + $self->{Inf} = $inf; + + return STATUS_OK ; +} + +#sub count +#{ +# my $self = shift ; +# $self->{Inf}->inflateCount(); +#} + +sub compressedBytes +{ + my $self = shift ; + $self->{Inf}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Inf}->uncompressedBytes(); +} + +sub crc32 +{ + my $self = shift ; + #$self->{Inf}->crc32(); +} + +sub adler32 +{ + my $self = shift ; + #$self->{Inf}->adler32(); +} + +sub sync +{ + my $self = shift ; + #( $self->{Inf}->inflateSync(@_) == LZMA_OK) + # ? STATUS_OK + # : STATUS_ERROR ; +} + + +1; + +__END__ + diff --git a/lib/lib/IO/Uncompress/Adapter/UnXz.pm b/lib/lib/IO/Uncompress/Adapter/UnXz.pm new file mode 100644 index 0000000..da0950e --- /dev/null +++ b/lib/lib/IO/Uncompress/Adapter/UnXz.pm @@ -0,0 +1,130 @@ +package IO::Uncompress::Adapter::UnXz; + +use strict; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.081 qw(:Status); + +use Compress::Raw::Lzma 2.081 ; + +our ($VERSION, @ISA); +$VERSION = '2.081'; + +#@ISA = qw( Compress::Raw::UnLzma ); + + +sub mkUncompObject +{ + my $memlimit = shift || 128 * 1024 * 1024; + my $flags = shift || 0; + + my ($inflate, $status) = + Compress::Raw::Lzma::StreamDecoder->new(AppendOutput => 1, + ConsumeInput => 1, + LimitOutput => 1, + MemLimit => $memlimit, + Flags => $flags, + ); + + return (undef, "Could not create StreamDecoder object: $status", $status) + if $status != LZMA_OK ; + + return bless {'Inf' => $inflate, + 'CompSize' => 0, + 'UnCompSize' => 0, + 'Error' => '', + 'ConsumesInput' => 1, + } ; + +} + +sub uncompr +{ + my $self = shift ; + my $from = shift ; + my $to = shift ; + my $eof = shift ; + + my $inf = $self->{Inf}; + + my $status = $inf->code($from, $to); + $self->{ErrorNo} = $status; + + if ($status != LZMA_OK && $status != LZMA_STREAM_END ) + { + $self->{Error} = "Uncompression Error: $status"; + return STATUS_ERROR; + } + + + return STATUS_OK if $status == LZMA_OK ; + return STATUS_ENDSTREAM if $status == LZMA_STREAM_END ; + return STATUS_ERROR ; +} + + +sub reset +{ + my $self = shift ; + + my ($inf, $status) = + Compress::Raw::Lzma::StreamDecoder->new(AppendOutput => 1, + ConsumeInput => 1, + LimitOutput => 1); + $self->{ErrorNo} = ($status == LZMA_OK) ? 0 : $status ; + + if ($status != LZMA_OK) + { + $self->{Error} = "Cannot create UnXz object: $status"; + return STATUS_ERROR; + } + + $self->{Inf} = $inf; + + return STATUS_OK ; +} + +#sub count +#{ +# my $self = shift ; +# $self->{Inf}->inflateCount(); +#} + +sub compressedBytes +{ + my $self = shift ; + $self->{Inf}->compressedBytes(); +} + +sub uncompressedBytes +{ + my $self = shift ; + $self->{Inf}->uncompressedBytes(); +} + +sub crc32 +{ + my $self = shift ; + #$self->{Inf}->crc32(); +} + +sub adler32 +{ + my $self = shift ; + #$self->{Inf}->adler32(); +} + +sub sync +{ + my $self = shift ; + #( $self->{Inf}->inflateSync(@_) == LZMA_OK) + # ? STATUS_OK + # : STATUS_ERROR ; +} + + +1; + +__END__ + diff --git a/lib/lib/IO/Uncompress/UnLzma.pm b/lib/lib/IO/Uncompress/UnLzma.pm new file mode 100644 index 0000000..0a6ab91 --- /dev/null +++ b/lib/lib/IO/Uncompress/UnLzma.pm @@ -0,0 +1,974 @@ +package IO::Uncompress::UnLzma ; + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.081 qw(:Status createSelfTiedObject); + +use IO::Uncompress::Base 2.081 ; +use IO::Uncompress::Adapter::UnLzma 2.081 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnLzmaError); + +$VERSION = '2.081'; +$UnLzmaError = ''; + +@ISA = qw( IO::Uncompress::Base Exporter ); +@EXPORT_OK = qw( $UnLzmaError unlzma ) ; +#%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +#Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + my $obj = createSelfTiedObject($class, \$UnLzmaError); + + $obj->_create(undef, 0, @_); +} + +sub unlzma +{ + my $obj = createSelfTiedObject(undef, \$UnLzmaError); + return $obj->_inf(@_); +} + +#our %PARAMS = ( + #'verbosity' => [IO::Compress::Base::Common::Parse_boolean, 0], + #'small' => [IO::Compress::Base::Common::Parse_boolean, 0], +# ); + +sub getExtraParams +{ + return (); +} + + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $got = shift ; + + #my $Small = $got->getValue('small'); + #my $Verbosity = $got->getValue('verbosity'); + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnLzma::mkUncompObject( + ); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + *$self->{Info} = $self->ckMagic() + or return 0 ; + + return 1; +} + + +sub ckMagic +{ + my $self = shift; + + my $got = $self->isLzma(@_); + + if ($got) { + *$self->{Pending} = *$self->{HeaderPending} ; + } + else { + $self->pushBack(*$self->{HeaderPending}); + *$self->{Uncomp}->reset(); + } + *$self->{HeaderPending} = ''; + + return $got ; +} + + +sub isLzma +{ + my $self = shift ; + my $magic = shift; + + $magic = '' unless defined $magic ; + + my $buffer = ''; + + $self->smartRead(\$buffer, *$self->{BlockSize}) >= 0 + or return $self->saveErrorString(undef, "No data to read"); + + my $temp_buf = $magic . $buffer ; + *$self->{HeaderPending} = $temp_buf ; + $buffer = ''; + my $status = *$self->{Uncomp}->uncompr(\$temp_buf, \$buffer, $self->smartEof()) ; + + return $self->saveErrorString(undef, *$self->{Uncomp}{Error}, STATUS_ERROR) + if $status == STATUS_ERROR; + + $self->pushBack($temp_buf) ; + + return $self->saveErrorString(undef, "unexpected end of file", STATUS_ERROR) + if $self->smartEof() && $status != STATUS_ENDSTREAM; + + #my $buf_len = *$self->{Uncomp}->uncompressedBytes(); + my $buf_len = length $buffer; + + if ($status == STATUS_ENDSTREAM) { + if (*$self->{MultiStream} + && (length $temp_buf || ! $self->smartEof())){ + *$self->{NewStream} = 1 ; + *$self->{EndStream} = 0 ; + } + else { + *$self->{EndStream} = 1 ; + } + } + *$self->{HeaderPending} = $buffer ; + *$self->{InflatedBytesRead} = $buf_len ; + *$self->{TotalInflatedBytesRead} += $buf_len ; + *$self->{Type} = 'lzma'; + + $self->saveStatus(STATUS_OK); + + return { + 'Type' => 'lzma', + 'HeaderLength' => 0, + 'TrailerLength' => 0, + 'Header' => '' + }; + + + return ''; + +# my $magic ; +# $self->smartReadExact(\$magic, 4); +# +# *$self->{HeaderPending} = $magic ; +# +# return $self->HeaderError("Header size is " . +# 4 . " bytes") +# if length $magic != 4; +# +# return $self->HeaderError("Bad Magic.") +# if ! isBzip2Magic($magic) ; +# +# +# *$self->{Type} = 'bzip2'; +# return $magic; +} + + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + $self->pushBack($magic); + *$self->{HeaderPending} = ''; + + + return { + 'Type' => 'lzma', + 'FingerprintLength' => 0, + 'HeaderLength' => 0, + 'TrailerLength' => 0, + 'Header' => '' + }; + +} + +sub chkTrailer +{ + return STATUS_OK; +} + + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::UnLzma - Read lzma files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::UnLzma qw(unlzma $UnLzmaError) ; + + my $status = unlzma $input => $output [,OPTS] + or die "unlzma failed: $UnLzmaError\n"; + + my $z = new IO::Uncompress::UnLzma $input [OPTS] + or die "unlzma failed: $UnLzmaError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $UnLzmaError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +B. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + +This module provides a Perl interface that allows the reading of +lzma files/buffers. + +For writing lzma files/buffers, see the companion module IO::Compress::Lzma. + +=head1 Functional Interface + +A top-level function, C, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L +section. + + use IO::Uncompress::UnLzma qw(unlzma $UnLzmaError) ; + + unlzma $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "unlzma failed: $UnLzmaError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 unlzma $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The input is the list of files that match the +fileglob. + +See L for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C, +C, are the same as those used with the OO interface defined in the +L section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C that are filehandles. + +If C is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C is enabled, the filehandle will be positioned to the end of +the file via a call to C before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C is specified, and set to true, it will I all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C by setting the +C option. + +=back + +=head2 Examples + +To read the contents of the file C and write the +uncompressed data to the file C. + + use strict ; + use warnings ; + use IO::Uncompress::UnLzma qw(unlzma $UnLzmaError) ; + + my $input = "file1.txt.lzma"; + my $output = "file1.txt"; + unlzma $input => $output + or die "unlzma failed: $UnLzmaError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::UnLzma qw(unlzma $UnLzmaError) ; + use IO::File ; + + my $input = new IO::File " \$buffer + or die "unlzma failed: $UnLzmaError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.lzma" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::UnLzma qw(unlzma $UnLzmaError) ; + + unlzma '' => '' + or die "unlzma failed: $UnLzmaError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::UnLzma qw(unlzma $UnLzmaError) ; + + for my $input ( glob "/my/home/*.txt.lzma" ) + { + my $output = $input; + $output =~ s/.lzma// ; + unlzma $input => $output + or die "Error compressing '$input': $UnLzmaError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::UnLzma is shown below + + my $z = new IO::Uncompress::UnLzma $input [OPTS] + or die "IO::Uncompress::UnLzma failed: $UnLzmaError\n"; + +Returns an C object on success and undef on failure. +The variable C<$UnLzmaError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::UnLzma can be used exactly like an L filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C method is called or the IO::Uncompress::UnLzma object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::UnLzma will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C method. + +If set to 0, the contents of the output parameter of the C method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C method and the +previous one, is that this one will attempt to return I C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C. + +B that the special variable C<$|> B be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C +will return the underlying file descriptor. Once the C method is +called C will return C. + +If the C<$z> object is associated with a buffer, this method will return +C. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::UnLzma object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C option has been enabled when the IO::Uncompress::UnLzma +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C by setting the +C option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::UnLzma at present. + +=over 5 + +=item :all + +Imports C and C<$UnLzmaError>. +Same as doing this + + use IO::Uncompress::UnLzma qw(unlzma $UnLzmaError) ; + +=back + +=head1 EXAMPLES + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + +=head1 AUTHOR + +This module was written by Paul Marquess, C. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2018 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/lib/lib/IO/Uncompress/UnXz.pm b/lib/lib/IO/Uncompress/UnXz.pm new file mode 100644 index 0000000..45a6ba5 --- /dev/null +++ b/lib/lib/IO/Uncompress/UnXz.pm @@ -0,0 +1,925 @@ +package IO::Uncompress::UnXz ; + +use strict ; +use warnings; +use bytes; + +use IO::Compress::Base::Common 2.081 qw(:Status createSelfTiedObject); + +use IO::Uncompress::Base 2.081 ; +use IO::Uncompress::Adapter::UnXz 2.081 ; + +require Exporter ; +our ($VERSION, @ISA, @EXPORT_OK, %EXPORT_TAGS, $UnXzError); + +$VERSION = '2.081'; +$UnXzError = ''; + +@ISA = qw( IO::Uncompress::Base Exporter ); +@EXPORT_OK = qw( $UnXzError unxz ) ; +#%EXPORT_TAGS = %IO::Uncompress::Base::EXPORT_TAGS ; +push @{ $EXPORT_TAGS{all} }, @EXPORT_OK ; +#Exporter::export_ok_tags('all'); + + +sub new +{ + my $class = shift ; + my $obj = createSelfTiedObject($class, \$UnXzError); + + $obj->_create(undef, 0, @_); +} + +sub unxz +{ + my $obj = createSelfTiedObject(undef, \$UnXzError); + return $obj->_inf(@_); +} + +our %PARAMS = ( + 'memlimit' => [IO::Compress::Base::Common::Parse_unsigned, 128 * 1024 * 1024], + 'flags' => [IO::Compress::Base::Common::Parse_boolean, 0], + ); + +sub getExtraParams +{ + return %PARAMS ; +} + + +sub ckParams +{ + my $self = shift ; + my $got = shift ; + + return 1; +} + +sub mkUncomp +{ + my $self = shift ; + my $got = shift ; + + my $magic = $self->ckMagic() + or return 0; + + *$self->{Info} = $self->readHeader($magic) + or return undef ; + + my $memlimit = $got->getValue('memlimit'); + my $flags = $got->getValue('flags'); + + my ($obj, $errstr, $errno) = IO::Uncompress::Adapter::UnXz::mkUncompObject( + $memlimit, $flags); + + return $self->saveErrorString(undef, $errstr, $errno) + if ! defined $obj; + + *$self->{Uncomp} = $obj; + + return 1; + +} + + +use constant XZ_ID_SIZE => 6; +use constant XZ_MAGIC => "\0xFD". '7zXZ'. "\0x00" ; + +sub ckMagic +{ + my $self = shift; + + my $magic ; + $self->smartReadExact(\$magic, XZ_ID_SIZE); + + *$self->{HeaderPending} = $magic ; + + return $self->HeaderError("Header size is " . + XZ_ID_SIZE . " bytes") + if length $magic != XZ_ID_SIZE; + + return $self->HeaderError("Bad Magic.") + if ! isXzMagic($magic) ; + + + *$self->{Type} = 'xz'; + return $magic; +} + +sub readHeader +{ + my $self = shift; + my $magic = shift ; + + $self->pushBack($magic); + *$self->{HeaderPending} = ''; + + + return { + 'Type' => 'xz', + 'FingerprintLength' => XZ_ID_SIZE, + 'HeaderLength' => XZ_ID_SIZE, + 'TrailerLength' => 0, + 'Header' => '$magic' + }; + +} + +sub chkTrailer +{ + return STATUS_OK; +} + + + +sub isXzMagic +{ + my $buffer = shift ; + return $buffer =~ /^\xFD\x37\x7A\x58\x5A\x00/; +} + +1 ; + +__END__ + + +=head1 NAME + +IO::Uncompress::UnXz - Read xz files/buffers + +=head1 SYNOPSIS + + use IO::Uncompress::UnXz qw(unxz $UnXzError) ; + + my $status = unxz $input => $output [,OPTS] + or die "unxz failed: $UnXzError\n"; + + my $z = new IO::Uncompress::UnXz $input [OPTS] + or die "unxz failed: $UnXzError\n"; + + $status = $z->read($buffer) + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + $line = $z->getline() + $char = $z->getc() + $char = $z->ungetc() + $char = $z->opened() + + $data = $z->trailingData() + $status = $z->nextStream() + $data = $z->getHeaderInfo() + $z->tell() + $z->seek($position, $whence) + $z->binmode() + $z->fileno() + $z->eof() + $z->close() + + $UnXzError ; + + # IO::File mode + + <$z> + read($z, $buffer); + read($z, $buffer, $length); + read($z, $buffer, $length, $offset); + tell($z) + seek($z, $position, $whence) + binmode($z) + fileno($z) + eof($z) + close($z) + +=head1 DESCRIPTION + +B. + +=over 5 + +=item * DO NOT use in production code. + +=item * The documentation is incomplete in places. + +=item * Parts of the interface defined here are tentative. + +=item * Please report any problems you find. + +=back + +This module provides a Perl interface that allows the reading of +lzma files/buffers. + +For writing xz files/buffers, see the companion module IO::Compress::Xz. + +=head1 Functional Interface + +A top-level function, C, is provided to carry out +"one-shot" uncompression between buffers and/or files. For finer +control over the uncompression process, see the L +section. + + use IO::Uncompress::UnXz qw(unxz $UnXzError) ; + + unxz $input_filename_or_reference => $output_filename_or_reference [,OPTS] + or die "unxz failed: $UnXzError\n"; + +The functional interface needs Perl5.005 or better. + +=head2 unxz $input_filename_or_reference => $output_filename_or_reference [, OPTS] + +C expects at least two parameters, +C<$input_filename_or_reference> and C<$output_filename_or_reference>. + +=head3 The C<$input_filename_or_reference> parameter + +The parameter, C<$input_filename_or_reference>, is used to define the +source of the compressed data. + +It can take one of the following forms: + +=over 5 + +=item A filename + +If the <$input_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for reading and the +input data will be read from it. + +=item A filehandle + +If the C<$input_filename_or_reference> parameter is a filehandle, the input +data will be read from it. The string '-' can be used as an alias for +standard input. + +=item A scalar reference + +If C<$input_filename_or_reference> is a scalar reference, the input data +will be read from C<$$input_filename_or_reference>. + +=item An array reference + +If C<$input_filename_or_reference> is an array reference, each element in +the array must be a filename. + +The input data will be read from each file in turn. + +The complete array will be walked to ensure that it only +contains valid filenames before any data is uncompressed. + +=item An Input FileGlob string + +If C<$input_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The input is the list of files that match the +fileglob. + +See L for more details. + +=back + +If the C<$input_filename_or_reference> parameter is any other type, +C will be returned. + +=head3 The C<$output_filename_or_reference> parameter + +The parameter C<$output_filename_or_reference> is used to control the +destination of the uncompressed data. This parameter can take one of +these forms. + +=over 5 + +=item A filename + +If the C<$output_filename_or_reference> parameter is a simple scalar, it is +assumed to be a filename. This file will be opened for writing and the +uncompressed data will be written to it. + +=item A filehandle + +If the C<$output_filename_or_reference> parameter is a filehandle, the +uncompressed data will be written to it. The string '-' can be used as +an alias for standard output. + +=item A scalar reference + +If C<$output_filename_or_reference> is a scalar reference, the +uncompressed data will be stored in C<$$output_filename_or_reference>. + +=item An Array Reference + +If C<$output_filename_or_reference> is an array reference, +the uncompressed data will be pushed onto the array. + +=item An Output FileGlob + +If C<$output_filename_or_reference> is a string that is delimited by the +characters "<" and ">" C will assume that it is an +I. The output is the list of files that match the +fileglob. + +When C<$output_filename_or_reference> is an fileglob string, +C<$input_filename_or_reference> must also be a fileglob string. Anything +else is an error. + +See L for more details. + +=back + +If the C<$output_filename_or_reference> parameter is any other type, +C will be returned. + +=head2 Notes + +When C<$input_filename_or_reference> maps to multiple compressed +files/buffers and C<$output_filename_or_reference> is +a single file/buffer, after uncompression C<$output_filename_or_reference> will contain a +concatenation of all the uncompressed data from each of the input +files/buffers. + +=head2 Optional Parameters + +Unless specified below, the optional parameters for C, +C, are the same as those used with the OO interface defined in the +L section below. + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option applies to any input or output data streams to +C that are filehandles. + +If C is specified, and the value is true, it will result in all +input and/or output filehandles being closed once C has +completed. + +This parameter defaults to 0. + +=item C<< BinModeOut => 0|1 >> + +When writing to a file or filehandle, set C before writing to the +file. + +Defaults to 0. + +=item C<< Append => 0|1 >> + +The behaviour of this option is dependent on the type of output data +stream. + +=over 5 + +=item * A Buffer + +If C is enabled, all uncompressed data will be append to the end of +the output buffer. Otherwise the output buffer will be cleared before any +uncompressed data is written to it. + +=item * A Filename + +If C is enabled, the file will be opened in append mode. Otherwise +the contents of the file, if any, will be truncated before any uncompressed +data is written to it. + +=item * A Filehandle + +If C is enabled, the filehandle will be positioned to the end of +the file via a call to C before any uncompressed data is +written to it. Otherwise the file pointer will not be moved. + +=back + +When C is specified, and set to true, it will I all uncompressed +data to the output data stream. + +So when the output is a filehandle it will carry out a seek to the eof +before writing any uncompressed data. If the output is a filename, it will be opened for +appending. If the output is a buffer, all uncompressed data will be +appended to the existing buffer. + +Conversely when C is not specified, or it is present and is set to +false, it will operate as follows. + +When the output is a filename, it will truncate the contents of the file +before writing any uncompressed data. If the output is a filehandle +its position will not be changed. If the output is a buffer, it will be +wiped before any uncompressed data is output. + +Defaults to 0. + +=item C<< MultiStream => 0|1 >> + +If the input file/buffer contains multiple compressed data streams, this +option will uncompress the whole lot as a single data stream. + +Defaults to 0. + +=item C<< TrailingData => $scalar >> + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C by setting the +C option. + +=back + +=head2 Examples + +To read the contents of the file C and write the +uncompressed data to the file C. + + use strict ; + use warnings ; + use IO::Uncompress::UnXz qw(unxz $UnXzError) ; + + my $input = "file1.txt.xz"; + my $output = "file1.txt"; + unxz $input => $output + or die "unxz failed: $UnXzError\n"; + +To read from an existing Perl filehandle, C<$input>, and write the +uncompressed data to a buffer, C<$buffer>. + + use strict ; + use warnings ; + use IO::Uncompress::UnXz qw(unxz $UnXzError) ; + use IO::File ; + + my $input = new IO::File " \$buffer + or die "unxz failed: $UnXzError\n"; + +To uncompress all files in the directory "/my/home" that match "*.txt.xz" and store the compressed data in the same directory + + use strict ; + use warnings ; + use IO::Uncompress::UnXz qw(unxz $UnXzError) ; + + unxz '' => '' + or die "unxz failed: $UnXzError\n"; + +and if you want to compress each file one at a time, this will do the trick + + use strict ; + use warnings ; + use IO::Uncompress::UnXz qw(unxz $UnXzError) ; + + for my $input ( glob "/my/home/*.txt.xz" ) + { + my $output = $input; + $output =~ s/.xz// ; + unxz $input => $output + or die "Error compressing '$input': $UnXzError\n"; + } + +=head1 OO Interface + +=head2 Constructor + +The format of the constructor for IO::Uncompress::UnXz is shown below + + my $z = new IO::Uncompress::UnXz $input [OPTS] + or die "IO::Uncompress::UnXz failed: $UnXzError\n"; + +Returns an C object on success and undef on failure. +The variable C<$UnXzError> will contain an error message on failure. + +If you are running Perl 5.005 or better the object, C<$z>, returned from +IO::Uncompress::UnXz can be used exactly like an L filehandle. +This means that all normal input file operations can be carried out with +C<$z>. For example, to read a line from a compressed file/buffer you can +use either of these forms + + $line = $z->getline(); + $line = <$z>; + +The mandatory parameter C<$input> is used to determine the source of the +compressed data. This parameter can take one of three forms. + +=over 5 + +=item A filename + +If the C<$input> parameter is a scalar, it is assumed to be a filename. This +file will be opened for reading and the compressed data will be read from it. + +=item A filehandle + +If the C<$input> parameter is a filehandle, the compressed data will be +read from it. +The string '-' can be used as an alias for standard input. + +=item A scalar reference + +If C<$input> is a scalar reference, the compressed data will be read from +C<$$input>. + +=back + +=head2 Constructor Options + +The option names defined below are case insensitive and can be optionally +prefixed by a '-'. So all of the following are valid + + -AutoClose + -autoclose + AUTOCLOSE + autoclose + +OPTS is a combination of the following options: + +=over 5 + +=item C<< AutoClose => 0|1 >> + +This option is only valid when the C<$input> parameter is a filehandle. If +specified, and the value is true, it will result in the file being closed once +either the C method is called or the IO::Uncompress::UnXz object is +destroyed. + +This parameter defaults to 0. + +=item C<< MultiStream => 0|1 >> + +Allows multiple concatenated compressed streams to be treated as a single +compressed stream. Decompression will stop once either the end of the +file/buffer is reached, an error is encountered (premature eof, corrupt +compressed data) or the end of a stream is not immediately followed by the +start of another stream. + +This parameter defaults to 0. + +=item C<< Prime => $string >> + +This option will uncompress the contents of C<$string> before processing the +input file/buffer. + +This option can be useful when the compressed data is embedded in another +file/data structure and it is not possible to work out where the compressed +data begins without having to read the first few bytes. If this is the +case, the uncompression can be I with these bytes using this +option. + +=item C<< Transparent => 0|1 >> + +If this option is set and the input file/buffer is not compressed data, +the module will allow reading of it anyway. + +In addition, if the input file/buffer does contain compressed data and +there is non-compressed data immediately following it, setting this option +will make this module treat the whole file/buffer as a single data stream. + +This option defaults to 1. + +=item C<< BlockSize => $num >> + +When reading the compressed input data, IO::Uncompress::UnXz will read it in +blocks of C<$num> bytes. + +This option defaults to 4096. + +=item C<< InputLength => $size >> + +When present this option will limit the number of compressed bytes read +from the input file/buffer to C<$size>. This option can be used in the +situation where there is useful data directly after the compressed data +stream and you know beforehand the exact length of the compressed data +stream. + +This option is mostly used when reading from a filehandle, in which case +the file pointer will be left pointing to the first byte directly after the +compressed data stream. + +This option defaults to off. + +=item C<< Append => 0|1 >> + +This option controls what the C method does with uncompressed data. + +If set to 1, all uncompressed data will be appended to the output parameter +of the C method. + +If set to 0, the contents of the output parameter of the C method +will be overwritten by the uncompressed data. + +Defaults to 0. + +=item C<< Strict => 0|1 >> + +This option controls whether the extra checks defined below are used when +carrying out the decompression. When Strict is on, the extra tests are +carried out, when Strict is off they are not. + +The default for this option is off. + +=item C<< MemLimit => $number >> + +Default is 128Meg. + +=item C<< Flags => $flags >> + +Default is 0. + +=back + +=head2 Examples + +TODO + +=head1 Methods + +=head2 read + +Usage is + + $status = $z->read($buffer) + +Reads a block of compressed data (the size of the compressed block is +determined by the C option in the constructor), uncompresses it and +writes any uncompressed data into C<$buffer>. If the C parameter is +set in the constructor, the uncompressed data will be appended to the +C<$buffer> parameter. Otherwise C<$buffer> will be overwritten. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 read + +Usage is + + $status = $z->read($buffer, $length) + $status = $z->read($buffer, $length, $offset) + + $status = read($z, $buffer, $length) + $status = read($z, $buffer, $length, $offset) + +Attempt to read C<$length> bytes of uncompressed data into C<$buffer>. + +The main difference between this form of the C method and the +previous one, is that this one will attempt to return I C<$length> +bytes. The only circumstances that this function will not is if end-of-file +or an IO error is encountered. + +Returns the number of uncompressed bytes written to C<$buffer>, zero if eof +or a negative number on error. + +=head2 getline + +Usage is + + $line = $z->getline() + $line = <$z> + +Reads a single line. + +This method fully supports the use of the variable C<$/> (or +C<$INPUT_RECORD_SEPARATOR> or C<$RS> when C is in use) to +determine what constitutes an end of line. Paragraph mode, record mode and +file slurp mode are all supported. + +=head2 getc + +Usage is + + $char = $z->getc() + +Read a single character. + +=head2 ungetc + +Usage is + + $char = $z->ungetc($string) + +=head2 getHeaderInfo + +Usage is + + $hdr = $z->getHeaderInfo(); + @hdrs = $z->getHeaderInfo(); + +This method returns either a hash reference (in scalar context) or a list +or hash references (in array context) that contains information about each +of the header fields in the compressed data stream(s). + +=head2 tell + +Usage is + + $z->tell() + tell $z + +Returns the uncompressed file offset. + +=head2 eof + +Usage is + + $z->eof(); + eof($z); + +Returns true if the end of the compressed input stream has been reached. + +=head2 seek + + $z->seek($position, $whence); + seek($z, $position, $whence); + +Provides a sub-set of the C functionality, with the restriction +that it is only legal to seek forward in the input file/buffer. +It is a fatal error to attempt to seek backward. + +Note that the implementation of C in this module does not provide +true random access to a compressed file/buffer. It works by uncompressing +data from the current offset in the file/buffer until it reaches the +uncompressed offset specified in the parameters to C. For very small +files this may be acceptable behaviour. For large files it may cause an +unacceptable delay. + +The C<$whence> parameter takes one the usual values, namely SEEK_SET, +SEEK_CUR or SEEK_END. + +Returns 1 on success, 0 on failure. + +=head2 binmode + +Usage is + + $z->binmode + binmode $z ; + +This is a noop provided for completeness. + +=head2 opened + + $z->opened() + +Returns true if the object currently refers to a opened file/buffer. + +=head2 autoflush + + my $prev = $z->autoflush() + my $prev = $z->autoflush(EXPR) + +If the C<$z> object is associated with a file or a filehandle, this method +returns the current autoflush setting for the underlying filehandle. If +C is present, and is non-zero, it will enable flushing after every +write/print operation. + +If C<$z> is associated with a buffer, this method has no effect and always +returns C. + +B that the special variable C<$|> B be used to set or +retrieve the autoflush setting. + +=head2 input_line_number + + $z->input_line_number() + $z->input_line_number(EXPR) + +Returns the current uncompressed line number. If C is present it has +the effect of setting the line number. Note that setting the line number +does not change the current position within the file/buffer being read. + +The contents of C<$/> are used to determine what constitutes a line +terminator. + +=head2 fileno + + $z->fileno() + fileno($z) + +If the C<$z> object is associated with a file or a filehandle, C +will return the underlying file descriptor. Once the C method is +called C will return C. + +If the C<$z> object is associated with a buffer, this method will return +C. + +=head2 close + + $z->close() ; + close $z ; + +Closes the output file/buffer. + +For most versions of Perl this method will be automatically invoked if +the IO::Uncompress::UnXz object is destroyed (either explicitly or by the +variable with the reference to the object going out of scope). The +exceptions are Perl versions 5.005 through 5.00504 and 5.8.0. In +these cases, the C method will be called automatically, but +not until global destruction of all live objects when the program is +terminating. + +Therefore, if you want your scripts to be able to run on all versions +of Perl, you should call C explicitly and not rely on automatic +closing. + +Returns true on success, otherwise 0. + +If the C option has been enabled when the IO::Uncompress::UnXz +object was created, and the object is associated with a file, the +underlying file will also be closed. + +=head2 nextStream + +Usage is + + my $status = $z->nextStream(); + +Skips to the next compressed data stream in the input file/buffer. If a new +compressed data stream is found, the eof marker will be cleared and C<$.> +will be reset to 0. + +Returns 1 if a new stream was found, 0 if none was found, and -1 if an +error was encountered. + +=head2 trailingData + +Usage is + + my $data = $z->trailingData(); + +Returns the data, if any, that is present immediately after the compressed +data stream once uncompression is complete. It only makes sense to call +this method once the end of the compressed data stream has been +encountered. + +This option can be used when there is useful information immediately +following the compressed data stream, and you don't know the length of the +compressed data stream. + +If the input is a buffer, C will return everything from the +end of the compressed data stream to the end of the buffer. + +If the input is a filehandle, C will return the data that is +left in the filehandle input buffer once the end of the compressed data +stream has been reached. You can then use the filehandle to read the rest +of the input file. + +Don't bother using C if the input is a filename. + +If you know the length of the compressed data stream before you start +uncompressing, you can avoid having to use C by setting the +C option in the constructor. + +=head1 Importing + +No symbolic constants are required by this IO::Uncompress::UnXz at present. + +=over 5 + +=item :all + +Imports C and C<$UnXzError>. +Same as doing this + + use IO::Uncompress::UnXz qw(unxz $UnXzError) ; + +=back + +=head1 EXAMPLES + +=head1 SEE ALSO + +L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L + +L + +L, L, +L, +L + +=head1 AUTHOR + +This module was written by Paul Marquess, C. + +=head1 MODIFICATION HISTORY + +See the Changes file. + +=head1 COPYRIGHT AND LICENSE + +Copyright (c) 2005-2018 Paul Marquess. All rights reserved. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + diff --git a/lib/lib/IO/Wrap.pm b/lib/lib/IO/Wrap.pm new file mode 100644 index 0000000..ad64f12 --- /dev/null +++ b/lib/lib/IO/Wrap.pm @@ -0,0 +1,228 @@ +package IO::Wrap; + +# SEE DOCUMENTATION AT BOTTOM OF FILE + +require 5.002; + +use strict; +use vars qw(@ISA @EXPORT $VERSION); +@ISA = qw(Exporter); +@EXPORT = qw(wraphandle); + +use FileHandle; +use Carp; + +# The package version, both in 1.23 style *and* usable by MakeMaker: +$VERSION = "2.111"; + + +#------------------------------ +# wraphandle RAW +#------------------------------ +sub wraphandle { + my $raw = shift; + new IO::Wrap $raw; +} + +#------------------------------ +# new STREAM +#------------------------------ +sub new { + my ($class, $stream) = @_; + no strict 'refs'; + + ### Convert raw scalar to globref: + ref($stream) or $stream = \*$stream; + + ### Wrap globref and incomplete objects: + if ((ref($stream) eq 'GLOB') or ### globref + (ref($stream) eq 'FileHandle') && !defined(&FileHandle::read)) { + return bless \$stream, $class; + } + $stream; ### already okay! +} + +#------------------------------ +# I/O methods... +#------------------------------ +sub close { + my $self = shift; + return close($$self); +} +sub fileno { + my $self = shift; + my $fh = $$self; + return fileno($fh); +} + +sub getline { + my $self = shift; + my $fh = $$self; + return scalar(<$fh>); +} +sub getlines { + my $self = shift; + wantarray or croak("Can't call getlines in scalar context!"); + my $fh = $$self; + <$fh>; +} +sub print { + my $self = shift; + print { $$self } @_; +} +sub read { + my $self = shift; + return read($$self, $_[0], $_[1]); +} +sub seek { + my $self = shift; + return seek($$self, $_[0], $_[1]); +} +sub tell { + my $self = shift; + return tell($$self); +} + +#------------------------------ +1; +__END__ + + +=head1 NAME + +IO::Wrap - wrap raw filehandles in IO::Handle interface + + +=head1 SYNOPSIS + + use IO::Wrap; + + ### Do stuff with any kind of filehandle (including a bare globref), or + ### any kind of blessed object that responds to a print() message. + ### + sub do_stuff { + my $fh = shift; + + ### At this point, we have no idea what the user gave us... + ### a globref? a FileHandle? a scalar filehandle name? + + $fh = wraphandle($fh); + + ### At this point, we know we have an IO::Handle-like object! + + $fh->print("Hey there!"); + ... + } + + +=head1 DESCRIPTION + +Let's say you want to write some code which does I/O, but you don't +want to force the caller to provide you with a FileHandle or IO::Handle +object. You want them to be able to say: + + do_stuff(\*STDOUT); + do_stuff('STDERR'); + do_stuff($some_FileHandle_object); + do_stuff($some_IO_Handle_object); + +And even: + + do_stuff($any_object_with_a_print_method); + +Sure, one way to do it is to force the caller to use tiehandle(). +But that puts the burden on them. Another way to do it is to +use B, which provides you with the following functions: + + +=over 4 + +=item wraphandle SCALAR + +This function will take a single argument, and "wrap" it based on +what it seems to be... + +=over 4 + +=item * + +B like C<"STDOUT"> or C<"Class::HANDLE">. +In this case, the filehandle name is wrapped in an IO::Wrap object, +which is returned. + +=item * + +B like C<\*STDOUT>. +In this case, the filehandle glob is wrapped in an IO::Wrap object, +which is returned. + +=item * + +B +In this case, the FileHandle is wrapped in an IO::Wrap object if and only +if your FileHandle class does not support the C method. + +=item * + +B which is assumed to be already +conformant to the IO::Handle interface. +In this case, you just get back that object. + +=back + +=back + + +If you get back an IO::Wrap object, it will obey a basic subset of +the IO:: interface. That is, the following methods (note: I said +I, not named operators) should work on the thing you get back: + + close + getline + getlines + print ARGS... + read BUFFER,NBYTES + seek POS,WHENCE + tell + + + +=head1 NOTES + +Clearly, when wrapping a raw external filehandle (like \*STDOUT), +I didn't want to close the file descriptor when the "wrapper" object is +destroyed... since the user might not appreciate that! Hence, +there's no DESTROY method in this class. + +When wrapping a FileHandle object, however, I believe that Perl will +invoke the FileHandle::DESTROY when the last reference goes away, +so in that case, the filehandle is closed if the wrapped FileHandle +really was the last reference to it. + + +=head1 WARNINGS + +This module does not allow you to wrap filehandle names which are given +as strings that lack the package they were opened in. That is, if a user +opens FOO in package Foo, they must pass it to you either as C<\*FOO> +or as C<"Foo::FOO">. However, C<"STDIN"> and friends will work just fine. + + +=head1 VERSION + +$Id: Wrap.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHOR + +=item Primary Maintainer + +Dianne Skoll (F). + +=item Original Author + +Eryq (F). +President, ZeeGee Software Inc (F). + +=cut + diff --git a/lib/lib/IO/WrapTie.pm b/lib/lib/IO/WrapTie.pm new file mode 100644 index 0000000..a15ada3 --- /dev/null +++ b/lib/lib/IO/WrapTie.pm @@ -0,0 +1,491 @@ +# SEE DOCUMENTATION AT BOTTOM OF FILE + + +#------------------------------------------------------------ +package IO::WrapTie; +#------------------------------------------------------------ +require 5.004; ### for tie +use strict; +use vars qw(@ISA @EXPORT $VERSION); +use Exporter; + +# Inheritance, exporting, and package version: +@ISA = qw(Exporter); +@EXPORT = qw(wraptie); +$VERSION = "2.111"; + +# Function, exported. +sub wraptie { + IO::WrapTie::Master->new(@_); +} + +# Class method; BACKWARDS-COMPATIBILITY ONLY! +sub new { + shift; + IO::WrapTie::Master->new(@_); +} + + + +#------------------------------------------------------------ +package IO::WrapTie::Master; +#------------------------------------------------------------ + +use strict; +use vars qw(@ISA $AUTOLOAD); +use IO::Handle; + +# We inherit from IO::Handle to get methods which invoke i/o operators, +# like print(), on our tied handle: +@ISA = qw(IO::Handle); + +#------------------------------ +# new SLAVE, TIEARGS... +#------------------------------ +# Create a new subclass of IO::Handle which... +# +# (1) Handles i/o OPERATORS because it is tied to an instance of +# an i/o-like class, like IO::Scalar. +# +# (2) Handles i/o METHODS by delegating them to that same tied object!. +# +# Arguments are the slave class (e.g., IO::Scalar), followed by all +# the arguments normally sent into that class's TIEHANDLE method. +# In other words, much like the arguments to tie(). :-) +# +# NOTE: +# The thing $x we return must be a BLESSED REF, for ($x->print()). +# The underlying symbol must be a FILEHANDLE, for (print $x "foo"). +# It has to have a way of getting to the "real" back-end object... +# +sub new { + my $master = shift; + my $io = IO::Handle->new; ### create a new handle + my $slave = shift; + tie *$io, $slave, @_; ### tie: will invoke slave's TIEHANDLE + bless $io, $master; ### return a master +} + +#------------------------------ +# AUTOLOAD +#------------------------------ +# Delegate method invocations on the master to the underlying slave. +# +sub AUTOLOAD { + my $method = $AUTOLOAD; + $method =~ s/.*:://; + my $self = shift; tied(*$self)->$method(\@_); +} + +#------------------------------ +# PRELOAD +#------------------------------ +# Utility. +# +# Most methods like print(), getline(), etc. which work on the tied object +# via Perl's i/o operators (like 'print') are inherited from IO::Handle. +# +# Other methods, like seek() and sref(), we must delegate ourselves. +# AUTOLOAD takes care of these. +# +# However, it may be necessary to preload delegators into your +# own class. PRELOAD will do this. +# +sub PRELOAD { + my $class = shift; + foreach (@_) { + eval "sub ${class}::$_ { my \$s = shift; tied(*\$s)->$_(\@_) }"; + } +} + +# Preload delegators for some standard methods which we can't simply +# inherit from IO::Handle... for example, some IO::Handle methods +# assume that there is an underlying file descriptor. +# +PRELOAD IO::WrapTie::Master + qw(open opened close read clearerr eof seek tell setpos getpos); + + + +#------------------------------------------------------------ +package IO::WrapTie::Slave; +#------------------------------------------------------------ +# Teeny private class providing a new_tie constructor... +# +# HOW IT ALL WORKS: +# +# Slaves inherit from this class. +# +# When you send a new_tie() message to a tie-slave class (like IO::Scalar), +# it first determines what class should provide its master, via TIE_MASTER. +# In this case, IO::Scalar->TIE_MASTER would return IO::Scalar::Master. +# Then, we create a new master (an IO::Scalar::Master) with the same args +# sent to new_tie. +# +# In general, the new() method of the master is inherited directly +# from IO::WrapTie::Master. +# +sub new_tie { + my $self = shift; + $self->TIE_MASTER->new($self,@_); ### e.g., IO::Scalar::Master->new(@_) +} + +# Default class method for new_tie(). +# All your tie-slave class (like IO::Scalar) has to do is override this +# method with a method that returns the name of an appropriate "master" +# class for tying that slave. +# +sub TIE_MASTER { 'IO::WrapTie::Master' } + +#------------------------------ +1; +__END__ + + +package IO::WrapTie; ### for doc generator + + +=head1 NAME + +IO::WrapTie - wrap tieable objects in IO::Handle interface + +I + + +=head1 SYNOPSIS + +First of all, you'll need tie(), so: + + require 5.004; + +I +Use this with any existing class... + + use IO::WrapTie; + use FooHandle; ### implements TIEHANDLE interface + + ### Suppose we want a "FooHandle->new(&FOO_RDWR, 2)". + ### We can instead say... + + $FH = wraptie('FooHandle', &FOO_RDWR, 2); + + ### Now we can use... + print $FH "Hello, "; ### traditional operator syntax... + $FH->print("world!\n"); ### ...and OO syntax as well! + +I +You can inherit from the IO::WrapTie::Slave mixin to get a +nifty C constructor... + + #------------------------------ + package FooHandle; ### a class which can TIEHANDLE + + use IO::WrapTie; + @ISA = qw(IO::WrapTie::Slave); ### inherit new_tie() + ... + + + #------------------------------ + package main; + + $FH = FooHandle->new_tie(&FOO_RDWR, 2); ### $FH is an IO::WrapTie::Master + print $FH "Hello, "; ### traditional operator syntax + $FH->print("world!\n"); ### OO syntax + +See IO::Scalar as an example. It also shows you how to create classes +which work both with and without 5.004. + + +=head1 DESCRIPTION + +Suppose you have a class C, where... + +=over 4 + +=item * + +B that is, it performs +filehandle-like I/O, but to something other than an underlying +file descriptor. Good examples are IO::Scalar (for printing to a +string) and IO::Lines (for printing to an array of lines). + +=item * + +B (see L); +that is, it provides methods TIEHANDLE, GETC, PRINT, PRINTF, +READ, and READLINE. + +=item * + +B of +FileHandle and IO::Handle; i.e., it contains methods like getline(), +read(), print(), seek(), tell(), eof(), etc. + +=back + + +Normally, users of your class would have two options: + + +=over 4 + +=item * + +B and forsake named I/O operators like 'print'. + +=item * + +B and forsake treating it as a first-class object +(i.e., class-specific methods can only be invoked through the underlying +object via tied()... giving the object a "split personality"). + +=back + + +But now with IO::WrapTie, you can say: + + $WT = wraptie('FooHandle', &FOO_RDWR, 2); + $WT->print("Hello, world\n"); ### OO syntax + print $WT "Yes!\n"; ### Named operator syntax too! + $WT->weird_stuff; ### Other methods! + +And if you're authoring a class like FooHandle, just have it inherit +from C and that first line becomes even prettier: + + $WT = FooHandle->new_tie(&FOO_RDWR, 2); + +B now, almost any class can look and work exactly like +an IO::Handle... and be used both with OO and non-OO filehandle syntax. + + +=head1 HOW IT ALL WORKS + + +=head2 The data structures + +Consider this example code, using classes in this distribution: + + use IO::Scalar; + use IO::WrapTie; + + $WT = wraptie('IO::Scalar',\$s); + print $WT "Hello, "; + $WT->print("world!\n"); + +In it, the wraptie() function creates a data structure as follows: + + * $WT is a blessed reference to a tied filehandle + $WT glob; that glob is tied to the "Slave" object. + | * You would do all your i/o with $WT directly. + | + | + | ,---isa--> IO::WrapTie::Master >--isa--> IO::Handle + V / + .-------------. + | | + | | * Perl i/o operators work on the tied object, + | "Master" | invoking the TIEHANDLE methods. + | | * Method invocations are delegated to the tied + | | slave. + `-------------' + | + tied(*$WT) | .---isa--> IO::WrapTie::Slave + V / + .-------------. + | | + | "Slave" | * Instance of FileHandle-like class which doesn't + | | actually use file descriptors, like IO::Scalar. + | IO::Scalar | * The slave can be any kind of object. + | | * Must implement the TIEHANDLE interface. + `-------------' + + +I just as an IO::Handle is really just a blessed reference to a +I filehandle glob... so also, an IO::WrapTie::Master +is really just a blessed reference to a filehandle +glob I + + +=head2 How wraptie() works + +=over 4 + +=item 1. + +The call to function C is +passed onto C. +Note that class IO::WrapTie::Master is a subclass of IO::Handle. + +=item 2. + +The C method creates a new IO::Handle object, +reblessed into class IO::WrapTie::Master. This object is the I, +which will be returned from the constructor. At the same time... + +=item 3. + +The C method also creates the I: this is an instance +of SLAVECLASS which is created by tying the master's IO::Handle +to SLAVECLASS via C. +This call to C creates the slave in the following manner: + +=item 4. + +Class SLAVECLASS is sent the message C; it +will usually delegate this to C, resulting +in a new instance of SLAVECLASS being created and returned. + +=item 5. + +Once both master and slave have been created, the master is returned +to the caller. + +=back + + +=head2 How I/O operators work (on the master) + +Consider using an i/o operator on the master: + + print $WT "Hello, world!\n"; + +Since the master ($WT) is really a [blessed] reference to a glob, +the normal Perl i/o operators like C may be used on it. +They will just operate on the symbol part of the glob. + +Since the glob is tied to the slave, the slave's PRINT method +(part of the TIEHANDLE interface) will be automatically invoked. + +If the slave is an IO::Scalar, that means IO::Scalar::PRINT will be +invoked, and that method happens to delegate to the C method +of the same class. So the I work is ultimately done by +IO::Scalar::print(). + + +=head2 How methods work (on the master) + +Consider using a method on the master: + + $WT->print("Hello, world!\n"); + +Since the master ($WT) is blessed into the class IO::WrapTie::Master, +Perl first attempts to find a C method there. Failing that, +Perl next attempts to find a C method in the superclass, +IO::Handle. It just so happens that there I such a method; +that method merely invokes the C i/o operator on the self object... +and for that, see above! + +But let's suppose we're dealing with a method which I part +of IO::Handle... for example: + + my $sref = $WT->sref; + +In this case, the intuitive behavior is to have the master delegate the +method invocation to the slave (now do you see where the designations +come from?). This is indeed what happens: IO::WrapTie::Master contains +an AUTOLOAD method which performs the delegation. + +So: when C can't be found in IO::Handle, the AUTOLOAD method +of IO::WrapTie::Master is invoked, and the standard behavior of +delegating the method to the underlying slave (here, an IO::Scalar) +is done. + +Sometimes, to get this to work properly, you may need to create +a subclass of IO::WrapTie::Master which is an effective master for +I class, and do the delegation there. + + + + +=head1 NOTES + +B + Because that means forsaking the use of named operators +like print(), and you may need to pass the object to a subroutine +which will attempt to use those operators: + + $O = FooHandle->new(&FOO_RDWR, 2); + $O->print("Hello, world\n"); ### OO syntax is okay, BUT.... + + sub nope { print $_[0] "Nope!\n" } + X nope($O); ### ERROR!!! (not a glob ref) + + +B + Because (1) you have to use tied() to invoke methods in the +object's public interface (yuck), and (2) you may need to pass +the tied symbol to another subroutine which will attempt to treat +it in an OO-way... and that will break it: + + tie *T, 'FooHandle', &FOO_RDWR, 2; + print T "Hello, world\n"; ### Operator is okay, BUT... + + tied(*T)->other_stuff; ### yuck! AND... + + sub nope { shift->print("Nope!\n") } + X nope(\*T); ### ERROR!!! (method "print" on unblessed ref) + + +B + I tried this, with an implementation similar to that of IO::Socket. +The problem is that I. +Subclassing IO::Handle will work fine for the OO stuff, and fine with +named operators I you tie()... but if you just attempt to say: + + $IO = FooHandle->new(&FOO_RDWR, 2); + print $IO "Hello!\n"; + +you get a warning from Perl like: + + Filehandle GEN001 never opened + +because it's trying to do system-level i/o on an (unopened) file +descriptor. To avoid this, you apparently have to tie() the handle... +which brings us right back to where we started! At least the +IO::WrapTie mixin lets us say: + + $IO = FooHandle->new_tie(&FOO_RDWR, 2); + print $IO "Hello!\n"; + +and so is not I bad. C<:-)> + + +=head1 WARNINGS + +Remember: this stuff is for doing FileHandle-like i/o on things +I. If you have an underlying +file descriptor, you're better off just inheriting from IO::Handle. + +B it does B return an instance +of the i/o class you're tying to! + +Invoking some methods on the master object causes AUTOLOAD to delegate +them to the slave object... so it I like you're manipulating a +"FooHandle" object directly, but you're not. + +I have not explored all the ramifications of this use of tie(). +I. + + +=head1 VERSION + +$Id: WrapTie.pm,v 1.2 2005/02/10 21:21:53 dfs Exp $ + + +=head1 AUTHOR + +=item Primary Maintainer + +Dianne Skoll (F). + +=item Original Author + +Eryq (F). +President, ZeeGee Software Inc (F). + +=cut + diff --git a/lib/lib/Net/DNS.pm b/lib/lib/Net/DNS.pm new file mode 100644 index 0000000..d4792cd --- /dev/null +++ b/lib/lib/Net/DNS.pm @@ -0,0 +1,652 @@ +package Net::DNS; + +# +# $Id: DNS.pm 1722 2018-11-14 15:45:37Z willem $ +# +require 5.006; +our $VERSION; +$VERSION = '1.19'; +$VERSION = eval $VERSION; +our $SVNVERSION = (qw$LastChangedRevision: 1722 $)[1]; + + +=head1 NAME + +Net::DNS - Perl Interface to the Domain Name System + +=head1 SYNOPSIS + + use Net::DNS; + +=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. +See RFC 1035 or DNS and BIND (Albitz & Liu) for details. + +=cut + + +use strict; +use warnings; +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 { $VERSION; } + + +# +# rr() +# +# Usage: +# @rr = rr('example.com'); +# @rr = rr('example.com', 'A', 'IN'); +# @rr = rr($res, 'example.com' ... ); +# +sub rr { + my ($arg1) = @_; + my $res = ref($arg1) ? shift : new Net::DNS::Resolver(); + + my $reply = $res->query(@_); + my @list = $reply ? $reply->answer : (); +} + + +# +# mx() +# +# Usage: +# @mx = mx('example.com'); +# @mx = mx($res, 'example.com'); +# +sub mx { + my ($arg1) = @_; + my @res = ( ref($arg1) ? shift : () ); + my ( $name, @class ) = @_; + + # 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 $rrtype = uc shift; + my ( $attribute, @rr ) = @_; ## NB: attribute is optional + ( @rr, $attribute ) = @_ 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; +} + + +# +# Auxiliary functions to support policy-driven zone serial numbering. +# +# $successor = $soa->serial(SEQUENTIAL); +# $successor = $soa->serial(UNIXTIME); +# $successor = $soa->serial(YYYYMMDDxx); +# + +sub SEQUENTIAL {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 $rr = new Net::DNS::RR(@_); + $rr->ttl(0); + $rr->class('ANY') unless $rr->rdata; + return $rr; +} + +sub nxrrset { + my $rr = new Net::DNS::RR(@_); + new Net::DNS::RR( + name => $rr->name, + type => $rr->type, + class => 'NONE' + ); +} + +sub yxdomain { + my ( $domain, @etc ) = map split, @_; + my $rr = new Net::DNS::RR( scalar(@etc) ? @_ : ( name => $domain ) ); + new Net::DNS::RR( + name => $rr->name, + type => 'ANY', + class => 'ANY' + ); +} + +sub nxdomain { + my ( $domain, @etc ) = map split, @_; + my $rr = new Net::DNS::RR( scalar(@etc) ? @_ : ( name => $domain ) ); + new Net::DNS::RR( + name => $rr->name, + type => 'ANY', + class => 'NONE' + ); +} + +sub rr_add { + my $rr = new Net::DNS::RR(@_); + $rr->{ttl} = 86400 unless defined $rr->{ttl}; + return $rr; +} + +sub rr_del { + my ( $domain, @etc ) = map split, @_; + my $rr = new Net::DNS::RR( scalar(@etc) ? @_ : ( 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 +used to create 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", "A"); + my @rr = rr("example.com", "A", "IN"); + + # Use your own resolver object. + my $res = Net::DNS::Resolver->new; + my @rr = rr($res, "example.com" ... ); + + my ($ptr) = rr("192.0.2.1"); + +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 A records; it only performs MX queries. + + +=head1 Dynamic DNS Update Support + +The Net::DNS module provides auxiliary functions which support +dynamic DNS update requests. + + +=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 A") ); + +Meaning: At least one RR with the specified name and type must +exist. + + # RRset exists (value-dependent) + $update->push( pre => yxrrset("host.example.com A 10.1.2.3") ); + +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 A") ); + +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 A 10.1.2.3") ); + +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 A") ); + +Meaning: Delete all RRs having the specified name and type. + + # Delete a specific RR. + $update->push( update => rr_del("host.example.com A 10.1.2.3") ); + +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. + +=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", "A"); + + if ($reply) { + foreach my $rr ($reply->answer) { + print $rr->address, "\n" if $rr->can("address"); + } + } else { + warn "query failed: ", $res->errorstring, "\n"; + } + + +=head2 Find the nameservers for a domain. + + use Net::DNS; + my $res = Net::DNS::Resolver->new; + my $reply = $res->query("example.com", "NS"); + + if ($reply) { + foreach $rr (grep { $_->type eq "NS" } $reply->answer) { + print $rr->nsdname, "\n"; + } + } else { + warn "query failed: ", $res->errorstring, "\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); + + if (@mx) { + foreach $rr (@mx) { + print $rr->preference, "\t", $rr->exchange, "\n"; + } + } else { + warn "Can not find MX records for $name: ", $res->errorstring, "\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"); + + if ($reply) { + foreach my $rr ($reply->answer) { + $rr->print; + } + } else { + warn "query failed: ", $res->errorstring, "\n"; + } + + +=head2 Perform a zone transfer and print all the records. + + use Net::DNS; + my $res = Net::DNS::Resolver->new; + $res->tcp_timeout(20); + $res->nameservers("ns.example.com"); + + my @zone = $res->axfr("example.com"); + + foreach $rr (@zone) { + $rr->print; + } + + warn $res->errorstring if $res->errorstring; + + +=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("host.example.com"); + + while ( $res->bgbusy($socket) ) { + # do some work here while waiting for the response + # ...and some more here + } + + my $packet = $res->bgread($socket); + if ($packet) { + $packet->print; + } else { + warn "query failed: ", $res->errorstring, "\n"; + } + + +=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 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 +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. + +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, +RFC1035, L, +I by Paul Albitz & Cricket Liu + +=cut + diff --git a/lib/lib/Net/DNS/Domain.pm b/lib/lib/Net/DNS/Domain.pm new file mode 100644 index 0000000..ad7c55a --- /dev/null +++ b/lib/lib/Net/DNS/Domain.pm @@ -0,0 +1,403 @@ +package Net::DNS::Domain; + +# +# $Id: Domain.pm 1698 2018-07-24 15:29:05Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1698 $)[1]; + + +=head1 NAME + +Net::DNS::Domain - DNS domains + +=head1 SYNOPSIS + + use Net::DNS::Domain; + + $domain = new Net::DNS::Domain('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 arbitrary +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 strict; +use warnings; +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 LIBIDN => defined eval 'require Net::LibIDN'; +use constant LIBIDN2 => ref eval 'require Net::LibIDN2; Net::LibIDN2->can("idn2_to_ascii_8")'; + +use constant IDN2FLAG => eval 'Net::LibIDN2::IDN2_NFC_INPUT + Net::LibIDN2::IDN2_NONTRANSITIONAL'; + +# 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 = new Net::DNS::Domain('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 $k = join '', $s, $class, $ORIGIN || ''; # cache key + my $cache = $$cache1{$k} ||= $$cache2{$k}; # 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 'empty domain label' unless length; + + if ( LIBIDN2 && UTF8 && /[^\000-\177]/ ) { + my $rc = 0; + s/\134/\357\277\275/; # disallow escapes + $_ = Net::LibIDN2::idn2_to_ascii_8( $_, IDN2FLAG, $rc ); + croak Net::LibIDN2::idn2_strerror($rc) unless $_; + } + + if ( !LIBIDN2 && LIBIDN && UTF8 && /[^\000-\177]/ ) { + s/\134/\357\277\275/; # disallow escapes + $_ = Net::LibIDN::idn_to_ascii( $_, 'utf-8' ); + croak 'name contains disallowed character' unless $_; + } + + s/\134([\060-\071]{3})/$unescape{$1}/eg; # numeric escape + s/\134(.)/$1/g; # character escape + croak 'long domain label' if length > 63; + } + + $$cache1{$k} = $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 = map { s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; $_ } $self->_wire; + + return $self->{name} = '.' unless scalar @label; + $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 ( !LIBIDN2 && 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 { + map { + s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg; + _decode_ascii($_) + } shift->_wire; +} + + +sub _wire { + my $self = shift; + + my $label = $self->{label}; + my $origin = $self->{origin} || return (@$label); + return ( @$label, $origin->_wire ); +} + + +=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 { + ( my $name = &name ) =~ s/(["'\$();@])/\\$1/; # escape special char + return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot +} + + +=head2 origin + + $create = origin Net::DNS::Domain( $ORIGIN ); + $result = &$create( sub{ new Net::DNS::RR( 'mx MX 10 a' ); } ); + $expect = new Net::DNS::RR( "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 ? new Net::DNS::Domain($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 + 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 + ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; +} + + +%escape = eval { ## precalculated ASCII escape table + my %table; + + foreach ( 33 .. 126 ) { # ASCII printable + $table{pack( 'C', $_ )} = pack 'C', $_; + } + + # minimal character escapes + foreach ( 46, 92 ) { # \. \\ + $table{pack( 'C', $_ )} = pack 'C*', 92, $_; + } + + foreach my $n ( 0 .. 32, 127 .. 255 ) { # \ddd + my $codepoint = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $codepoint =~ tr [0-9] [\060-\071]; + + $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint; + } + + return %table; +}; + + +%unescape = eval { ## precalculated numeric escape table + my %table; + + foreach my $n ( 0 .. 255 ) { + my $key = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $key =~ tr [0-9] [\060-\071]; + + $table{$key} = pack 'C', $n; + $table{$key} = pack 'C2', 92, $n if $n == 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 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 +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, RFC1034, RFC1035, RFC5891, Unicode TR#16 + +=cut + diff --git a/lib/lib/Net/DNS/DomainName.pm b/lib/lib/Net/DNS/DomainName.pm new file mode 100644 index 0000000..55c8c3e --- /dev/null +++ b/lib/lib/Net/DNS/DomainName.pm @@ -0,0 +1,294 @@ +package Net::DNS::DomainName; + +# +# $Id: DomainName.pm 1605 2017-11-27 11:37:40Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1605 $)[1]; + + +=head1 NAME + +Net::DNS::DomainName - DNS name representation + +=head1 SYNOPSIS + + use Net::DNS::DomainName; + + $object = new Net::DNS::DomainName('example.com'); + $name = $object->name; + $data = $object->encode; + + ( $object, $next ) = decode Net::DNS::DomainName( \$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 as defined in RFC1035. All other behaviour, +including the new() constructor, 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 strict; +use warnings; +use base qw(Net::DNS::Domain); + +use integer; +use Carp; + + +=head1 METHODS + +=head2 new + + $object = new Net::DNS::DomainName('example.com'); + +Creates a domain name object which identifies the domain specified +by the character string argument. + + +=head2 canonical + + $data = $object->canonical; + +Returns the canonical wire-format representation of the domain name +as defined in RFC2535(8.1). + +=cut + +sub canonical { + join '', map( { tr /\101-\132/\141-\172/; + pack 'C a*', length($_), $_; + } shift->_wire ), + pack 'x'; +} + + +=head2 decode + + $object = decode Net::DNS::DomainName( \$buffer, $offset, $hash ); + + ( $object, $next ) = decode Net::DNS::DomainName( \$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 $cache = shift || {}; # 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; + + # uncoverable condition false + $self->{origin} = $cache->{$link} ||= decode Net::DNS::DomainName( $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 { + join '', map pack( 'C a*', length($_), $_ ), shift->_wire, ''; +} + + +######################################## + +sub _wire { ## Generate list of wire-format labels + my $self = shift; + + my $label = $self->{label}; + my $origin = $self->{origin} || return (@$label); + return ( @$label, $origin->_wire ); +} + + +######################################## + +package Net::DNS::DomainName1035; +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. + + use Net::DNS::DomainName; + + $object = new Net::DNS::DomainName1035('compressible.example.com'); + $data = $object->encode( $offset, $hash ); + + ( $object, $next ) = decode Net::DNS::DomainName1035( \$data, $offset ); + +Note that RFC3597 implies that the RR types defined in RFC1035 +section 3.3 are the only types eligible for compression. + + +=head2 encode + + $data = $object->encode( $offset, $hash ); + +Returns the wire-format representation of the domain name suitable +for inclusion in a DNS packet buffer. + +The optional 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. + +If the hash reference is undefined, encode() returns the lowercase +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; + } + $data .= pack 'x'; +} + + +######################################## + +package Net::DNS::DomainName2535; +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. + +Note that RFC3597, and latterly RFC4034, specifies that the lower +case canonical encoding defined in RFC2535 is to be used for RR +types defined prior to RFC3597. + + use Net::DNS::DomainName; + + $object = new Net::DNS::DomainName2535('incompressible.example.com'); + $data = $object->encode( $offset, $hash ); + + ( $object, $next ) = decode Net::DNS::DomainName2535( \$data, $offset ); + + +=head2 encode + + $data = $object->encode( $offset, $hash ); + +Returns the uncompressed wire-format representation of the domain +name suitable for inclusion in a DNS packet buffer. + +If the hash reference is undefined, encode() returns the lowercase +canonical form defined in RFC2535(8.1). + +=cut + +sub encode { + return shift->canonical unless defined $_[2]; + join '', map pack( 'C a*', length($_), $_ ), shift->_wire, ''; +} + +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 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 +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, RFC1035, RFC2535, +RFC3597, RFC4034 + +=cut + diff --git a/lib/lib/Net/DNS/FAQ.pod b/lib/lib/Net/DNS/FAQ.pod new file mode 100644 index 0000000..42242dc --- /dev/null +++ b/lib/lib/Net/DNS/FAQ.pod @@ -0,0 +1,49 @@ +=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 $ + diff --git a/lib/lib/Net/DNS/Header.pm b/lib/lib/Net/DNS/Header.pm new file mode 100644 index 0000000..2c11437 --- /dev/null +++ b/lib/lib/Net/DNS/Header.pm @@ -0,0 +1,501 @@ +package Net::DNS::Header; + +# +# $Id: Header.pm 1709 2018-09-07 08:03:09Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1709 $)[1]; + + +=head1 NAME + +Net::DNS::Header - DNS packet header + +=head1 SYNOPSIS + + use Net::DNS; + + $packet = new Net::DNS::Packet; + $header = $packet->header; + + +=head1 DESCRIPTION + +C represents the header portion of a DNS packet. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use Net::DNS::Parameters; + + +=head1 METHODS + + +=head2 $packet->header + + $packet = new Net::DNS::Packet; + $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 $opt = $$self->edns; + my $edns = $opt->_specified ? $opt->string : ''; + + return <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; + + return <header->print; + +Prints the string representation of the packet header. + +=cut + +sub print { print &string; } + + +=head2 id + + print "query id = ", $packet->header->id, "\n"; + $packet->header->id(1234); + +Gets or sets the query identification number. + +A random value is assigned if the argument value is undefined. + +=cut + +sub id { + my $self = shift; + $$self->{id} = shift if scalar @_; + return $$self->{id} if defined $$self->{id}; + $$self->{id} = int rand(0xffff); +} + + +=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 = shift; + for ( $$self->{status} ) { + return opcodebyval( ( $_ >> 11 ) & 0x0f ) unless scalar @_; + my $opcode = opcodebyname(shift); + $_ = ( $_ & 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 = shift; + for ( $$self->{status} ) { + my $arg = shift; + my $opt = $$self->edns; + unless ( defined $arg ) { + my $rcode = $opt->rcode; + return rcodebyval( $_ & 0x0f ) unless $opt->_specified; + $rcode = ( $rcode & 0xff0 ) | ( $_ & 0x00f ); + $opt->rcode($rcode); # write back full 12-bit rcode + return $rcode == 16 ? 'BADVERS' : rcodebyval($rcode); + } + my $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 { + shift->_dnsflag( 0x8000, @_ ); +} + + +=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 { + shift->_dnsflag( 0x0400, @_ ); +} + + +=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 { + shift->_dnsflag( 0x0200, @_ ); +} + + +=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 { + shift->_dnsflag( 0x0100, @_ ); +} + + +=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 { + shift->_dnsflag( 0x0080, @_ ); +} + + +=head2 z + +Unassigned bit, should always be zero. + +=cut + +sub z { + shift->_dnsflag( 0x0040, @_ ); +} + + +=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 { + shift->_dnsflag( 0x0020, @_ ); +} + + +=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 { + shift->_dnsflag( 0x0010, @_ ); +} + + +=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 + +our $warned; + +sub qdcount { + my $self = shift; + return $$self->{count}[0] || scalar @{$$self->{question}} unless scalar @_; + carp 'header->qdcount attribute is read-only' unless $warned++; +} + + +=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 = shift; + return $$self->{count}[1] || scalar @{$$self->{answer}} unless scalar @_; + carp 'header->ancount attribute is read-only' unless $warned++; +} + + +=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 = shift; + return $$self->{count}[2] || scalar @{$$self->{authority}} unless scalar @_; + carp 'header->nscount attribute is read-only' unless $warned++; +} + + +=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 = shift; + return $$self->{count}[3] || scalar @{$$self->{additional}} unless scalar @_; + carp 'header->arcount attribute is read-only' unless $warned++; +} + +sub zocount { &qdcount; } +sub prcount { &ancount; } +sub upcount { &nscount; } +sub adcount { &arcount; } + + +=head1 EDNS Protocol Extensions + + +=head2 do + + print "DNSSEC_OK flag was ", $packet->header->do ? "not" : "", "set\n"; + $packet->header->do(1); + +Gets or sets the EDNS DNSSEC OK flag. + +=cut + +sub do { + shift->_ednsflag( 0x8000, @_ ); +} + + +=head2 Extended rcode + +EDNS extended rcodes are handled transparently by $packet->header->rcode(). + + +=head2 UDP packet size + + $udp_max = $packet->header->size; + $udp_max = $packet->edns->size; + +EDNS offers a mechanism to advertise the maximum UDP packet size +which can be assembled by the local network stack. + +UDP size advertisement can be viewed as either a header extension or +an EDNS feature. Endless debate is avoided by supporting both views. + +=cut + +sub size { + my $self = shift; + return $$self->edns->size(@_); +} + + +=head2 edns + + $header = $packet->header; + $version = $header->edns->version; + @options = $header->edns->options; + $option = $header->edns->option(n); + $udp_max = $packet->edns->size; + +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 = shift; + my $flag = shift; + for ( $$self->{status} ) { + my $set = $_ | $flag; + my $not = $set - $flag; + $_ = (shift) ? $set : $not if scalar @_; + return ( $_ & $flag ) ? 1 : 0; + } +} + + +sub _ednsflag { + my $self = shift; + my $flag = shift; + my $edns = $$self->edns->flags || 0; + return $flag & $edns ? 1 : 0 unless scalar @_; + my $set = $flag | $edns; + my $not = $set - $flag; + my $new = (shift) ? $set : $not; + $$self->edns->flags($new) unless $new == $edns; + return ( $new & $flag ) ? 1 : 0; +} + + +1; +__END__ + + +######################################## + +=head1 COPYRIGHT + +Copyright (c)1997 Michael Fuhr. + +Portions Copyright (c)2002,2003 Chris Reinhardt. + +Portions 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 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 +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 +RFC 1035 Section 4.1.1 + +=cut + diff --git a/lib/lib/Net/DNS/Mailbox.pm b/lib/lib/Net/DNS/Mailbox.pm new file mode 100644 index 0000000..785bbe7 --- /dev/null +++ b/lib/lib/Net/DNS/Mailbox.pm @@ -0,0 +1,158 @@ +package Net::DNS::Mailbox; + +# +# $Id: Mailbox.pm 1605 2017-11-27 11:37:40Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1605 $)[1]; + + +=head1 NAME + +Net::DNS::Mailbox - DNS mailbox representation + +=head1 SYNOPSIS + + use Net::DNS::Mailbox; + + $mailbox = new Net::DNS::Mailbox('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. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use base qw(Net::DNS::DomainName); + + +=head1 METHODS + +=head2 new + + $mailbox = new Net::DNS::Mailbox('John Doe '); + $mailbox = new Net::DNS::Mailbox('john.doe@example.com'); + $mailbox = new Net::DNS::Mailbox('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/\\\@/\\064/g; # disguise escaped @ + s/("[^"]*)\@([^"]*")/$1\\064$2/g; # disguise quoted @ + + my ( $mbox, @host ) = split /\@/; # split on @ if present + for ( $mbox ||= '' ) { + s/^.*"(.*)".*$/$1/; # strip quotes + s/\\\./\\046/g; # disguise escaped dot + s/\./\\046/g if @host; # escape dots in local part + } + + bless __PACKAGE__->SUPER::new( join '.', $mbox, @host ), $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/\\\d\d\d//g; # delete non-printable + s/\\\./\./g; # unescape dots + s/[\\"]//g; # delete \ " + s/^(.*)$/"$1"/ if /["(),:;<>@\[\\\]]/; # quote local part + return $_ unless scalar(@label); + join '@', $_, join '.', @label; +} + + +######################################## + +=head1 DOMAIN NAME COMPRESSION AND CANONICALISATION + +The Net::DNS::Mailbox1035 and Net::DNS::Mailbox2535 subclass +packages implement RFC1035 domain name compression and RFC2535 +canonicalisation. + +=cut + +package Net::DNS::Mailbox1035; +our @ISA = qw(Net::DNS::Mailbox); + +sub encode { &Net::DNS::DomainName1035::encode; } + + +package Net::DNS::Mailbox2535; +our @ISA = qw(Net::DNS::Mailbox); + +sub encode { &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 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 +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, RFC1035, RFC5322 (RFC822) + +=cut + diff --git a/lib/lib/Net/DNS/Nameserver.pm b/lib/lib/Net/DNS/Nameserver.pm new file mode 100644 index 0000000..e94084d --- /dev/null +++ b/lib/lib/Net/DNS/Nameserver.pm @@ -0,0 +1,856 @@ +package Net::DNS::Nameserver; + +# +# $Id: Nameserver.pm 1692 2018-07-06 08:55:39Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1692 $)[1]; + + +=head1 NAME + +Net::DNS::Nameserver - DNS server class + +=head1 SYNOPSIS + + use Net::DNS::Nameserver; + + my $nameserver = new Net::DNS::Nameserver( + LocalAddr => ['::1' , '127.0.0.1'], + ZoneFile => "filename" + ); + + my $nameserver = new Net::DNS::Nameserver( + LocalAddr => '10.1.2.3', + LocalPort => 5353, + ReplyHandler => \&reply_handler + ); + + +=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 for an example. + +=cut + +use constant USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.32; 1;'; + +use strict; +use warnings; +use integer; +use Carp; +use Net::DNS; +use Net::DNS::ZoneFile; + +use IO::Socket; +use IO::Select; + +use constant FORCE_IPv4 => 0; + +use constant DEFAULT_ADDR => qw(::1 127.0.0.1); +use constant DEFAULT_PORT => 53; + +use constant STATE_ACCEPTED => 1; +use constant STATE_GOT_LENGTH => 2; +use constant STATE_SENDING => 3; + +use constant PACKETSZ => 512; + + +#------------------------------------------------------------------------------ +# Constructor. +#------------------------------------------------------------------------------ + +sub new { + my ( $class, %self ) = @_; + my $self = bless \%self, $class; + if ( !exists $self{ReplyHandler} ) { + if ( my $handler = UNIVERSAL::can( $class, "ReplyHandler" ) ) { + $self{ReplyHandler} = sub { $handler->( $self, @_ ); }; + } + } + croak 'No reply handler!' unless ref( $self{ReplyHandler} ) eq "CODE"; + + $self->ReadZoneFile( $self{ZoneFile} ) if exists $self{ZoneFile}; + + # local server addresses must also be accepted by a resolver + my $LocalAddr = $self{LocalAddr} || [DEFAULT_ADDR]; + my $resolver = new Net::DNS::Resolver( nameservers => $LocalAddr ); + $resolver->force_v4(1) if FORCE_IPv4; + my @localaddresses = $resolver->nameservers; + + my $port = $self{LocalPort} || DEFAULT_PORT; + $self{Truncate} = 1 unless defined( $self{Truncate} ); + $self{IdleTimeout} = 120 unless defined( $self{IdleTimeout} ); + + my @sock_tcp; # All the TCP sockets we will listen to. + my @sock_udp; # All the UDP sockets we will listen to. + + # while we are here, print incomplete lines as they come along. + local $| = 1 if $self{Verbose}; + + foreach my $addr (@localaddresses) { + + #-------------------------------------------------------------------------- + # Create the TCP socket. + #-------------------------------------------------------------------------- + + print "\nCreating TCP socket $addr#$port - " if $self{Verbose}; + + my $sock_tcp = inet_new( + LocalAddr => $addr, + LocalPort => $port, + Listen => 64, + Proto => "tcp", + Reuse => 1, + Blocking => 0, + ); + if ($sock_tcp) { + push @sock_tcp, $sock_tcp; + print "done.\n" if $self{Verbose}; + } else { + carp "Couldn't create TCP socket: $!"; + } + + #-------------------------------------------------------------------------- + # Create the UDP Socket. + #-------------------------------------------------------------------------- + + print "Creating UDP socket $addr#$port - " if $self{Verbose}; + + my $sock_udp = inet_new( + LocalAddr => $addr, + LocalPort => $port, + Proto => "udp", + ); + + if ($sock_udp) { + push @sock_udp, $sock_udp; + print "done.\n" if $self{Verbose}; + } else { + carp "Couldn't create UDP socket: $!"; + } + + } + + #-------------------------------------------------------------------------- + # Create the Select object. + #-------------------------------------------------------------------------- + + my $select = $self{select} = new IO::Select; + + $select->add(@sock_tcp); + $select->add(@sock_udp); + + return undef unless $select->count; + + #-------------------------------------------------------------------------- + # Return the object. + #-------------------------------------------------------------------------- + + return $self; +} + + +#------------------------------------------------------------------------------ +# ReadZoneFile - Read zone file used by default reply handler +#------------------------------------------------------------------------------ + +sub ReadZoneFile { + my ( $self, $file ) = @_; + my $zonefile = new Net::DNS::ZoneFile($file); + + my $RRhash = $self->{RRhash} = {}; + my $RRlist = []; + while ( my $rr = $zonefile->read ) { + my ($leaf) = $rr->{owner}->label; + push @{$RRhash->{lc $leaf}}, $rr; + + # Warning: Nasty trick abusing SOA to reference zone RR list + if ( $rr->type eq 'SOA' ) { $RRlist = $rr->{RRlist} = [] } + else { push @$RRlist, $rr } + } +} + + +#------------------------------------------------------------------------------ +# ReplyHandler - Default reply handler serving RRs from zone file +#------------------------------------------------------------------------------ + +sub ReplyHandler { + my ( $self, $qname, $qclass, $qtype, $peerhost, $query, $conn ) = @_; + my $opcode = $query->header->opcode; + my $rcode = 'NOERROR'; + my @ans; + + my $lcase = lc $qname; # assume $qclass always 'IN' + my ( $leaf, @tail ) = split /\./, $lcase; + my $RRhash = $self->{RRhash}; + my $RRlist = $RRhash->{$leaf} || []; # hash, then linear search + my @match = grep lc( $_->owner ) eq $lcase, @$RRlist; + + if ( $qtype eq 'AXFR' ) { + my ($soa) = grep $_->type eq 'SOA', @match; + if ($soa) { push @ans, $soa, @{$soa->{RRlist}}, $soa } + else { $rcode = 'NOTAUTH' } + + } else { + unless ( scalar(@match) ) { + my $wildcard = join '.', '*', @tail; + my $wildlist = $RRhash->{'*'} || []; + foreach ( grep lc( $_->owner ) eq $wildcard, @$wildlist ) { + my $clone = bless {%$_}, ref($_); + $clone->owner($qname); + push @match, $clone; + } + $rcode = 'NXDOMAIN' unless @match; + } + @ans = grep $_->type eq $qtype, @match; + } + + return ( $rcode, \@ans, [], [], {aa => 1}, {} ); +} + + +#------------------------------------------------------------------------------ +# inet_new - Calls the constructor in the correct module for making sockets. +#------------------------------------------------------------------------------ + +sub inet_new { + return new IO::Socket::IP(@_) if USE_SOCKET_IP; + return new IO::Socket::INET(@_) unless USE_SOCKET_IP; +} + +#------------------------------------------------------------------------------ +# make_reply - Make a reply packet. +#------------------------------------------------------------------------------ + +sub make_reply { + my ( $self, $query, $peerhost, $conn ) = @_; + + unless ($query) { + print "ERROR: invalid packet\n" if $self->{Verbose}; + my $empty = new Net::DNS::Packet(); # 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 $self->{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 ) { + print "ERROR: qdcount $qdcount unsupported\n" if $self->{Verbose}; + $header->rcode("FORMERR"); + + } else { + my ($qr) = $query->question; + my $qname = $qr->qname; + my $qtype = $qr->qtype; + my $qclass = $qr->qclass; + + my $id = $query->header->id; + print "query $id : $qname $qclass $qtype\n" if $self->{Verbose}; + + my ( $rcode, $ans, $auth, $add ); + my @arglist = ( $qname, $qclass, $qtype, $peerhost, $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 $self->{Verbose}; + $rcode = "FORMERR"; + } + + if ( !defined($rcode) ) { + print "remaining silent\n" if $self->{Verbose}; + return undef; + } + + $header->rcode($rcode); + + $reply->{answer} = [@$ans] if $ans; + $reply->{authority} = [@$auth] if $auth; + $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 $self->{Verbose} && ( $headermask || $optionmask ); + + return $reply; +} + + +#------------------------------------------------------------------------------ +# readfromtcp - read from a TCP client +#------------------------------------------------------------------------------ + +sub readfromtcp { + my ( $self, $sock ) = @_; + return -1 unless defined $self->{_tcp}{$sock}; + my $peer = $self->{_tcp}{$sock}{peer}; + my $buf; + my $charsread = $sock->sysread( $buf, 16384 ); + $self->{_tcp}{$sock}{inbuffer} .= $buf; + $self->{_tcp}{$sock}{timeout} = time() + $self->{IdleTimeout}; # Reset idle timer + print "Received $charsread octets from $peer\n" if $self->{Verbose}; + + if ( $charsread == 0 ) { # 0 octets means socket has closed + print "Connection to $peer closed or lost.\n" if $self->{Verbose}; + $self->{select}->remove($sock); + $sock->close(); + delete $self->{_tcp}{$sock}; + return $charsread; + } + return $charsread; +} + +#------------------------------------------------------------------------------ +# tcp_connection - Handle a TCP connection. +#------------------------------------------------------------------------------ + +sub tcp_connection { + my ( $self, $sock ) = @_; + + if ( not $self->{_tcp}{$sock} ) { + + # We go here if we are called with a listener socket. + my $client = $sock->accept; + if ( not defined $client ) { + print "TCP connection closed by peer before we could accept it.\n" if $self->{Verbose}; + return 0; + } + my $peerport = $client->peerport; + my $peerhost = $client->peerhost; + + print "TCP connection from $peerhost:$peerport\n" if $self->{Verbose}; + $client->blocking(0); + $self->{_tcp}{$client}{peer} = "tcp:" . $peerhost . ":" . $peerport; + $self->{_tcp}{$client}{state} = STATE_ACCEPTED; + $self->{_tcp}{$client}{socket} = $client; + $self->{_tcp}{$client}{timeout} = time() + $self->{IdleTimeout}; + $self->{select}->add($client); + + # After we accepted we will look at the socket again + # to see if there is any data there. ---Olaf + $self->loop_once(0); + } else { + + # We go here if we are called with a client socket + my $peer = $self->{_tcp}{$sock}{peer}; + + if ( $self->{_tcp}{$sock}{state} == STATE_ACCEPTED ) { + if ( not $self->{_tcp}{$sock}{inbuffer} =~ s/^(..)//s ) { + return; # Still not 2 octets ready + } + my $msglen = unpack( "n", $1 ); + print "$peer said his query contains $msglen octets\n" if $self->{Verbose}; + $self->{_tcp}{$sock}{state} = STATE_GOT_LENGTH; + $self->{_tcp}{$sock}{querylength} = $msglen; + } + + # Not elsif, because we might already have all the data + if ( $self->{_tcp}{$sock}{state} == STATE_GOT_LENGTH ) { + + # return if not all data has been received yet. + return if $self->{_tcp}{$sock}{querylength} > length $self->{_tcp}{$sock}{inbuffer}; + + my $qbuf = substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ); + substr( $self->{_tcp}{$sock}{inbuffer}, 0, $self->{_tcp}{$sock}{querylength} ) = ""; + my $query = new Net::DNS::Packet( \$qbuf ); + if ( my $err = $@ ) { + print "Error decoding query packet: $err\n" if $self->{Verbose}; + undef $query; # force FORMERR reply + } + my $conn = { + sockhost => $sock->sockhost, + sockport => $sock->sockport, + peerhost => $sock->peerhost, + peerport => $sock->peerport + }; + my $reply = $self->make_reply( $query, $sock->peerhost, $conn ); + if ( not defined $reply ) { + print "I couldn't create a reply for $peer. Closing socket.\n" + if $self->{Verbose}; + $self->{select}->remove($sock); + $sock->close(); + delete $self->{_tcp}{$sock}; + return; + } + my $reply_data = $reply->data(65535); # limit to one TCP envelope + warn "multi-packet TCP response not implemented" if $reply->header->tc; + my $len = length $reply_data; + $self->{_tcp}{$sock}{outbuffer} = pack( 'n a*', $len, $reply_data ); + print "Queued TCP response (2 + $len octets) to $peer\n" + if $self->{Verbose}; + + # We are done. + $self->{_tcp}{$sock}{state} = STATE_SENDING; + } + } +} + +#------------------------------------------------------------------------------ +# udp_connection - Handle a UDP connection. +#------------------------------------------------------------------------------ + +sub udp_connection { + my ( $self, $sock ) = @_; + + my $buf = ""; + + $sock->recv( $buf, PACKETSZ ); + my ( $peerhost, $peerport, $sockhost ) = ( $sock->peerhost, $sock->peerport, $sock->sockhost ); + unless ( defined $peerhost && defined $peerport ) { + print "the Peer host and sock host appear to be undefined: bailing out of handling the UDP connection" + if $self->{Verbose}; + return; + } + + + print "UDP connection from $peerhost:$peerport to $sockhost\n" if $self->{Verbose}; + + my $query = new Net::DNS::Packet( \$buf ); + if ( my $err = $@ ) { + print "Error decoding query packet: $err\n" if $self->{Verbose}; + undef $query; # force FORMERR reply + } + my $conn = { + sockhost => $sock->sockhost, + sockport => $sock->sockport, + peerhost => $sock->peerhost, + peerport => $sock->peerport + }; + my $reply = $self->make_reply( $query, $peerhost, $conn ) || return; + + my $max_len = ( $query && $self->{Truncate} ) ? $query->edns->size : undef; + if ( $self->{Verbose} ) { + local $| = 1; + print "Maximum UDP size advertised by $peerhost#$peerport: $max_len\n" if $max_len; + print "Writing response - "; + print $sock->send( $reply->data($max_len) ) ? "done" : "failed: $!", "\n"; + + } else { + $sock->send( $reply->data($max_len) ); + } +} + + +sub get_open_tcp { + my $self = shift; + return keys %{$self->{_tcp}}; +} + + +#------------------------------------------------------------------------------ +# loop_once - Just check "once" on sockets already set up +#------------------------------------------------------------------------------ + +# This function might not actually return immediately. If an AXFR request is +# coming in which will generate a huge reply, we will not relinquish control +# until our outbuffers are empty. + +# +# NB this method may be subject to change and is therefore left 'undocumented' +# + +sub loop_once { + my ( $self, $timeout ) = @_; + + print ";loop_once called with timeout: " . ( defined($timeout) ? $timeout : "undefined" ) . "\n" + if $self->{Verbose} && $self->{Verbose} > 4; + foreach my $sock ( keys %{$self->{_tcp}} ) { + + # There is TCP traffic to handle + $timeout = 0.1 if $self->{_tcp}{$sock}{outbuffer}; + } + my @ready = $self->{select}->can_read($timeout); + + foreach my $sock (@ready) { + my $protonum = $sock->protocol; + + # This is a weird and nasty hack. Although not incorrect, + # I just don't know why ->protocol won't tell me the protocol + # on a connected socket. --robert + $protonum = getprotobyname('tcp') if not defined $protonum and $self->{_tcp}{$sock}; + + my $proto = getprotobynumber($protonum); + if ( !$proto ) { + print "ERROR: connection with unknown protocol\n" + if $self->{Verbose}; + } elsif ( lc($proto) eq "tcp" ) { + + $self->readfromtcp($sock) + && $self->tcp_connection($sock); + } elsif ( lc($proto) eq "udp" ) { + $self->udp_connection($sock); + } else { + print "ERROR: connection with unsupported protocol $proto\n" + if $self->{Verbose}; + } + } + my $now = time(); + + # Lets check if any of our TCP clients has pending actions. + # (outbuffer, timeout) + foreach my $s ( keys %{$self->{_tcp}} ) { + my $sock = $self->{_tcp}{$s}{socket}; + if ( $self->{_tcp}{$s}{outbuffer} ) { + + # If we have buffered output, then send as much as the OS will accept + # and wait with the rest + my $len = length $self->{_tcp}{$s}{outbuffer}; + my $charssent = $sock->syswrite( $self->{_tcp}{$s}{outbuffer} ) || 0; + print "Sent $charssent of $len octets to ", $self->{_tcp}{$s}{peer}, ".\n" + if $self->{Verbose}; + substr( $self->{_tcp}{$s}{outbuffer}, 0, $charssent ) = ""; + if ( length $self->{_tcp}{$s}{outbuffer} == 0 ) { + delete $self->{_tcp}{$s}{outbuffer}; + $self->{_tcp}{$s}{state} = STATE_ACCEPTED; + if ( length $self->{_tcp}{$s}{inbuffer} >= 2 ) { + + # See if the client has send us enough data to process the + # next query. + # We do this here, because we only want to process (and buffer!!) + # a single query at a time, per client. If we allowed a STATE_SENDING + # client to have new requests processed. We could be easilier + # victims of DoS (client sending lots of queries and never reading + # from it's socket). + # Note that this does not disable serialisation on part of the + # client. The split second it should take for us to lookup the + # next query, is likely faster than the time it takes to + # send the response... well, unless it's a lot of tiny queries, + # in which case we will be generating an entire TCP packet per + # reply. --robert + $self->tcp_connection( $self->{_tcp}{$s}{socket} ); + } + } + $self->{_tcp}{$s}{timeout} = time() + $self->{IdleTimeout}; + } else { + + # Get rid of idle clients. + my $timeout = $self->{_tcp}{$s}{timeout}; + if ( $timeout - $now < 0 ) { + print $self->{_tcp}{$s}{peer}, " has been idle for too long and will be disconnected.\n" + if $self->{Verbose}; + $self->{select}->remove($sock); + $sock->close(); + delete $self->{_tcp}{$s}; + } + } + } +} + +#------------------------------------------------------------------------------ +# main_loop - Main nameserver loop. +#------------------------------------------------------------------------------ + +sub main_loop { + my $self = shift; + + while (1) { + print "Waiting for connections...\n" if $self->{Verbose}; + + # You really need an argument otherwise you'll be burning CPU. + $self->loop_once(10); + } +} + + +1; +__END__ + + +=head1 METHODS + +=head2 new + + $nameserver = new Net::DNS::Nameserver( + LocalAddr => ['::1' , '127.0.0.1'], + ZoneFile => "filename" + ); + + $nameserver = new Net::DNS::Nameserver( + LocalAddr => '10.1.2.3', + LocalPort => 5353, + ReplyHandler => \&reply_handler, + Verbose => 1, + Truncate => 0 + ); + +Returns a Net::DNS::Nameserver object, or undef if the object +could not be created. + +Each instance is configured using the following optional arguments: + + LocalAddr IP address on which to listen Defaults to loopback address + LocalPort Port on which to listen Defaults to 53 + ZoneFile Name of file containing RRs + accessed using the default + reply-handling subroutine + ReplyHandler Reference to customised + reply-handling subroutine + NotifyHandler Reference to reply-handling + subroutine for queries with + opcode NOTIFY (RFC1996) + UpdateHandler Reference to reply-handling + subroutine for queries with + opcode UPDATE (RFC2136) + Verbose Report internal activity Defaults to 0 (off) + Truncate Truncates UDP packets that + are too big for the reply Defaults to 1 (on) + IdleTimeout TCP clients are disconnected + if they are idle longer than + this duration Defaults to 120 (secs) + +The LocalAddr attribute may alternatively be specified as a list of IP +addresses to listen to. +If the IO::Socket::IP library package is available on the system +this may also include IPv6 addresses. + + +The ReplyHandler subroutine is passed the query name, query class, +query type and optionally an argument containing the peerhost, the +incoming query, and the name of the incoming socket (sockethost). 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: + + NOERROR No error + FORMERR Format error + SERVFAIL Server failure + NXDOMAIN Non-existent domain (name doesn't exist) + NOTIMP Not implemented + REFUSED Query refused + +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 +C<< { ad => 1, aa => 0, ra => 1 } >>. + +EDNS options may be specified in a similar manner using optionmask +C<< { $optioncode => $value, $optionname => $value } >>. + + +See RFC 1035 and the IANA dns-parameters file for more information: + + ftp://ftp.rfc-editor.org/in-notes/rfc1035.txt + http://www.isi.edu/in-notes/iana/assignments/dns-parameters + +The nameserver will listen for both UDP and TCP connections. On +Unix-like systems, the program will probably have to run as root +to listen on the default port, 53. A non-privileged user should +be able to listen on ports 1024 and higher. + +UDP reply truncation functionality was introduced in VERSION 830. +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 C +to 0 and truncate the reply packet in the code of the ReplyHandler. + +See L for an example. + +=head2 main_loop + + $ns->main_loop; + +Start accepting queries. Calling main_loop never returns. + + +=head2 loop_once + + $ns->loop_once( [TIMEOUT_IN_SECONDS] ); + +Start accepting queries, but returns. If called without a parameter, the +call will not return until a request has been received (and replied to). +Otherwise, the parameter specifies the maximum time to wait for a request. +A zero timeout forces an immediate return if there is nothing to do. + +Handling a request and replying obviously depends on the speed of +ReplyHandler. Assuming a fast ReplyHandler, loop_once should spend just a +fraction of a second, if called with a timeout value of 0.0 seconds. One +exception is when an AXFR has requested a huge amount of data that the OS +is not ready to receive in full. In that case, it will remain in a loop +(while servicing new requests) until the reply has been sent. + +In case loop_once accepted a TCP connection it will immediately check if +there is data to be read from the socket. If not it will return and you +will have to call loop_once() again to check if there is any data waiting +on the socket to be processed. In most cases you will have to count on +calling "loop_once" twice. + +A code fragment like: + + $ns->loop_once(10); + while( $ns->get_open_tcp() ){ + $ns->loop_once(0); + } + +Would wait for 10 seconds for the initial connection and would then +process all TCP sockets until none is left. + + +=head2 get_open_tcp + +In scalar context returns the number of TCP connections for which state +is maintained. In array context it returns IO::Socket objects, these could +be useful for troubleshooting but be careful using them. + + +=head1 EXAMPLE + +The following example will listen on port 5353 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 its basis may be applied. + + #!/usr/bin/perl + + 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 = new Net::DNS::RR("$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 = new Net::DNS::Nameserver( + LocalPort => 5353, + ReplyHandler => \&reply_handler, + Verbose => 1 + ) || die "couldn't create nameserver object\n"; + + + $ns->main_loop; + + +=head1 BUGS + +Limitations in perl 5.8.6 makes it impossible to guarantee that +replies to UDP queries from Net::DNS::Nameserver are sent from the +IP-address they were received on. This is a problem for machines with +multiple IP-addresses and causes violation of RFC2181 section 4. +Thus a UDP socket created listening to INADDR_ANY (all available +IP-addresses) will reply not necessarily with the source address being +the one to which the request was sent, but rather with the address that +the operating system chooses. This is also often called "the closest +address". This should really only be a problem on a server which has +more than one IP-address (besides localhost - any experience with IPv6 +complications here, would be nice). If this is a problem for you, a +work-around would be to not listen to INADDR_ANY but to specify each +address that you want this module to listen on. A separate set of +sockets will then be created 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 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 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 +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, RFC 1035 + +=cut + diff --git a/lib/lib/Net/DNS/Packet.pm b/lib/lib/Net/DNS/Packet.pm new file mode 100644 index 0000000..db5df00 --- /dev/null +++ b/lib/lib/Net/DNS/Packet.pm @@ -0,0 +1,873 @@ +package Net::DNS::Packet; + +# +# $Id: Packet.pm 1714 2018-09-21 14:14:55Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1714 $)[1]; + + +=head1 NAME + +Net::DNS::Packet - DNS protocol packet + +=head1 SYNOPSIS + + use Net::DNS::Packet; + + $query = new Net::DNS::Packet( 'example.com', 'MX', 'IN' ); + + $reply = $resolver->send( $query ); + + +=head1 DESCRIPTION + +A Net::DNS::Packet object represents a DNS protocol packet. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use constant UDPSZ => 512; + +BEGIN { + require Net::DNS::Header; + require Net::DNS::Question; + require Net::DNS::RR; +} + + +=head1 METHODS + +=head2 new + + $packet = new Net::DNS::Packet( 'example.com' ); + $packet = new Net::DNS::Packet( 'example.com', 'MX', 'IN' ); + + $packet = new Net::DNS::Packet(); + +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 { + return &decode if ref $_[1]; + my $class = shift; + + my $self = bless { + status => 0, + question => [], + answer => [], + authority => [], + additional => [], + }, $class; + + $self->{question} = [Net::DNS::Question->new(@_)] if scalar @_; + + return $self; +} + + +#=head2 decode + +=pod + + $packet = new Net::DNS::Packet( \$data ); + $packet = new Net::DNS::Packet( \$data, 1 ); # debug + +If passed a reference to a scalar containing DNS packet data, a new +packet object is created by decoding the data. +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 ) = new Net::DNS::Packet( \$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; # uncoverable pod + my $data = shift; + my $debug = shift || 0; + + my $offset = 0; + my $self; + eval { + local $SIG{__DIE__}; + die 'corrupt wire-format data' if length($$data) < HEADER_LENGTH; + + # header section + my ( $id, $status, @count ) = unpack 'n6', $$data; + my ( $qd, $an, $ns, $ar ) = @count; + $offset = HEADER_LENGTH; + + $self = bless { + id => $id, + status => $status, + count => [@count], + question => [], + answer => [], + authority => [], + additional => [], + replysize => length $$data + }, $class; + + # question/zone section + my $hash = {}; + my $record; + while ( $qd-- ) { + ( $record, $offset ) = decode Net::DNS::Question( $data, $offset, $hash ); + CORE::push( @{$self->{question}}, $record ); + } + + # RR sections + while ( $an-- ) { + ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); + CORE::push( @{$self->{answer}}, $record ); + } + + while ( $ns-- ) { + ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); + CORE::push( @{$self->{authority}}, $record ); + } + + while ( $ar-- ) { + ( $record, $offset ) = decode Net::DNS::RR( $data, $offset, $hash ); + CORE::push( @{$self->{additional}}, $record ); + } + + return $self; + }; + + if ($debug) { + local $@ = $@; + print $@ if $@; + $self->print if $self; + } + + return wantarray ? ( $self, $offset ) : $self; +} + + +=head2 data + + $data = $packet->data; + $data = $packet->data( $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 { + &encode; +} + +sub encode { + my ( $self, $size ) = @_; # uncoverable pod + + 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->header->id, $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; + bless \$self, q(Net::DNS::Header); +} + + +=head2 edns + + $edns = $packet->edns; + $version = $edns->version; + $UDPsize = $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 = new Net::DNS::RR( 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 = shift; + my $UDPmax = shift; + my $qheadr = $query->header; + croak 'erroneous qr flag in query packet' if $qheadr->qr; + + my $reply = new Net::DNS::Packet(); + 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->size($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}}; +} + +sub zone {&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}}; +} + +sub pre {&answer} +sub prerequisite {&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}}; +} + +sub update {&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}}; +} + + +=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; } + + +=head2 string + + print $packet->string; + +Returns a string representation of the packet. + +=cut + +sub string { + my $self = shift; + + my $header = $self->header; + my $update = $header->opcode eq 'UPDATE'; + + my $server = $self->{replyfrom}; + my $length = $self->{replysize}; + my $string = $server ? ";; Response received from $server ($length octets)\n" : ""; + + $string .= ";; HEADER SECTION\n" . $header->string; + + my $question = $update ? 'ZONE' : 'QUESTION'; + my @question = map $_->string, $self->question; + my $qdcount = scalar @question; + my $qds = $qdcount != 1 ? 's' : ''; + $string .= join "\n;; ", "\n;; $question SECTION ($qdcount record$qds)", @question; + + my $answer = $update ? 'PREREQUISITE' : 'ANSWER'; + my @answer = map $_->string, $self->answer; + my $ancount = scalar @answer; + my $ans = $ancount != 1 ? 's' : ''; + $string .= join "\n", "\n\n;; $answer SECTION ($ancount record$ans)", @answer; + + my $authority = $update ? 'UPDATE' : 'AUTHORITY'; + my @authority = map $_->string, $self->authority; + my $nscount = scalar @authority; + my $nss = $nscount != 1 ? 's' : ''; + $string .= join "\n", "\n\n;; $authority SECTION ($nscount record$nss)", @authority; + + my @additional = map $_->string, $self->additional; + my $arcount = scalar @additional; + my $ars = $arcount != 1 ? 's' : ''; + $string .= join "\n", "\n\n;; ADDITIONAL SECTION ($arcount record$ars)", @additional; + + return "$string\n\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 = shift; + + $self->{replyfrom} = shift if scalar @_; + $self->{replyfrom}; +} + +sub answerfrom { &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 { + shift->{replysize}; +} + +sub answersize { &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 = shift; + my $list = $self->_section(shift); + CORE::push( @$list, grep ref($_), @_ ); +} + + +=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 = shift; + my $list = $self->_section(shift); + my @rr = grep ref($_), @_; + + my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list; + + 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); + 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; + $self->{$list} ||= []; +} + + +=head2 sign_tsig + + $query = Net::DNS::Packet->new( 'www.example.com', 'A' ); + + $query->sign_tsig( + 'Khmac-sha512.example.+165+01018.private', + 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 historical simplified syntax is still available, but additional +options can not be specified. + + $packet->sign_tsig( $key_name, $key ); + + +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 ); + $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 = shift; + + eval { + local $SIG{__DIE__}; + require Net::DNS::RR::TSIG; + my $tsig = Net::DNS::RR::TSIG->create(@_); + $self->push( 'additional' => $tsig ); + return $tsig; + } || do { + croak "$@\nTSIG: unable to sign packet"; + }; +} + + +=head2 verify and verifyerr + + $packet->verify() || die $packet->verifyerr; + $reply->verify( $query ) || die $reply->verifyerr; + +Verify TSIG signature of packet or reply to the corresponding query. + + + $opaque = $packet1->verify( $query ) || die $packet1->verifyerr; + $opaque = $packet2->verify( $opaque ); + $verifed = $packet3->verify( $opaque ) || die $packet3->verifyerr; + +The opaque intermediate object references returned during multi-packet +verify() will be undefined (Boolean false) if verification fails. +Access to the object itself, if it exists, is expressly forbidden. +Testing at every stage may be omitted, which results in a BADSIG error +on the final packet in the absence of more specific information. + +=cut + +sub verify { + my $self = shift; + + my $sig = $self->sigrr; + return $sig ? $sig->verify( $self, @_ ) : shift; +} + +sub verifyerr { + my $self = shift; + + my $sig = $self->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 = new Net::DNS::Update('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; + + eval { + local $SIG{__DIE__}; + require Net::DNS::RR::SIG; + + my $sig0; + if ( ref($karg) eq 'Net::DNS::RR::SIG' ) { + $sig0 = $karg; + + } else { + $sig0 = Net::DNS::RR::SIG->create( '', $karg ); + } + + $self->push( 'additional' => $sig0 ); + return $sig0; + } || do { + 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 undef unless $sig; + return $sig if $sig->type eq 'TSIG'; + return $sig if $sig->type eq 'SIG'; + return undef; +} + + +######################################## + +=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; + pack 'n6 a*', $self->header->id, $self->{status}, @size, substr( $data, HEADER_LENGTH ); +} + + +######################################## + +sub dump { ## print internal data structure + require Data::Dumper; # uncoverable pod + local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 3; + local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; + print Data::Dumper::Dumper(@_); +} + + +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-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 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 +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, +RFC1035 Section 4.1, RFC2136 Section 2, RFC2845 + +=cut + diff --git a/lib/lib/Net/DNS/Parameters.pm b/lib/lib/Net/DNS/Parameters.pm new file mode 100644 index 0000000..e184e7a --- /dev/null +++ b/lib/lib/Net/DNS/Parameters.pm @@ -0,0 +1,429 @@ +package Net::DNS::Parameters; + +# +# $Id: Parameters.pm 1714 2018-09-21 14:14:55Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1714 $)[1]; + + +################################################ +## +## Domain Name System (DNS) Parameters +## (last updated 2018-01-08) +## +################################################ + + +use strict; +use warnings; +use integer; +use Carp; + +use base qw(Exporter); +our @EXPORT = qw( + classbyname classbyval %classbyname + typebyname typebyval %typebyname + opcodebyname opcodebyval + rcodebyname rcodebyval + ednsoptionbyname ednsoptionbyval + ); + + +# 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 + 'NSAP-PTR' => 23, # RFC1348 RFC1637 RFC1706 + SIG => 24, # RFC4034 RFC3755 RFC2535 RFC2536 RFC2537 RFC2931 RFC3110 RFC3008 + KEY => 25, # RFC4034 RFC3755 RFC2535 RFC2536 RFC2537 RFC2539 RFC3008 RFC3110 + PX => 26, # RFC2163 + GPOS => 27, # RFC1712 + AAAA => 28, # RFC3596 + LOC => 29, # RFC1876 + NXT => 30, # RFC3755 RFC2535 + 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, # RFC2915 RFC2168 RFC3403 + KX => 36, # RFC2230 + CERT => 37, # RFC4398 + A6 => 38, # RFC3226 RFC2874 RFC6563 + DNAME => 39, # RFC6672 + SINK => 40, # http://tools.ietf.org/html/draft-eastlake-kitchen-sink + OPT => 41, # RFC6891 RFC3225 + APL => 42, # RFC3123 + DS => 43, # RFC4034 RFC3658 + SSHFP => 44, # RFC4255 + IPSECKEY => 45, # RFC4025 + RRSIG => 46, # RFC4034 RFC3755 + NSEC => 47, # RFC4034 RFC3755 + DNSKEY => 48, # RFC4034 RFC3755 + DHCID => 49, # RFC4701 + NSEC3 => 50, # RFC5155 + 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 + 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 + TKEY => 249, # RFC2930 + TSIG => 250, # RFC2845 + IXFR => 251, # RFC1995 + AXFR => 252, # RFC1035 RFC5936 + MAILB => 253, # RFC1035 + MAILA => 254, # RFC1035 + ANY => 255, # RFC1035 RFC6895 + URI => 256, # RFC7553 + CAA => 257, # RFC6844 + AVC => 258, # + DOA => 259, # draft-durand-doa-over-dns + TA => 32768, # http://cameo.library.cmu.edu/ http://www.watson.org/~weiler/INI1999-19.pdf + DLV => 32769, # 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 + ); +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, # RFC2845 + NOTZONE => 10, # RFC2136 + BADVERS => 16, # RFC6891 + BADSIG => 16, # RFC2845 + BADKEY => 17, # RFC2845 + BADTIME => 18, # RFC2845 + BADMODE => 19, # RFC2930 + BADNAME => 20, # RFC2930 + BADALG => 21, # RFC2930 + BADTRUNC => 22, # RFC4635 + 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, # http://files.dns-sd.org/draft-sekar-dns-llq.txt + UL => 2, # http://files.dns-sd.org/draft-sekar-dns-ul.txt + 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 + DEVICEID => 26946, # https://docs.umbrella.com/developer/networkdevices-api/identifying-dns-traffic2 + ); +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; + + +######## + +# The following functions are wrappers around similarly named hashes. + +sub classbyname { + my $name = shift; + + $classbyname{$name} || $classbyname{uc $name} || do { + croak "unknown class $name" unless $name =~ m/^(CLASS)?(\d+)/i; + my $val = 0 + $2; + croak "classbyname( $name ) out of range" if $val > 0xffff; + return $val; + } +} + +sub classbyval { + my $val = shift; + + $classbyval{$val} || do { + $val += 0; + croak "classbyval( $val ) out of range" if $val > 0xffff; + return "CLASS$val"; + } +} + + +sub typebyname { + my $name = shift; + + $typebyname{$name} || do { + if ( $name =~ m/^(TYPE)?(\d+)/i ) { + my $val = 0 + $2; + croak "typebyname( $name ) out of range" if $val > 0xffff; + return $val; + } + _typespec("$name.RRNAME") unless $typebyname{uc $name}; + return $typebyname{uc $name} || croak "unknown type $name"; + } +} + +sub typebyval { + my $val = shift; + + $typebyval{$val} || do { + $val += 0; + croak "typebyval( $val ) out of range" if $val > 0xffff; + $typebyval{$val} = "TYPE$val"; + _typespec("$val.RRTYPE"); + return $typebyval{$val}; + } +} + + +sub opcodebyname { + my $arg = shift; + return $opcodebyname{$arg} if defined $opcodebyname{$arg}; + return 0 + $arg if $arg =~ /^\d/; + croak "unknown opcode $arg"; +} + +sub opcodebyval { + my $val = shift; + $opcodebyval{$val} || return $val; +} + + +sub rcodebyname { + my $arg = shift; + return $rcodebyname{$arg} if defined $rcodebyname{$arg}; + return 0 + $arg if $arg =~ /^\d/; + croak "unknown rcode $arg"; +} + +sub rcodebyval { + my $val = shift; + $rcodebyval{$val} || return $val; +} + + +sub ednsoptionbyname { + my $arg = shift; + return $ednsoptionbyname{$arg} if defined $ednsoptionbyname{$arg}; + return 0 + $arg if $arg =~ /^\d/; + croak "unknown option $arg"; +} + +sub ednsoptionbyval { + my $val = shift; + $ednsoptionbyval{$val} || return $val; +} + + +sub register { ## register( 'TOY', 1234 ) (NOT part of published API) + my ( $mnemonic, $rrtype ) = map uc($_), @_; # uncoverable pod + $rrtype = rand(255) + 65280 unless $rrtype; + for ( typebyval $rrtype = int($rrtype) ) { + croak "'$mnemonic' is a CLASS identifier" if $classbyname{$mnemonic}; + return $rrtype if /^$mnemonic$/; # duplicate registration + croak "'$mnemonic' conflicts with TYPE$rrtype ($_)" unless /^TYPE\d+$/; + my $known = $typebyname{$mnemonic}; + croak "'$mnemonic' conflicts with TYPE$known" if $known; + } + $typebyval{$rrtype} = $mnemonic; + return $typebyname{$mnemonic} = $rrtype; +} + + +use constant EXTLANG => defined eval 'require Net::DNS::Extlang'; + +our $DNSEXTLANG = EXTLANG ? eval 'Net::DNS::Extlang->new()->domain' : undef; + +sub _typespec { ## draft-levine-dnsextlang + eval <<'END' if EXTLANG && $DNSEXTLANG; + my ($node) = @_; + + require Net::DNS::Resolver; + my $resolver = new Net::DNS::Resolver() || return; + my $response = $resolver->send( "$node.$DNSEXTLANG", '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+$/; + register( $1, $2 ) if $identifier =~ /^(\w+):(\d+)\W*/; + return unless defined wantarray; + + my $extobj = new Net::DNS::Extlang(); + my $recipe = $extobj->xlstorerecord( $identifier, @attribute ); + my @source = split /\n/, $extobj->compilerr($recipe); + return sub { defined( $_ = shift @source ) }; + } + return; +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 + +Access functions which return the numerical code corresponding to +the given mnemonic. + +=head2 classbyval, typebyval, opcodebyval, rcodebyval, ednsoptionbyval + +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 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 +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 + diff --git a/lib/lib/Net/DNS/Question.pm b/lib/lib/Net/DNS/Question.pm new file mode 100644 index 0000000..0311acb --- /dev/null +++ b/lib/lib/Net/DNS/Question.pm @@ -0,0 +1,340 @@ +package Net::DNS::Question; + +# +# $Id: Question.pm 1714 2018-09-21 14:14:55Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1714 $)[1]; + + +=head1 NAME + +Net::DNS::Question - DNS question record + +=head1 SYNOPSIS + + use Net::DNS::Question; + + $question = new Net::DNS::Question('example.com', 'A', 'IN'); + +=head1 DESCRIPTION + +A Net::DNS::Question object represents a record in the question +section of a DNS packet. + +=cut + + +use strict; +use warnings; +use integer; +use Carp; + +use Net::DNS::Parameters; +use Net::DNS::Domain; +use Net::DNS::DomainName; + + +=head1 METHODS + +=head2 new + + $question = new Net::DNS::Question('example.com', 'A', 'IN'); + $question = new Net::DNS::Question('example.com'); + + $question = new Net::DNS::Question('192.0.32.10', 'PTR', 'IN'); + $question = new Net::DNS::Question('192.0.32.10'); + +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} = new Net::DNS::DomainName1035($qname); + $self->{qtype} = typebyname( $qtype || 'A' ); + $self->{qclass} = classbyname( $qclass || 'IN' ); + + return $self; +} + + +=head2 decode + + $question = decode Net::DNS::Question(\$data, $offset); + + ($question, $offset) = decode Net::DNS::Question(\$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 $self = bless {}, shift; + my ( $data, $offset ) = @_; + + ( $self->{qname}, $offset ) = decode Net::DNS::DomainName1035(@_); + + my $next = $offset + QFIXEDSZ; + die 'corrupt wire-format data' if length $$data < $next; + @{$self}{qw(qtype qclass)} = unpack "\@$offset n2", $$data; + + 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 = shift; + + pack 'a* n2', $self->{qname}->encode(@_), @{$self}{qw(qtype qclass)}; +} + + +=head2 print + + $object->print; + +Prints the record to the standard output. Calls the string() method +to get the string representation. + +=cut + +sub print { + print shift->string, "\n"; +} + + +=head2 string + + print "string = ", $question->string, "\n"; + +Returns a string representation of the question record. + +=cut + +sub string { + my $self = shift; + + join "\t", $self->{qname}->string, $self->qclass, $self->qtype; +} + + +=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 = new Net::DNS::Packet( $example, 'ANY' ); + $reply = $resolver->send($query) or die; + ($question) = $reply->question; + $name = $question->name; + +=cut + +sub name { + my $self = shift; + + croak 'immutable object: argument invalid' if scalar @_; + $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 = shift; + + croak 'immutable object: argument invalid' if scalar @_; + $self->{qname}->name; +} + +sub zname { &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 = shift; + + croak 'immutable object: argument invalid' if scalar @_; + typebyval( $self->{qtype} ); +} + +sub qtype { &type; } +sub ztype { &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 = shift; + + croak 'immutable object: argument invalid' if scalar @_; + classbyval( $self->{qclass} ); +} + +sub qclass { &class; } +sub zclass { &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 undef 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 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 +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, +RFC 1035 Section 4.1.2 + +=cut + diff --git a/lib/lib/Net/DNS/RR.pm b/lib/lib/Net/DNS/RR.pm new file mode 100644 index 0000000..83f0e19 --- /dev/null +++ b/lib/lib/Net/DNS/RR.pm @@ -0,0 +1,820 @@ +package Net::DNS::RR; + +# +# $Id: RR.pm 1718 2018-10-22 14:39:29Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1718 $)[1]; + + +=head1 NAME + +Net::DNS::RR - DNS resource record base class + +=head1 SYNOPSIS + + use Net::DNS; + + $rr = new Net::DNS::RR('example.com IN A 192.0.2.99'); + + $rr = new Net::DNS::RR( + owner => 'example.com', + type => 'A', + address => '192.0.2.99' + ); + + +=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 strict; +use warnings; +use integer; +use Carp; + +use constant LIB => grep $_ ne '.', grep !ref($_), @INC; + +use Net::DNS::Parameters; +use Net::DNS::Domain; +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 { + return eval { + local $SIG{__DIE__}; + scalar @_ > 2 ? &_new_hash : &_new_string; + } || do { + my $class = shift || __PACKAGE__; + my @param = map defined($_) ? split /\s+/ : 'undef', @_; + my $stmnt = substr "new $class( @param )", 0, 80; + croak "${@}in $stmnt\n"; + }; +} + + +=head2 new (from string) + + $a = new Net::DNS::RR('host.example.com. 86400 A 192.0.2.1'); + $mx = new Net::DNS::RR('example.com. 7200 MX 10 mailhost.example.com.'); + $cname = new Net::DNS::RR('www.example.com 300 IN CNAME host.example.com'); + $txt = new Net::DNS::RR('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()]/; + +sub _new_string { + my $base; + local $_; + ( $base, $_ ) = @_; + croak 'argument absent or undefined' unless defined $_; + croak 'non-scalar argument' if ref $_; + + # parse into quoted strings, contiguous non-whitespace and (discarded) comments + 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; + + croak 'unable to parse RR string' unless scalar @token; + my $t1 = uc $token[0]; + my $t2 = uc $token[1] if $#token; + + my ( $ttl, $class ); + if ( not defined $t2 ) { # + @token = ('ANY') if $classbyname{$t1}; # + } elsif ( $classbyname{$t1} || $t1 =~ /^CLASS\d/ ) { + $class = shift @token; # [] + $ttl = shift @token if $t2 =~ /^\d/; + } elsif ( $t1 =~ /^\d/ ) { + $ttl = shift @token; # [] + $class = shift @token if $classbyname{$t2} || $t2 =~ /^CLASS\d/; + } + + my $type = shift(@token); + my $populated = scalar @token; + + my $self = $base->_subclass( $type, $populated ); # create RR object + $self->owner($owner); + $self->class($class) if defined $class; # specify CLASS + $self->ttl($ttl) if defined $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 ); + croak 'length and hexadecimal data inconsistent' unless $rdlen == length $rdata; + $self->rdata($rdata); # unpack RDATA + return $self; + } + + $self->_parse_rdata(@token); # parse arguments + return $self; +} + + +=head2 new (from hash) + + $rr = new Net::DNS::RR(%hash); + + $rr = new Net::DNS::RR( + owner => 'host.example.com', + ttl => 86400, + class => 'IN', + type => 'A', + address => '192.0.2.1' + ); + + $rr = new Net::DNS::RR( + 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 $@; + + return $self; +} + + +=head2 decode + + ( $rr, $next ) = decode Net::DNS::RR( \$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. +Remaining arguments, if any, are passed as opaque data to +subordinate decoders. + +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. + +Any remaining arguments are passed as opaque data to subordinate +decoders and do not form part of the published interface. + +=cut + +use constant RRFIXEDSZ => length pack 'n2 N n', (0) x 4; + +sub decode { + my $base = shift; + my ( $data, $offset, @opaque ) = @_; + + my ( $owner, $fixed ) = decode Net::DNS::DomainName1035(@_); + + my $index = $fixed + RRFIXEDSZ; + 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; + + $self->{offset} = $offset || 0; + $self->_decode_rdata( $data, $index, @opaque ) if $next > $index or $self->type eq 'OPT'; + delete $self->{offset}; + + 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 = shift; + my ( $offset, @opaque ) = scalar(@_) ? @_ : ( 0x4000, {} ); + + 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 ); + 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 lower case 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 ); + 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"; +} + + +=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 ); + + my $empty = $self->_empty; + my @rdata = $empty ? () : eval { $self->_format_rdata }; + carp $@ if $@; + + my $tab = length($name) < 72 ? "\t" : ' '; + $self->_annotation('no data') if $empty; + + my @line = _wrap( join( $tab, @core, '(' ), @rdata, ')' ); + + my $last = pop(@line); # last or only line + $last = join $tab, @core, "@rdata" unless scalar(@line); + + 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 { + 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 ); + + my @rdata = $self->_empty ? () : eval { $self->_format_rdata }; + + # parse into quoted strings, contiguous non-whitespace and (discarded) comments + my @parse = map { s/\\\\/\\092/g; s/\\"/\\034/g; split /$PARSE_REGEX/o; } @rdata; + my @token = ( @core, grep defined && length, @parse ); +} + + +=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; + join ' ', @core, @data; +} + + +=head2 owner name + + $name = $rr->owner; + +Returns the owner name of the record. + +=cut + +sub owner { + my $self = shift; + $self->{owner} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{owner}->name if defined wantarray; +} + +sub name { &owner; } ## historical + + +=head2 type + + $type = $rr->type; + +Returns the record type. + +=cut + +sub type { + my $self = shift; + croak 'not possible to change RR->type' if scalar @_; + typebyval( $self->{type} ); +} + + +=head2 class + + $class = $rr->class; + +Resource record class. + +=cut + +sub class { + my $self = shift; + return $self->{class} = classbyname(shift) if scalar @_; + 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; + } + $self->{ttl} = $ttl; +} + + +################################################################################ +## +## Default implementation for unknown RR type +## +################################################################################ + +sub _decode_rdata { ## decode rdata from wire-format octet string + my ( $self, $data, $offset ) = @_; + $self->{rdata} = substr $$data, $offset, $self->{rdlength}; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $rdata = shift->{rdata}; +} + + +sub _format_rdata { ## format rdata portion of RR string + my $data = shift->rdata; + my $size = length($data); # RFC3597 unknown RR format + my @data = ( '\\#', $size, split /(\S{32})/, unpack 'H*', $data ); +} + + +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 _defaults { } ## set attribute default values + + +sub dump { ## print internal data structure + require Data::Dumper; # uncoverable pod + local $Data::Dumper::Maxdepth = $Data::Dumper::Maxdepth || 6; + local $Data::Dumper::Sortkeys = $Data::Dumper::Sortkeys || 1; + print Data::Dumper::Dumper(@_); +} + +sub rdatastr { ## historical RR subtype method + &rdstring; # uncoverable pod +} + + +=head2 rdata + + $rr = new Net::DNS::RR( 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 || ''; + my $hash = {}; + $self->_decode_rdata( \$data, 0, $hash ) if ( $self->{rdlength} = length $data ); + croak 'unexpected compression pointer in rdata' if keys %$hash; +} + + +=head2 rdstring + + $rdstring = $rr->rdstring; + +Returns a string representation of the RR-specific data. + +=cut + +sub rdstring { + my $self = shift; + + my @rdata = $self->_empty ? () : eval { $self->_format_rdata }; + carp $@ if $@; + + join "\n\t", _wrap(@rdata); +} + + +=head2 rdlength + + $rdlength = $rr->rdlength; + +Returns the uncompressed length of the encoded RR-specific data. + +=cut + +sub rdlength { + 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; +} + + +=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 { $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/::([^:]+)$/; + + $rrsortfunct{$type}{$attribute} || $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" ) { + push @INC, sub { + Net::DNS::Parameters::_typespec("$rrtype.RRTYPE"); + }; + + $subclass = join '::', __PACKAGE__, "TYPE$rrtype"; + eval "require $subclass"; + } + + $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}; + bless {@$prebuilt}, ref($prebuilt); # create object +} + + +sub _annotation { + my $self = shift; + $self->{annotation} = ["@_"] if scalar @_; + return @{$self->{annotation} || []} if wantarray; +} + + +my %ignore = map( ( $_ => 1 ), @core, 'annotation', '#' ); + +sub _empty { + not( $_[0]->{'#'} ||= scalar grep !$ignore{$_}, keys %{$_[0]} ); +} + + +sub _wrap { + my @text = @_; + my $cols = 80; + my $coln = 0; + + my ( @line, @fill ); + foreach (@text) { + if ( ( $coln += 1 + length ) > $cols ) { # start new line + push @line, join ' ', @fill if scalar @fill; + $coln = length; + @fill = (); + } + $coln = $cols if chomp; # force line break + push( @fill, $_ ); + } + push @line, join ' ', @fill; + return @line; +} + + +################################################################################ + +our $AUTOLOAD; + +sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) + +sub AUTOLOAD { ## Default method + my $self = shift; + my $oref = ref($self); + + no strict q/refs/; + my ($method) = reverse split /::/, $AUTOLOAD; + *{$AUTOLOAD} = sub {undef}; ## suppress repetition and 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__; + + @_ = ( <<"END", $@, "@object" ); +*** 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. +*** +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 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 +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, +RFC1035 Section 4.1.3, RFC1123, RFC3597 + +=cut + diff --git a/lib/lib/Net/DNS/RR/A.pm b/lib/lib/Net/DNS/RR/A.pm new file mode 100644 index 0000000..4a02e8b --- /dev/null +++ b/lib/lib/Net/DNS/RR/A.pm @@ -0,0 +1,136 @@ +package Net::DNS::RR::A; + +# +# $Id: A.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a4", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a4', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +my $pad = pack 'x4'; + +sub address { + my $self = shift; + my $addr = shift; + + 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); + $self->{address} = pack 'C4', @part, (0) x ( 3 - @part ), $last; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN A address'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC1035 Section 3.4.1 + +=cut diff --git a/lib/lib/Net/DNS/RR/AAAA.pm b/lib/lib/Net/DNS/RR/AAAA.pm new file mode 100644 index 0000000..1e97a18 --- /dev/null +++ b/lib/lib/Net/DNS/RR/AAAA.pm @@ -0,0 +1,176 @@ +package Net::DNS::RR::AAAA; + +# +# $Id: AAAA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a16", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a16', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address_short; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address_long { + my $addr = pack 'a*@16', grep defined, shift->{address}; + sprintf '%x:%x:%x:%x:%x:%x:%x:%x', unpack 'n8', $addr; +} + + +sub address_short { + my $addr = pack 'a*@16', grep defined, shift->{address}; + for ( 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 = shift; + + return address_long($self) unless scalar @_; + + my $addr = shift; + 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; + $self->{address} = pack 'n8', @expand; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN AAAA address'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC3596, RFC3513, RFC5952 + +=cut diff --git a/lib/lib/Net/DNS/RR/AFSDB.pm b/lib/lib/Net/DNS/RR/AFSDB.pm new file mode 100644 index 0000000..321afcf --- /dev/null +++ b/lib/lib/Net/DNS/RR/AFSDB.pm @@ -0,0 +1,149 @@ +package Net::DNS::RR::AFSDB; + +# +# $Id: AFSDB.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{subtype} = unpack "\@$offset n", $$data; + $self->{hostname} = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $hostname = $self->{hostname}; + 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}; + join ' ', $self->subtype, $hostname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->subtype(shift); + $self->hostname(shift); +} + + +sub subtype { + my $self = shift; + + $self->{subtype} = 0 + shift if scalar @_; + $self->{subtype} || 0; +} + + +sub hostname { + my $self = shift; + + $self->{hostname} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{hostname}->name if $self->{hostname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1183, RFC5864 + +=cut diff --git a/lib/lib/Net/DNS/RR/APL.pm b/lib/lib/Net/DNS/RR/APL.pm new file mode 100644 index 0000000..c2180dd --- /dev/null +++ b/lib/lib/Net/DNS/RR/APL.pm @@ -0,0 +1,281 @@ +package Net::DNS::RR::APL; + +# +# $Id: APL.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $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 +} + + +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; + } + join '', @rdata; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $aplist = $self->{aplist}; + my @rdata = map $_->string, @$aplist; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->aplist(@_); +} + + +sub aplist { + my $self = shift; + + while ( scalar @_ ) { # parse apitem strings + last unless $_[0] =~ m#[!:./]#; + shift =~ 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 = @_ ) { # 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 wantarray ? @ap : join ' ', map $_->string, @ap if defined wantarray; +} + + +######################################## + + +package Net::DNS::RR::APL::Item; + +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 $bit = 0x80; + for ( shift->{negate} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub family { + my $self = shift; + + $self->{family} = 0 + shift if scalar @_; + $self->{family} || 0; +} + + +sub prefix { + my $self = shift; + + $self->{prefix} = 0 + shift if scalar @_; + $self->{prefix} || 0; +} + + +sub address { + my $self = shift; + + my $family = $family{$self->family} || die 'unknown address family'; + return bless( {%$self}, $family )->address unless scalar @_; + + my $bitmask = $self->prefix; + my $address = bless( {}, $family )->address(shift); + $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 = new Net::DNS::RR('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 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 +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, RFC3123 + +=cut diff --git a/lib/lib/Net/DNS/RR/CAA.pm b/lib/lib/Net/DNS/RR/CAA.pm new file mode 100644 index 0000000..4cc8d5b --- /dev/null +++ b/lib/lib/Net/DNS/RR/CAA.pm @@ -0,0 +1,199 @@ +package Net::DNS::RR::CAA; + +# +# $Id: CAA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + $self->{flags} = unpack "\@$offset C", $$data; + ( $self->{tag}, $offset ) = decode Net::DNS::Text( $data, $offset + 1 ); + $self->{value} = decode Net::DNS::Text( $data, $offset, $limit - $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $tag = $self->{tag}; + pack 'C a* a*', $self->flags, $tag->encode, $self->{value}->raw; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $tag = $self->{tag}; + my @rdata = ( $self->flags, $tag->string, $self->{value}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->flags(shift); + $self->tag(shift); + $self->value(shift); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->flags(0); +} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub critical { + my $bit = 0x0080; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub tag { + my $self = shift; + + $self->{tag} = new Net::DNS::Text(shift) if scalar @_; + $self->{tag}->value if $self->{tag}; +} + + +sub value { + my $self = shift; + + $self->{value} = new Net::DNS::Text(shift) if scalar @_; + $self->{value}->value if $self->{value}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 ); + +The property identifier, a sequence of ASCII characters. + +Tag values may contain ASCII characters a-z, A-Z, and 0-9. +Tag values should not contain any other characters. +Matching of tag values 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 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 +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, RFC6844 + +=cut diff --git a/lib/lib/Net/DNS/RR/CDNSKEY.pm b/lib/lib/Net/DNS/RR/CDNSKEY.pm new file mode 100644 index 0000000..b2059d3 --- /dev/null +++ b/lib/lib/Net/DNS/RR/CDNSKEY.pm @@ -0,0 +1,99 @@ +package Net::DNS::RR::CDNSKEY; + +# +# $Id: CDNSKEY.pm 1586 2017-08-15 09:01:57Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1586 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::DNSKEY); + +=head1 NAME + +Net::DNS::RR::CDNSKEY - DNS CDNSKEY 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(flags protocol algorithm)} = ( 0, 3, 0 ); +} + + +sub key { + my $self = shift; + return $self->SUPER::key(@_) unless defined( $_[0] ) && length( $_[0] ) < 2; + return $self->SUPER::keybin( $_[0] ? '' : chr(0) ); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC7344, RFC8078(erratum 5049) + +=cut diff --git a/lib/lib/Net/DNS/RR/CDS.pm b/lib/lib/Net/DNS/RR/CDS.pm new file mode 100644 index 0000000..b40f841 --- /dev/null +++ b/lib/lib/Net/DNS/RR/CDS.pm @@ -0,0 +1,105 @@ +package Net::DNS::RR::CDS; + +# +# $Id: CDS.pm 1586 2017-08-15 09:01:57Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1586 $)[1]; + + +use strict; +use warnings; +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)} = ( 0, 0, 0 ); +} + + +sub digtype { + my ( $self, $arg ) = @_; + $self->SUPER::digtype( $arg ? $arg : () ); +} + + +sub digest { + my $self = shift; + return $self->SUPER::digest(@_) unless defined( $_[0] ) && length( $_[0] ) < 2; + return $self->SUPER::digestbin( $_[0] ? '' : chr(0) ); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC7344, RFC8078(erratum 5049) + +=cut diff --git a/lib/lib/Net/DNS/RR/CERT.pm b/lib/lib/Net/DNS/RR/CERT.pm new file mode 100644 index 0000000..09e35a6 --- /dev/null +++ b/lib/lib/Net/DNS/RR/CERT.pm @@ -0,0 +1,269 @@ +package Net::DNS::RR::CERT; + +# +# $Id: CERT.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 + ); + + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + 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] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; 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 "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(certtype keytag algorithm)} = unpack "\@$offset n2 C", $$data; + $self->{certbin} = substr $$data, $offset + 5, $self->{rdlength} - 5; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + 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 @base64 = split /\s+/, encode_base64( $self->{certbin} ); + my @rdata = ( $self->certtype, $self->keytag, $self->algorithm, @base64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->certtype(shift); + $self->keytag(shift); + $self->algorithm(shift); + $self->cert(@_); +} + + +sub certtype { + my $self = shift; + + return $self->{certtype} unless scalar @_; + + my $certtype = shift || 0; + return $self->{certtype} = $certtype unless $certtype =~ /\D/; + + my $typenum = $certtype{$certtype}; + $typenum || croak "unknown certtype $certtype"; + $self->{certtype} = $typenum; +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $self->{keytag} || 0; +} + + +sub algorithm { + my ( $self, $arg ) = @_; + + return $self->{algorithm} unless defined $arg; + return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC'; + $self->{algorithm} = _algbyname($arg); +} + + +sub certificate { &certbin; } + + +sub certbin { + my $self = shift; + + $self->{certbin} = shift if scalar @_; + $self->{certbin} || ""; +} + + +sub cert { + my $self = shift; + return MIME::Base64::encode( $self->certbin(), "" ) unless scalar @_; + $self->certbin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub format { &certtype; } # uncoverable pod + +sub tag { &keytag; } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC4398 + +=cut diff --git a/lib/lib/Net/DNS/RR/CNAME.pm b/lib/lib/Net/DNS/RR/CNAME.pm new file mode 100644 index 0000000..84fb43a --- /dev/null +++ b/lib/lib/Net/DNS/RR/CNAME.pm @@ -0,0 +1,135 @@ +package Net::DNS::RR::CNAME; + +# +# $Id: CNAME.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + + $self->{cname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $cname = $self->{cname}; + $cname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $cname = $self->{cname}; + $cname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->cname(shift); +} + + +sub cname { + my $self = shift; + + $self->{cname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{cname}->name if $self->{cname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name CNAME cname'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC1035 Section 3.3.1 + +=cut diff --git a/lib/lib/Net/DNS/RR/CSYNC.pm b/lib/lib/Net/DNS/RR/CSYNC.pm new file mode 100644 index 0000000..12cda42 --- /dev/null +++ b/lib/lib/Net/DNS/RR/CSYNC.pm @@ -0,0 +1,219 @@ +package Net::DNS::RR::CSYNC; + +# +# $Id: CSYNC.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::CSYNC - DNS CSYNC resource record + +=cut + + +use integer; + +use Net::DNS::Parameters; +use Net::DNS::RR::NSEC; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{qw(soaserial flags)} = unpack "\@$offset Nn", $$data; + $offset += 6; + $self->{typebm} = substr $$data, $offset, $limit - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + 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 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->soaserial(shift); + $self->flags(shift); + $self->typelist(@_); +} + + +sub soaserial { + my $self = shift; + + $self->{soaserial} = 0 + shift if scalar @_; + $self->{soaserial} || 0; +} + + +sub SOAserial {&soaserial} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub immediate { + my $bit = 0x0001; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub soaminimum { + my $bit = 0x0002; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub typelist { + &Net::DNS::RR::NSEC::typelist; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC7477 + +=cut diff --git a/lib/lib/Net/DNS/RR/DHCID.pm b/lib/lib/Net/DNS/RR/DHCID.pm new file mode 100644 index 0000000..304905f --- /dev/null +++ b/lib/lib/Net/DNS/RR/DHCID.pm @@ -0,0 +1,188 @@ +package Net::DNS::RR::DHCID; + +# +# $Id: DHCID.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::DHCID - DNS DHCID resource record + +=cut + + +use integer; + +use MIME::Base64; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $size = $self->{rdlength} - 3; + @{$self}{qw(identifiertype digesttype digest)} = unpack "\@$offset nC a$size", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'nC a*', map $self->$_, qw(identifiertype digesttype digest); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @base64 = split /\s+/, encode_base64( $self->_encode_rdata ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my $data = MIME::Base64::decode( join "", @_ ); + my $size = length($data) - 3; + @{$self}{qw(identifiertype digesttype digest)} = unpack "n C a$size", $data; +} + + +# +------------------+------------------------------------------------+ +# | 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 { + my $self = shift; + + $self->{identifiertype} = 0 + shift if scalar @_; + $self->{identifiertype} || 0; +} + + +sub digesttype { + my $self = shift; + + $self->{digesttype} = 0 + shift if scalar @_; + $self->{digesttype} || 0; +} + + +sub digest { + my $self = shift; + + $self->{digest} = shift if scalar @_; + $self->{digest} || ""; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('client.example.com. DHCID ( AAAB + xLmlskllE0MVjd57zHcWmEH3pCQ6VytcKD//7es/deY='); + + $rr = new Net::DNS::RR( + 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; + $rr->identifiertype( $identifiertype ); + +The 16-bit identifier type describes the form of host identifier +used to construct the DHCP identity information. + +=head2 digesttype + + $digesttype = $rr->digesttype; + $rr->digesttype( $digesttype ); + +The 8-bit digest type number describes the message-digest +algorithm used to obfuscate the DHCP identity information. + +=head2 digest + + $digest = $rr->digest; + $rr->digest( $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 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 +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, RFC4701 + +=cut diff --git a/lib/lib/Net/DNS/RR/DLV.pm b/lib/lib/Net/DNS/RR/DLV.pm new file mode 100644 index 0000000..bba13f7 --- /dev/null +++ b/lib/lib/Net/DNS/RR/DLV.pm @@ -0,0 +1,81 @@ +package Net::DNS::RR::DLV; + +# +# $Id: DLV.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::DS); + +=head1 NAME + +Net::DNS::RR::DLV - DNS DLV resource record + +=cut + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name DLV keytag algorithm digtype digest'); + +=head1 DESCRIPTION + +DNS DLV 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 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 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 +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, RFC4431 + +=cut diff --git a/lib/lib/Net/DNS/RR/DNAME.pm b/lib/lib/Net/DNS/RR/DNAME.pm new file mode 100644 index 0000000..5bd42fa --- /dev/null +++ b/lib/lib/Net/DNS/RR/DNAME.pm @@ -0,0 +1,130 @@ +package Net::DNS::RR::DNAME; + +# +# $Id: DNAME.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + + $self->{target} = decode Net::DNS::DomainName2535(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $target = $self->{target}; + $target->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $target = $self->{target}; + $target->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->target(shift); +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{target}->name if $self->{target}; +} + + +sub dname { ⌖ } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC6672 + +=cut diff --git a/lib/lib/Net/DNS/RR/DNSKEY.pm b/lib/lib/Net/DNS/RR/DNSKEY.pm new file mode 100644 index 0000000..be212e7 --- /dev/null +++ b/lib/lib/Net/DNS/RR/DNSKEY.pm @@ -0,0 +1,426 @@ +package Net::DNS::RR::DNSKEY; + +# +# $Id: DNSKEY.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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'; + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + 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] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; 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 "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $rdata = substr $$data, $offset, $self->{rdlength}; + $self->{keybin} = unpack '@4 a*', $rdata; + @{$self}{qw(flags protocol algorithm)} = unpack 'n C*', $rdata; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n C2 a*', @{$self}{qw(flags protocol algorithm keybin)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $algorithm = $self->{algorithm}; + $self->_annotation( 'Key ID =', $self->keytag ) if $algorithm; + return $self->SUPER::_format_rdata() unless BASE64; + my @base64 = split /\s+/, MIME::Base64::encode( $self->{keybin} ) || '-'; + my @rdata = ( @{$self}{qw(flags protocol)}, $algorithm, @base64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my $flags = shift; ## avoid destruction by CDNSKEY algorithm(0) + $self->protocol(shift); + $self->algorithm(shift); + $self->flags($flags); + $self->key(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->algorithm(1); + $self->flags(256); + $self->protocol(3); +} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub zone { + my $bit = 0x0100; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub revoke { + my $bit = 0x0080; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub sep { + my $bit = 0x0001; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub protocol { + my $self = shift; + + $self->{protocol} = 0 + shift if scalar @_; + $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'; + $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0) +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +sub publickey { shift->key(@_); } + + +sub privatekeyname { + my $self = shift; + my $name = $self->signame; + sprintf 'K%s+%03d+%05d.private', $name, $self->algorithm, $self->keytag; +} + + +sub signame { + my $self = shift; + my $name = lc $self->{owner}->fqdn; +} + + +sub keylength { + my $self = shift; + + my $keybin = $self->keybin || return undef; + + 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; + } + + length($keybin) << 2; ## ECDSA / ECC-GOST +} + + +sub keytag { + my $self = shift; + + my $keybin = $self->keybin || return 0; + + # 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; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 + +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 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 +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, RFC4034, RFC3755 + +L + +=cut diff --git a/lib/lib/Net/DNS/RR/DS.pm b/lib/lib/Net/DNS/RR/DS.pm new file mode 100644 index 0000000..d8306c1 --- /dev/null +++ b/lib/lib/Net/DNS/RR/DS.pm @@ -0,0 +1,406 @@ +package Net::DNS::RR::DS; + +# +# $Id: DS.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 +eval 'require Digest::GOST'; +eval 'require Digest::GOST::CryptoPro'; + +my %digest = ( + '1' => ['Digest::SHA', 1], + '2' => ['Digest::SHA', 256], + '3' => ['Digest::GOST::CryptoPro'], + '4' => ['Digest::SHA', 384], + ); + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + 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] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; 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 "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + +# +# source: http://www.iana.org/assignments/ds-rr-types +# +{ + my @digestbyname = ( + 'SHA-1' => 1, # RFC3658 + 'SHA-256' => 2, # RFC4509 + 'GOST-R-34.11-94' => 3, # RFC5933 + 'SHA-384' => 4, # RFC6605 + ); + + my @digestalias = ( + 'SHA' => 1, + 'GOST' => 3, + ); + + my %digestbyval = reverse @digestbyname; + + my @digestrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; 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 "unknown digest type $arg"; + } + + sub _digestbyval { + my $value = shift; + $digestbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $rdata = substr $$data, $offset, $self->{rdlength}; + $self->{digestbin} = unpack '@4 a*', $rdata; + @{$self}{qw(keytag algorithm digtype)} = unpack 'n C*', $rdata; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n C2 a*', @{$self}{qw(keytag algorithm digtype digestbin)}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->_annotation( $self->babble ) if BABBLE && $self->{algorithm}; + my @digest = split /(\S{64})/, $self->digest || '-'; + my @rdata = ( @{$self}{qw(keytag algorithm digtype)}, @digest ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my $keytag = shift; ## avoid destruction by CDS algorithm(0) + $self->algorithm(shift); + $self->keytag($keytag); + $self->digtype(shift); + $self->digest(@_); +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $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'; + $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'; + $self->{digtype} = _digestbyname($arg) || die _digestbyname('') # disallow digtype(0) +} + + +sub digest { + my $self = shift; + return unpack "H*", $self->digestbin() unless scalar @_; + $self->digestbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub digestbin { + my $self = shift; + + $self->{digestbin} = shift if scalar @_; + $self->{digestbin} || ""; +} + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->digestbin ) : ''; +} + + +sub create { + my $class = shift; + my $keyrr = shift; + my %args = $keyrr->ttl ? ( ttl => $keyrr->ttl, @_ ) : (@_); + + my ($type) = reverse split '::', $class; + + my $kname = $keyrr->name; + my $flags = $keyrr->flags; + croak "Unable to create $type record for non-DNSSEC key" unless $keyrr->protocol == 3; + croak "Unable to create $type record for non-authentication key" if $flags & 0x8000; + croak "Unable to create $type record for non-ZONE key" unless ( $flags & 0x300 ) == 0x100; + + my $self = new Net::DNS::RR( + name => $kname, # per definition, same as keyrr + type => $type, + class => $keyrr->class, + keytag => $keyrr->keytag, + algorithm => $keyrr->algorithm, + digtype => 1, # SHA1 by default + %args + ); + + my $owner = $self->{owner}->encode(); + my $data = pack 'a* a*', $owner, $keyrr->_encode_rdata; + + my $arglist = $digest{$self->digtype}; + croak join ' ', 'digtype', $self->digtype('MNEMONIC'), 'not supported' unless $arglist; + my ( $object, @argument ) = @$arglist; + my $hash = $object->new(@argument); + $hash->add($data); + $self->digestbin( $hash->digest ); + + return $self; +} + + +sub verify { + my ( $self, $key ) = @_; + my $verify = create Net::DNS::RR::DS( $key, ( digtype => $self->digtype ) ); + return $verify->digestbin eq $self->digestbin; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name DS keytag algorithm digtype digest'); + + use Net::DNS::SEC; + $ds = create Net::DNS::RR::DS( + $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 = create Net::DNS::RR::DS($keyrr, digtype => 'SHA-256' ); + $keyrr->print; + $dsrr->print; + +This constructor takes a key object as argument and will return the +corresponding DS RR object. + +The digest type 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 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 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 +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, RFC4034, RFC3658 + +L, +L + +=cut diff --git a/lib/lib/Net/DNS/RR/EUI48.pm b/lib/lib/Net/DNS/RR/EUI48.pm new file mode 100644 index 0000000..f830984 --- /dev/null +++ b/lib/lib/Net/DNS/RR/EUI48.pm @@ -0,0 +1,133 @@ +package Net::DNS::RR::EUI48; + +# +# $Id: EUI48.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a6", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a6', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address { + my ( $self, $address ) = @_; + $self->{address} = pack 'C6', map hex($_), split /[:-]/, $address if $address; + join '-', unpack 'H2H2H2H2H2H2', $self->{address} if defined wantarray; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN EUI48 address'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC7043 + +=cut diff --git a/lib/lib/Net/DNS/RR/EUI64.pm b/lib/lib/Net/DNS/RR/EUI64.pm new file mode 100644 index 0000000..22586a7 --- /dev/null +++ b/lib/lib/Net/DNS/RR/EUI64.pm @@ -0,0 +1,133 @@ +package Net::DNS::RR::EUI64; + +# +# $Id: EUI64.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + $self->{address} = unpack "\@$offset a8", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a8', $self->{address}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->address; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address { + my ( $self, $address ) = @_; + $self->{address} = pack 'C8', map hex($_), split /[:-]/, $address if $address; + join '-', unpack 'H2H2H2H2H2H2H2H2', $self->{address} if defined wantarray; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name IN EUI64 address'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC7043 + +=cut diff --git a/lib/lib/Net/DNS/RR/GPOS.pm b/lib/lib/Net/DNS/RR/GPOS.pm new file mode 100644 index 0000000..ac64180 --- /dev/null +++ b/lib/lib/Net/DNS/RR/GPOS.pm @@ -0,0 +1,181 @@ +package Net::DNS::RR::GPOS; + +# +# $Id: GPOS.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + ( $self->{latitude}, $offset ) = decode Net::DNS::Text( $data, $offset ) if $offset < $limit; + ( $self->{longitude}, $offset ) = decode Net::DNS::Text( $data, $offset ) if $offset < $limit; + ( $self->{altitude}, $offset ) = decode Net::DNS::Text( $data, $offset ) if $offset < $limit; + croak('corrupt GPOS data') unless $offset == $limit; # more or less FUBAR +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + return '' unless defined $self->{altitude}; + join '', map $self->{$_}->encode, qw(latitude longitude altitude); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + return '' unless defined $self->{altitude}; + join ' ', map $self->{$_}->string, qw(latitude longitude altitude); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->latitude(shift); + $self->longitude(shift); + $self->altitude(shift); + die 'too many arguments for GPOS' if scalar @_; +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->_parse_rdata(qw(0.0 0.0 0.0)); +} + + +sub latitude { + my $self = shift; + $self->{latitude} = _fp2text(shift) if scalar @_; + _text2fp( $self->{latitude} ) if defined wantarray; +} + + +sub longitude { + my $self = shift; + $self->{longitude} = _fp2text(shift) if scalar @_; + _text2fp( $self->{longitude} ) if defined wantarray; +} + + +sub altitude { + my $self = shift; + $self->{altitude} = _fp2text(shift) if scalar @_; + _text2fp( $self->{altitude} ) if defined wantarray; +} + + +######################################## + +sub _fp2text { + return new Net::DNS::Text( sprintf( '%1.10g', shift ) ); +} + +sub _text2fp { + no integer; + return 0.0 + shift->value; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1712 + +=cut diff --git a/lib/lib/Net/DNS/RR/HINFO.pm b/lib/lib/Net/DNS/RR/HINFO.pm new file mode 100644 index 0000000..c67583d --- /dev/null +++ b/lib/lib/Net/DNS/RR/HINFO.pm @@ -0,0 +1,142 @@ +package Net::DNS::RR::HINFO; + +# +# $Id: HINFO.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + ( $self->{cpu}, $offset ) = decode Net::DNS::Text( $data, $offset ); + ( $self->{os}, $offset ) = decode Net::DNS::Text( $data, $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + join '', $self->{cpu}->encode, $self->{os}->encode; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->{cpu}->string, $self->{os}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->cpu(shift); + $self->os(@_); +} + + +sub cpu { + my $self = shift; + + $self->{cpu} = new Net::DNS::Text(shift) if scalar @_; + $self->{cpu}->value if $self->{cpu}; +} + + +sub os { + my $self = shift; + + $self->{os} = new Net::DNS::Text(shift) if scalar @_; + $self->{os}->value if $self->{os}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1035 Section 3.3.2 + +=cut diff --git a/lib/lib/Net/DNS/RR/HIP.pm b/lib/lib/Net/DNS/RR/HIP.pm new file mode 100644 index 0000000..48cedde --- /dev/null +++ b/lib/lib/Net/DNS/RR/HIP.pm @@ -0,0 +1,228 @@ +package Net::DNS::RR::HIP; + +# +# $Id: HIP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my ( $hitlen, $pklen ) = unpack "\@$offset Cxn", $$data; + @{$self}{qw(pkalgorithm 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 ) = decode Net::DNS::DomainName( $data, $offset ); + push @{$self->{servers}}, $item; + } + croak('corrupt HIP data') unless $offset == $limit; # more or less FUBAR +} + + +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->pkalgorithm, length($key), $hit, $key; + join '', $nos, map $_->encode, @{$self->{servers}}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $base64 = encode_base64( $self->keybin, '' ); + my @server = map $_->string, @{$self->{servers}}; + my @rdata = ( $self->pkalgorithm, $self->hit, $base64, @server ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach (qw(pkalgorithm hit key)) { $self->$_(shift) } + $self->servers(@_); +} + + +sub pkalgorithm { + my $self = shift; + + $self->{pkalgorithm} = 0 + shift if scalar @_; + $self->{pkalgorithm} || 0; +} + + +sub hit { + my $self = shift; + return unpack "H*", $self->hitbin() unless scalar @_; + $self->hitbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub hitbin { + my $self = shift; + + $self->{hitbin} = shift if scalar @_; + $self->{hitbin} || ""; +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +sub pubkey { &key; } + +sub servers { + my $self = shift; + + my $servers = $self->{servers} ||= []; + @$servers = map Net::DNS::DomainName->new($_), @_ if scalar @_; + return map $_->name, @$servers if defined wantarray; +} + +sub rendezvousservers { ## historical + my @servers = &servers; # uncoverable pod + \@servers; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 pkalgorithm + + $pkalgorithm = $rr->pkalgorithm; + $rr->pkalgorithm( $pkalgorithm ); + +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 pubkey + +=head2 key + + $key = $rr->key; + $rr->key( $key ); + +The hexadecimal 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 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 +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, RFC8005 + +=cut diff --git a/lib/lib/Net/DNS/RR/IPSECKEY.pm b/lib/lib/Net/DNS/RR/IPSECKEY.pm new file mode 100644 index 0000000..d7ccbc8 --- /dev/null +++ b/lib/lib/Net/DNS/RR/IPSECKEY.pm @@ -0,0 +1,301 @@ +package Net::DNS::RR::IPSECKEY; + +# +# $Id: IPSECKEY.pm 1718 2018-10-22 14:39:29Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1718 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::IPSECKEY - DNS IPSECKEY resource record + +=cut + + +use integer; + +use Carp; +use MIME::Base64; + +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 = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + + @{$self}{qw(precedence gatetype algorithm)} = unpack "\@$offset C3", $$data; + $offset += 3; + + my $gatetype = $self->{gatetype}; + if ( not $gatetype ) { + $self->{gateway} = undef; # 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 ) = decode Net::DNS::DomainName( $data, $offset ); + $self->{gateway} = $name; + + } else { + die "unknown gateway type ($gatetype)"; + } + + $self->keybin( substr $$data, $offset, $limit - $offset ); +} + + +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; + + if ( not $gatetype ) { + return pack 'C3 a*', $precedence, $gatetype, $algorithm, $keybin; + + } elsif ( $gatetype == 1 ) { + return pack 'C3 a4 a*', $precedence, $gatetype, $algorithm, $gateway, $keybin; + + } elsif ( $gatetype == 2 ) { + return pack 'C3 a16 a*', $precedence, $gatetype, $algorithm, $gateway, $keybin; + + } elsif ( $gatetype == 3 ) { + my $namebin = $gateway->encode; + return pack 'C3 a* a*', $precedence, $gatetype, $algorithm, $namebin, $keybin; + } + die "unknown gateway type ($gatetype)"; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @params = map $self->$_, qw(precedence gatetype algorithm); + my @base64 = split /\s+/, encode_base64( $self->keybin ); + my @rdata = ( @params, $self->gateway, @base64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach (qw(precedence gatetype algorithm gateway)) { $self->$_(shift) } + $self->key(@_); +} + + +sub precedence { + my $self = shift; + + $self->{precedence} = 0 + shift if scalar @_; + $self->{precedence} || 0; +} + + +sub gatetype { + return shift->{gatetype} || 0; +} + + +sub algorithm { + my $self = shift; + + $self->{algorithm} = 0 + shift if scalar @_; + $self->{algorithm} || 0; +} + + +sub gateway { + my $self = shift; + + for (@_) { + /^\.*$/ && do { + $self->{gatetype} = 0; + $self->{gateway} = undef; # 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} = new Net::DNS::DomainName($_); + last; + }; + croak 'unrecognised gateway type'; + } + + if ( defined wantarray ) { + my $gatetype = $self->{gatetype}; + return wantarray ? '.' : undef unless $gatetype; + my $gateway = $self->{gateway}; + for ($gatetype) { + /^1$/ && return Net::DNS::RR::A::address( {address => $gateway} ); + /^2$/ && return Net::DNS::RR::AAAA::address( {address => $gateway} ); + /^3$/ && return wantarray ? $gateway->string : $gateway->name; + die "unknown gateway type ($gatetype)"; + } + } +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +sub pubkey { &key; } + + +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 = new Net::DNS::RR('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 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 +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, RFC4025 + +=cut diff --git a/lib/lib/Net/DNS/RR/ISDN.pm b/lib/lib/Net/DNS/RR/ISDN.pm new file mode 100644 index 0000000..23d7e01 --- /dev/null +++ b/lib/lib/Net/DNS/RR/ISDN.pm @@ -0,0 +1,158 @@ +package Net::DNS::RR::ISDN; + +# +# $Id: ISDN.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + ( $self->{address}, $offset ) = decode Net::DNS::Text( $data, $offset ); + ( $self->{sa}, $offset ) = decode Net::DNS::Text( $data, $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $address = $self->{address}; + join '', $address->encode, $self->{sa}->encode; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $address = $self->{address}; + join ' ', $address->string, $self->{sa}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); + $self->sa(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->sa(''); +} + + +sub address { + my $self = shift; + + $self->{address} = new Net::DNS::Text(shift) if scalar @_; + $self->{address}->value if $self->{address}; +} + + +sub sa { + my $self = shift; + + $self->{sa} = new Net::DNS::Text(shift) if scalar @_; + $self->{sa}->value if $self->{sa}; +} + + +sub ISDNaddress { &address; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1183 Section 3.2 + +=cut diff --git a/lib/lib/Net/DNS/RR/KEY.pm b/lib/lib/Net/DNS/RR/KEY.pm new file mode 100644 index 0000000..d7fee0b --- /dev/null +++ b/lib/lib/Net/DNS/RR/KEY.pm @@ -0,0 +1,90 @@ +package Net::DNS::RR::KEY; + +# +# $Id: KEY.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +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); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC3755, RFC2535 + +=cut diff --git a/lib/lib/Net/DNS/RR/KX.pm b/lib/lib/Net/DNS/RR/KX.pm new file mode 100644 index 0000000..3ee3c22 --- /dev/null +++ b/lib/lib/Net/DNS/RR/KX.pm @@ -0,0 +1,157 @@ +package Net::DNS::RR::KX; + +# +# $Id: KX.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{exchange} = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $exchange = $self->{exchange}; + 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}; + join ' ', $self->preference, $exchange->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->exchange(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub exchange { + my $self = shift; + + $self->{exchange} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{exchange}->name if $self->{exchange}; +} + + +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 = new Net::DNS::RR('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 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 +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, RFC2230 + +=cut diff --git a/lib/lib/Net/DNS/RR/L32.pm b/lib/lib/Net/DNS/RR/L32.pm new file mode 100644 index 0000000..0b881f5 --- /dev/null +++ b/lib/lib/Net/DNS/RR/L32.pm @@ -0,0 +1,164 @@ +package Net::DNS::RR::L32; + +# +# $Id: L32.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(preference locator32)} = unpack "\@$offset n a4", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n a4', $self->{preference}, $self->{locator32}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->locator32; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->locator32(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub locator32 { + my $self = shift; + my $prfx = shift; + + $self->{locator32} = pack 'C* @4', split /\./, $prfx if defined $prfx; + + join '.', unpack 'C4', $self->{locator32} if $self->{locator32}; +} + + +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 = new Net::DNS::RR('name IN L32 preference locator32'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC6742 + +=cut diff --git a/lib/lib/Net/DNS/RR/L64.pm b/lib/lib/Net/DNS/RR/L64.pm new file mode 100644 index 0000000..f480665 --- /dev/null +++ b/lib/lib/Net/DNS/RR/L64.pm @@ -0,0 +1,164 @@ +package Net::DNS::RR::L64; + +# +# $Id: L64.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(preference locator64)} = unpack "\@$offset n a8", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n a8', $self->{preference}, $self->{locator64}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->locator64; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->locator64(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub locator64 { + my $self = shift; + my $prfx = shift; + + $self->{locator64} = pack 'n4', map hex($_), split /:/, $prfx if defined $prfx; + + sprintf '%x:%x:%x:%x', unpack 'n4', $self->{locator64} if $self->{locator64}; +} + + +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 = new Net::DNS::RR('name IN L64 preference locator64'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC6742 + +=cut diff --git a/lib/lib/Net/DNS/RR/LOC.pm b/lib/lib/Net/DNS/RR/LOC.pm new file mode 100644 index 0000000..1b82ec0 --- /dev/null +++ b/lib/lib/Net/DNS/RR/LOC.pm @@ -0,0 +1,347 @@ +package Net::DNS::RR::LOC; + +# +# $Id: LOC.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $version = $self->{version} = unpack "\@$offset C", $$data; + @{$self}{qw(size hp vp latitude longitude altitude)} = unpack "\@$offset xC3N3", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + 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/\s+10m$//; + s/\s+10000m$//; + s/\s*1m$//; + } + my @rdata = ( $self->latitude, '', $self->longitude, '', $altitude, $precision ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + my @lat; + while ( scalar @_ ) { + my $this = shift; + push( @lat, $this ); + last if $this =~ /[NSns]/; + } + $self->latitude(@lat); + + my @long; + while ( scalar @_ ) { + my $this = shift; + push( @long, $this ); + last if $this =~ /[EWew]/; + } + $self->longitude(@long); + + foreach my $attr (qw(altitude size hp vp)) { + $self->$attr(@_); + shift; + } +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->{version} = 0; + $self->size(1); + $self->hp(10000); + $self->vp(10); +} + + +sub latitude { + my $self = shift; + $self->{latitude} = _encode_lat(@_) if scalar @_; + return _decode_lat( $self->{latitude} ) if defined wantarray; +} + + +sub longitude { + my $self = shift; + $self->{longitude} = _encode_lat(@_) if scalar @_; + return undef unless defined wantarray; + return _decode_lat( $self->{longitude} ) unless wantarray; + my @long = map { s/N/E/; s/S/W/; $_ } _decode_lat( $self->{longitude} ); +} + + +sub altitude { + my $self = shift; + $self->{altitude} = _encode_alt(shift) if scalar @_; + _decode_alt( $self->{altitude} ) if defined wantarray; +} + + +sub size { + my $self = shift; + $self->{size} = _encode_prec(shift) if scalar @_; + _decode_prec( $self->{size} ) if defined wantarray; +} + + +sub hp { + my $self = shift; + $self->{hp} = _encode_prec(shift) if scalar @_; + _decode_prec( $self->{hp} ) if defined wantarray; +} + +sub horiz_pre { &hp; } # uncoverable pod + + +sub vp { + my $self = shift; + $self->{vp} = _encode_prec(shift) if scalar @_; + _decode_prec( $self->{vp} ) if defined wantarray; +} + +sub vert_pre { &vp; } # uncoverable pod + + +sub latlon { + my $self = shift; + my ( $lat, @lon ) = @_; + my @pair = scalar $self->latitude(@_), scalar $self->longitude(@lon); +} + + +sub version { + shift->{version}; +} + + +######################################## + +no integer; + +use constant ALTITUDE0 => 10000000; +use constant LATITUDE0 => 0x80000000; + +sub _decode_lat { + my $msec = shift || LATITUDE0; + return int( 0.5 + ( $msec - LATITUDE0 ) / 0.36 ) / 10000000 unless wantarray; + use integer; + my $abs = abs( $msec - LATITUDE0 ); + my $deg = int( $abs / 3600000 ); + my $min = int( $abs / 60000 ) % 60; + no integer; + my $sec = ( $abs % 60000 ) / 1000; + return ( $deg, $min, $sec, ( $msec < LATITUDE0 ? 'S' : 'N' ) ); +} + + +sub _encode_lat { + my @ang = scalar @_ > 1 ? (@_) : ( split /[\s\260'"]+/, shift ); + 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 ? LATITUDE0 - $ang : LATITUDE0 + $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]$//; + foreach my $exponent ( 0 .. 9 ) { + next unless $argument < $power10[1 + $exponent]; + my $mantissa = int( 0.5 + $argument / $power10[$exponent] ); + return ( $mantissa & 0xF ) << 4 | $exponent; + } +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1876 + +=cut diff --git a/lib/lib/Net/DNS/RR/LP.pm b/lib/lib/Net/DNS/RR/LP.pm new file mode 100644 index 0000000..2ccefd1 --- /dev/null +++ b/lib/lib/Net/DNS/RR/LP.pm @@ -0,0 +1,173 @@ +package Net::DNS::RR::LP; + +# +# $Id: LP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{target} = decode Net::DNS::DomainName( $data, $offset + 2 ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $target = $self->{target}; + pack 'n a*', $self->preference, $target->encode(); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $target = $self->{target}; + join ' ', $self->preference, $target->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->target(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{target}->name if $self->{target}; +} + + +sub FQDN { shift->{target}->fqdn; } +sub fqdn { shift->{target}->fqdn; } + + +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 = new Net::DNS::RR('name IN LP preference FQDN'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'LP', + preference => 10, + target => 'target.example.com.' + ); + +=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 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 +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, RFC6742 + +=cut diff --git a/lib/lib/Net/DNS/RR/MB.pm b/lib/lib/Net/DNS/RR/MB.pm new file mode 100644 index 0000000..d496f46 --- /dev/null +++ b/lib/lib/Net/DNS/RR/MB.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::MB; + +# +# $Id: MB.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +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 = shift; + + $self->{madname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $madname = $self->{madname} || return ''; + $madname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $madname = $self->{madname} || return ''; + $madname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->madname(shift); +} + + +sub madname { + my $self = shift; + + $self->{madname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{madname}->name if $self->{madname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1035 Section 3.3.3 + +=cut diff --git a/lib/lib/Net/DNS/RR/MG.pm b/lib/lib/Net/DNS/RR/MG.pm new file mode 100644 index 0000000..321be8a --- /dev/null +++ b/lib/lib/Net/DNS/RR/MG.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::MG; + +# +# $Id: MG.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +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 = shift; + + $self->{mgmname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $mgmname = $self->{mgmname} || return ''; + $mgmname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $mgmname = $self->{mgmname} || return ''; + $mgmname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->mgmname(shift); +} + + +sub mgmname { + my $self = shift; + + $self->{mgmname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{mgmname}->name if $self->{mgmname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1035 Section 3.3.6 + +=cut diff --git a/lib/lib/Net/DNS/RR/MINFO.pm b/lib/lib/Net/DNS/RR/MINFO.pm new file mode 100644 index 0000000..c4095fe --- /dev/null +++ b/lib/lib/Net/DNS/RR/MINFO.pm @@ -0,0 +1,155 @@ +package Net::DNS::RR::MINFO; + +# +# $Id: MINFO.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + ( $self->{rmailbx}, $offset ) = decode Net::DNS::Mailbox1035(@_); + ( $self->{emailbx}, $offset ) = decode Net::DNS::Mailbox1035( $data, $offset, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $rdata = $self->{rmailbx}->encode(@_); + $rdata .= $self->{emailbx}->encode( $offset + length $rdata, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( $self->{rmailbx}->string, $self->{emailbx}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->rmailbx(shift); + $self->emailbx(shift); +} + + +sub rmailbx { + my $self = shift; + + $self->{rmailbx} = new Net::DNS::Mailbox1035(shift) if scalar @_; + $self->{rmailbx}->address if $self->{rmailbx}; +} + + +sub emailbx { + my $self = shift; + + $self->{emailbx} = new Net::DNS::Mailbox1035(shift) if scalar @_; + $self->{emailbx}->address if $self->{emailbx}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new 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 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 +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, RFC1035 Section 3.3.7 + +=cut diff --git a/lib/lib/Net/DNS/RR/MR.pm b/lib/lib/Net/DNS/RR/MR.pm new file mode 100644 index 0000000..4537801 --- /dev/null +++ b/lib/lib/Net/DNS/RR/MR.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::MR; + +# +# $Id: MR.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +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 = shift; + + $self->{newname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $newname = $self->{newname} || return ''; + $newname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $newname = $self->{newname} || return ''; + $newname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->newname(shift); +} + + +sub newname { + my $self = shift; + + $self->{newname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{newname}->name if $self->{newname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new 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 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 +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, RFC1035 Section 3.3.8 + +=cut diff --git a/lib/lib/Net/DNS/RR/MX.pm b/lib/lib/Net/DNS/RR/MX.pm new file mode 100644 index 0000000..39f839f --- /dev/null +++ b/lib/lib/Net/DNS/RR/MX.pm @@ -0,0 +1,166 @@ +package Net::DNS::RR::MX; + +# +# $Id: MX.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{exchange} = decode Net::DNS::DomainName1035( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $exchange = $self->{exchange}; + 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}; + join ' ', $self->preference, $exchange->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->exchange(shift); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->preference(10); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub exchange { + my $self = shift; + + $self->{exchange} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{exchange}->name if $self->{exchange}; +} + + +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 = new Net::DNS::RR('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 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 +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, RFC1035 Section 3.3.9 + +=cut diff --git a/lib/lib/Net/DNS/RR/NAPTR.pm b/lib/lib/Net/DNS/RR/NAPTR.pm new file mode 100644 index 0000000..1f5fae1 --- /dev/null +++ b/lib/lib/Net/DNS/RR/NAPTR.pm @@ -0,0 +1,236 @@ +package Net::DNS::RR::NAPTR; + +# +# $Id: NAPTR.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + @{$self}{qw(order preference)} = unpack "\@$offset n2", $$data; + ( $self->{flags}, $offset ) = decode Net::DNS::Text( $data, $offset + 4 ); + ( $self->{service}, $offset ) = decode Net::DNS::Text( $data, $offset ); + ( $self->{regexp}, $offset ) = decode Net::DNS::Text( $data, $offset ); + $self->{replacement} = decode Net::DNS::DomainName2535( $data, $offset, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $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 ); +} + + +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)} ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach (qw(order preference flags service regexp replacement)) { $self->$_(shift) } +} + + +sub order { + my $self = shift; + + $self->{order} = 0 + shift if scalar @_; + $self->{order} || 0; +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub flags { + my $self = shift; + + $self->{flags} = new Net::DNS::Text(shift) if scalar @_; + $self->{flags}->value if $self->{flags}; +} + + +sub service { + my $self = shift; + + $self->{service} = new Net::DNS::Text(shift) if scalar @_; + $self->{service}->value if $self->{service}; +} + + +sub regexp { + my $self = shift; + + $self->{regexp} = new Net::DNS::Text(shift) if scalar @_; + $self->{regexp}->value if $self->{regexp}; +} + + +sub replacement { + my $self = shift; + + $self->{replacement} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{replacement}->name if $self->{replacement}; +} + + +my $function = sub { + my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); + $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 = new Net::DNS::RR('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 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 +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, RFC2915, RFC2168, RFC3403 + +=cut diff --git a/lib/lib/Net/DNS/RR/NID.pm b/lib/lib/Net/DNS/RR/NID.pm new file mode 100644 index 0000000..7c438f2 --- /dev/null +++ b/lib/lib/Net/DNS/RR/NID.pm @@ -0,0 +1,165 @@ +package Net::DNS::RR::NID; + +# +# $Id: NID.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + @{$self}{qw(preference nodeid)} = unpack "\@$offset n a8", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'n a8', $self->{preference}, $self->{nodeid}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->nodeid; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->nodeid(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub nodeid { + my $self = shift; + my $idnt = shift; + + $self->{nodeid} = pack 'n4', map hex($_), split /:/, $idnt if defined $idnt; + + sprintf '%0.4x:%0.4x:%0.4x:%0.4x', unpack 'n4', $self->{nodeid} if $self->{nodeid}; +} + + +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 = new Net::DNS::RR('name IN NID preference nodeid'); + + $rr = new Net::DNS::RR( + name => 'example.com', + type => 'NID', + preference => 10, + nodeid => '8:800:200C:417A' + ); + +=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 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 +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, RFC6742 + +=cut diff --git a/lib/lib/Net/DNS/RR/NS.pm b/lib/lib/Net/DNS/RR/NS.pm new file mode 100644 index 0000000..b97740e --- /dev/null +++ b/lib/lib/Net/DNS/RR/NS.pm @@ -0,0 +1,133 @@ +package Net::DNS::RR::NS; + +# +# $Id: NS.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + + $self->{nsdname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $nsdname = $self->{nsdname}; + $nsdname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $nsdname = $self->{nsdname}; + $nsdname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->nsdname(shift); +} + + +sub nsdname { + my $self = shift; + + $self->{nsdname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{nsdname}->name if $self->{nsdname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name NS nsdname'); + + $rr = new Net::DNS::RR( + 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 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 +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, RFC1035 Section 3.3.11 + +=cut diff --git a/lib/lib/Net/DNS/RR/NSEC.pm b/lib/lib/Net/DNS/RR/NSEC.pm new file mode 100644 index 0000000..fb390f9 --- /dev/null +++ b/lib/lib/Net/DNS/RR/NSEC.pm @@ -0,0 +1,273 @@ +package Net::DNS::RR::NSEC; + +# +# $Id: NSEC.pm 1696 2018-07-20 16:15:11Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1696 $)[1]; + + +use strict; +use warnings; +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; + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + ( $self->{nxtdname}, $offset ) = decode Net::DNS::DomainName(@_); + $self->{typebm} = substr $$data, $offset, $limit - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $nxtdname = $self->{nxtdname}; + join '', $nxtdname->encode(), $self->{typebm}; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $nxtdname = $self->{nxtdname}; + my @rdata = ( $nxtdname->string(), $self->typelist ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->nxtdname(shift); + $self->typelist(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->_parse_rdata('.'); +} + + +sub nxtdname { + my $self = shift; + + $self->{nxtdname} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{nxtdname}->name if $self->{nxtdname}; +} + + +sub typelist { + my $self = shift; + + if ( scalar(@_) || !defined(wantarray) ) { + $self->{typebm} = &_type2bm; + return; + } + + my @type = &_bm2type( $self->{typebm} ); + return wantarray ? (@type) : "@type"; +} + + +sub typemap { + my $self = shift; + + my $number = typebyname(shift); + 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 covers { + my $self = shift; + my $name = join chr(0), reverse Net::DNS::DomainName->new(shift)->_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 _type2bm { + my @typearray; + foreach my $typename ( map split(), @_ ) { + 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 @typelist; + my $bitmap = shift || return @typelist; + + my $index = 0; + my $limit = length $bitmap; + + 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 = shift; # uncoverable pod + $self->{typebm} = shift if scalar @_; + return $self->{typebm}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR( '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 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. + + +=head1 COPYRIGHT + +Copyright (c)2001-2005 RIPE NCC. Author Olaf M. Kolkman + +Portions Copyright (c)2018 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 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 +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, RFC4034, RFC3755 + +=cut diff --git a/lib/lib/Net/DNS/RR/NSEC3.pm b/lib/lib/Net/DNS/RR/NSEC3.pm new file mode 100644 index 0000000..80efe66 --- /dev/null +++ b/lib/lib/Net/DNS/RR/NSEC3.pm @@ -0,0 +1,498 @@ +package Net::DNS::RR::NSEC3; + +# +# $Id: NSEC3.pm 1694 2018-07-16 04:19:40Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1694 $)[1]; + + +use strict; +use warnings; +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 + +my %digest = ( + '1' => ['Digest::SHA', 1], # RFC3658 + ); + +{ + my @digestbyname = ( + 'SHA-1' => 1, # RFC3658 + ); + + my @digestalias = ( 'SHA' => 1 ); + + my %digestbyval = reverse @digestbyname; + + my @digestrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; uc($_) }, @digestbyname; + my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl + + sub _digestbyname { + my $name = shift; + my $key = uc $name; # synthetic key + $key =~ s /[\W_]//g; # strip non-alphanumerics + $digestbyname{$key} || croak "unknown digest type $name"; + } + + sub _digestbyval { + my $value = shift; + $digestbyval{$value} || return $value; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + my $ssize = unpack "\@$offset x4 C", $$data; + @{$self}{qw(algorithm flags iterations saltbin)} = unpack "\@$offset CCnx a$ssize", $$data; + $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( @{$self}{qw(algorithm iterations saltbin)} ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $salt = $self->saltbin; + my $hash = $self->{hnxtname}; + 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 + ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->algorithm(shift); + $self->flags(shift); + $self->iterations(shift); + my $salt = shift; + $self->salt($salt) unless $salt eq '-'; + $self->hnxtname(shift); + $self->typelist(@_); + $self->{hashfn} = _hashfn( @{$self}{qw(algorithm iterations saltbin)} ); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->_parse_rdata( 1, 0, 0, '' ); +} + + +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 = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub optout { + my $bit = 0x01; + for ( shift->{flags} ) { + my $set = $bit | ( $_ ||= 0 ); + $_ = (shift) ? $set : ( $set ^ $bit ) if scalar @_; + return $_ & $bit; + } +} + + +sub iterations { + my $self = shift; + + $self->{iterations} = 0 + shift if scalar @_; + $self->{iterations} || 0; +} + + +sub salt { + my $self = shift; + return unpack "H*", $self->saltbin() unless scalar @_; + $self->saltbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub saltbin { + my $self = shift; + + $self->{saltbin} = shift if scalar @_; + $self->{saltbin} || ""; +} + + +sub hnxtname { + my $self = shift; + $self->{hnxtname} = _decode_base32hex(shift) if scalar @_; + _encode_base32hex( $self->{hnxtname} ) if defined wantarray; +} + + +sub covers { + my ( $self, $name ) = @_; + + my ( $owner, @zone ) = $self->{owner}->_wire; + my $ownerhash = _decode_base32hex($owner); + my $nexthash = $self->{hnxtname}; + + my @label = new Net::DNS::DomainName($name)->_wire; + 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 covered { ## historical + &covers; # uncoverable pod +} + +sub match { ## historical + my ( $self, $name ) = @_; # uncoverable pod + + my ($owner) = $self->{owner}->_wire; + my $ownerhash = _decode_base32hex($owner); + + my $hashfn = $self->{hashfn}; + $ownerhash eq &$hashfn($name); +} + + +sub encloser { + my ( $self, $qname ) = @_; + + my ( $owner, @zone ) = $self->{owner}->_wire; + my $ownerhash = _decode_base32hex($owner); + my $nexthash = $self->{hnxtname}; + + my @label = new Net::DNS::DomainName($qname)->_wire; + 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; + shift @label; + foreach (@close) { + my $nextcloser = $encloser; + my $hash = &$hashfn( $encloser = join '.', @label ); + shift @label; + next if $hash ne $ownerhash; + $self->{nextcloser} = $nextcloser; # next closer name + $self->{wildcard} = join '.', '*', $encloser; # wildcard at provable encloser + return $encloser; # provable encloser + } + return; +} + + +sub nextcloser { return shift->{nextcloser}; } + +sub wildcard { return shift->{wildcard}; } + + +######################################## + +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; + 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 $key_adjunct = pack 'Cna*', $hashalg, $iterations, $salt; + $iterations++; + + my $instance = eval { + my $arglist = $digest{$hashalg}; + my ( $class, @argument ) = @$arglist; + $class->new(@argument); + }; + my $exception = $@; + + return $exception ? sub { croak $exception } : sub { + my $name = new Net::DNS::DomainName(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 + + my $hash = $name; + my $iter = $iterations; + $instance->reset; + while ( $iter-- ) { + $instance->add($hash); + $instance->add($salt); + $hash = $instance->digest; + } + return $$cache1{$key} = $hash; + }; +} + + +sub hashalgo { &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 ); + _encode_base32hex( &$hash($name) ); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 Hash Algorithm field is represented as an unsigned decimal +integer. The value has a maximum of 255. + +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 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 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 +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, RFC5155, RFC4648 + +L + +=cut diff --git a/lib/lib/Net/DNS/RR/NSEC3PARAM.pm b/lib/lib/Net/DNS/RR/NSEC3PARAM.pm new file mode 100644 index 0000000..bc62548 --- /dev/null +++ b/lib/lib/Net/DNS/RR/NSEC3PARAM.pm @@ -0,0 +1,209 @@ +package Net::DNS::RR::NSEC3PARAM; + +# +# $Id: NSEC3PARAM.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $size = unpack "\@$offset x4 C", $$data; + @{$self}{qw(algorithm flags iterations saltbin)} = unpack "\@$offset CCnx a$size", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $salt = $self->saltbin; + pack 'CCnCa*', @{$self}{qw(algorithm flags iterations)}, length($salt), $salt; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->algorithm, $self->flags, $self->iterations, $self->salt || '-'; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->algorithm(shift); + $self->flags(shift); + $self->iterations(shift); + my $salt = shift; + $self->salt($salt) unless $salt eq '-'; +} + + +sub algorithm { + my $self = shift; + + $self->{algorithm} = 0 + shift if scalar @_; + $self->{algorithm} || 0; +} + + +sub flags { + my $self = shift; + + $self->{flags} = 0 + shift if scalar @_; + $self->{flags} || 0; +} + + +sub iterations { + my $self = shift; + + $self->{iterations} = 0 + shift if scalar @_; + $self->{iterations} || 0; +} + + +sub salt { + my $self = shift; + return unpack "H*", $self->saltbin() unless scalar @_; + $self->saltbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub saltbin { + my $self = shift; + + $self->{saltbin} = shift if scalar @_; + $self->{saltbin} || ""; +} + + +######################################## + +sub hashalgo { &algorithm; } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 Hash Algorithm field is represented as an unsigned decimal +integer. The value has a maximum of 255. + +=head2 flags + + $flags = $rr->flags; + $rr->flags( $flags ); + +The Flags field is represented as an unsigned decimal integer. +The value has a maximum of 255. + +=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 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 +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, RFC5155 + +=cut diff --git a/lib/lib/Net/DNS/RR/NULL.pm b/lib/lib/Net/DNS/RR/NULL.pm new file mode 100644 index 0000000..3532ef0 --- /dev/null +++ b/lib/lib/Net/DNS/RR/NULL.pm @@ -0,0 +1,89 @@ +package Net::DNS::RR::NULL; + +# +# $Id: NULL.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +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 = new Net::DNS::RR('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 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 +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, RFC1035 Section 3.3.10 + +=cut diff --git a/lib/lib/Net/DNS/RR/OPENPGPKEY.pm b/lib/lib/Net/DNS/RR/OPENPGPKEY.pm new file mode 100644 index 0000000..e4741bf --- /dev/null +++ b/lib/lib/Net/DNS/RR/OPENPGPKEY.pm @@ -0,0 +1,141 @@ +package Net::DNS::RR::OPENPGPKEY; + +# +# $Id: OPENPGPKEY.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $length = $self->{rdlength}; + $self->keybin( substr $$data, $offset, $length ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + pack 'a*', $self->keybin; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @base64 = split /\s+/, encode_base64( $self->keybin ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->key(@_); +} + + +sub key { + my $self = shift; + return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @_; + $self->keybin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub keybin { + my $self = shift; + + $self->{keybin} = shift if scalar @_; + $self->{keybin} || ""; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC7929 + +=cut diff --git a/lib/lib/Net/DNS/RR/OPT.pm b/lib/lib/Net/DNS/RR/OPT.pm new file mode 100644 index 0000000..ca9cc59 --- /dev/null +++ b/lib/lib/Net/DNS/RR/OPT.pm @@ -0,0 +1,527 @@ +package Net::DNS::RR::OPT; + +# +# $Id: OPT.pm 1717 2018-10-12 13:14:42Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1717 $)[1]; + + +use strict; +use warnings; +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; + +use constant CLASS_TTL_RDLENGTH => length pack 'n N n', (0) x 3; + +use constant OPT => typebyname qw(OPT); + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $index = $offset - CLASS_TTL_RDLENGTH; # OPT redefines class and TTL fields + @{$self}{qw(size rcode version flags)} = unpack "\@$index n C2 n", $$data; + @{$self}{rcode} = @{$self}{rcode} << 4; + delete @{$self}{qw(class 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; + $self->{option}{$code} = $value; + $offset += $length + 4; + } +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $option = $self->{option} || {}; + join '', map pack( 'nna*', $_, length $option->{$_}, $option->{$_} ), keys %$option; +} + + +sub encode { ## overide RR method + my $self = shift; + + my $data = $self->_encode_rdata; + my $size = $self->size; + my @xttl = ( $self->rcode >> 4, $self->version, $self->flags ); + pack 'C n n C2n n a*', 0, OPT, $size, @xttl, length($data), $data; +} + + +sub string { ## overide RR method + my $self = shift; + + my $edns = $self->version; + my $flags = sprintf '%04x', $self->flags; + my $rcode = $self->rcode; + my $size = $self->size; + my @option = map join( "\n;;\t\t\t\t", $self->_format_option($_) ), $self->options; + my @format = join "\n;;\t\t", @option; + + $rcode = 0 if $rcode < 16; # weird: 1 .. 15 not EDNS codes!! + + my $rc = exists( $self->{rdlength} ) && $rcode ? "$rcode + [4-bits]" : rcodebyval($rcode); + + $rc = 'BADVERS' if $rcode == 16; # code 16 unambiguous here + + return <<"QQ"; +;; EDNS version $edns +;; flags: $flags +;; rcode: $rc +;; size: $size +;; option: @format +QQ +} + + +my ( $class, $ttl ); + +sub class { ## overide RR method + carp qq[Usage: OPT has no "class" attribute, please use "size()"] unless $class++; + &size; +} + +sub ttl { ## overide RR method + my $self = shift; + carp qq[Usage: OPT has no "ttl" attribute, please use "flags()" or "rcode()"] unless $ttl++; + my @rcode = map unpack( 'C', pack 'N', $_ ), @_; + my @flags = map unpack( 'x2n', pack 'N', $_ ), @_; + pack 'C2n', $self->rcode(@rcode), $self->version, $self->flags(@flags); +} + + +sub version { + my $version = shift->{version}; + return defined($version) ? $version : 0; +} + + +sub size { + my $self = shift; + for ( $self->{size} ) { + my $UDP_size = 0; + ( $UDP_size, $_ ) = ( shift || 0 ) if scalar @_; + return $UDP_size < 512 ? 512 : ( $_ = $UDP_size ) unless $_; + return $_ > 512 ? $_ : 512; + } +} + + +sub rcode { + my $self = shift; + return $self->{rcode} || 0 unless scalar @_; + delete $self->{rdlength}; # (ab)used to signal incomplete value + my $val = shift || 0; + $self->{rcode} = $val < 16 ? 0 : $val; # discard non-EDNS rcodes 1 .. 15 +} + + +sub flags { + my $self = shift; + return $self->{flags} || 0 unless scalar @_; + $self->{flags} = shift; +} + + +sub options { + my ($self) = @_; + my $options = $self->{option} || {}; + my @options = sort { $a <=> $b } keys %$options; +} + +sub option { + my $self = shift; + my $number = ednsoptionbyname(shift); + return $self->_get_option($number) unless scalar @_; + $self->_set_option( $number, @_ ); +} + + +sub _format_option { + my ( $self, $number ) = @_; + my $option = ednsoptionbyval($number); + my $options = $self->{option} || {}; + my $payload = $options->{$number}; + return () unless defined $payload; + my $package = join '::', __PACKAGE__, $option; + $package =~ s/-/_/g; + my $defined = length($payload) && $package->can('_image'); + my @element = $defined ? eval { $package->_image($payload) } : unpack 'H*', $payload; + my $protect = pop(@element); + Net::DNS::RR::_wrap( "$option\t=> (", map( "$_,", @element ), $protect, ')' ); +} + + +sub _get_option { + my ( $self, $number ) = @_; + + my $options = $self->{option} || {}; + my $payload = $options->{$number}; + return $payload unless wantarray; + return () unless $payload; + my $package = join '::', __PACKAGE__, ednsoptionbyval($number); + $package =~ s/-/_/g; + return ( 'OPTION-DATA' => $payload ) unless $package->can('_decompose'); + my @payload = eval { $package->_decompose($payload) }; +} + + +sub _set_option { + my ( $self, $number, $value, @etc ) = @_; + + my $options = $self->{option} ||= {}; + delete $options->{$number}; + return unless defined $value; + if ( ref($value) || scalar(@etc) ) { + my $option = ednsoptionbyval($number); + my @arg = ( $value, @etc ); + @arg = @$value if ref($value) eq 'ARRAY'; + @arg = %$value if ref($value) eq 'HASH'; + if ( $arg[0] eq 'OPTION-DATA' ) { + $value = $arg[1]; + } else { + my $package = join '::', __PACKAGE__, $option; + $package =~ s/-/_/g; + croak "unable to compose option $option" unless $package->can('_compose'); + $value = $package->_compose(@arg); + } + } + $options->{$number} = $value; +} + + +sub _specified { + my $self = shift; + my @spec = grep $self->{$_}, qw(size flags rcode option); + scalar @spec; +} + + +######################################## + +package Net::DNS::RR::OPT::DAU; # RFC6975 + +sub _compose { + my ( $class, @argument ) = @_; + pack 'C*', @argument; +} + +sub _decompose { + my @payload = unpack 'C*', $_[1]; +} + +sub _image { &_decompose; } + + +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 +use Net::DNS::RR::A; +use Net::DNS::RR::AAAA; + +my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA); +my @field = qw(FAMILY SOURCE-PREFIX-LENGTH SCOPE-PREFIX-LENGTH ADDRESS); + +sub _compose { + my ( $class, %argument ) = @_; + my $address = bless( {}, $family{$argument{FAMILY}} )->address( $argument{ADDRESS} ); + my $preamble = pack 'nC2', map $_ ||= 0, @argument{@field}; + my $bitmask = $argument{'SOURCE-PREFIX-LENGTH'}; + pack "a* B$bitmask", $preamble, unpack 'B*', $address; +} + +sub _decompose { + my %hash; + @hash{@field} = unpack 'nC2a*', $_[1]; + $hash{ADDRESS} = bless( {address => $hash{ADDRESS}}, $family{$hash{FAMILY}} )->address; + my @payload = map { ( $_ => $hash{$_} ) } @field; +} + +sub _image { + my %hash = &_decompose; + my @image = map "$_ => $hash{$_}", @field; +} + + +package Net::DNS::RR::OPT::EXPIRE; # RFC7314 + +sub _compose { + my ( $class, %argument ) = @_; + pack 'N', values %argument; +} + +sub _decompose { + my @payload = ( 'EXPIRE-TIMER' => unpack 'N', $_[1] ); +} + +sub _image { join ' => ', &_decompose; } + + +package Net::DNS::RR::OPT::COOKIE; # RFC7873 + +my @key = qw(CLIENT-COOKIE SERVER-COOKIE); + +sub _compose { + my ( $class, %argument ) = @_; + pack 'a8 a*', map $_ || '', @argument{@key}; +} + +sub _decompose { + my %hash; + @hash{@key} = unpack 'a8 a*', $_[1]; + my @payload = map { ( $_ => $hash{$_} ) } @key; +} + +sub _image { + my %hash = &_decompose; + my @image = map join( ' => ', $_, unpack 'H*', $hash{$_} ), @key; +} + + +package Net::DNS::RR::OPT::TCP_KEEPALIVE; # RFC7828 + +sub _compose { + my ( $class, %argument ) = @_; + pack 'n', values %argument; +} + +sub _decompose { + my @payload = ( 'TIMEOUT' => unpack 'n', $_[1] ); +} + +sub _image { join ' => ', &_decompose; } + + +package Net::DNS::RR::OPT::PADDING; # RFC7830 + +sub _compose { + my ( $class, %argument ) = @_; + my ($size) = values %argument; + pack "x$size"; +} + +sub _decompose { + my @payload = ( 'OPTION-LENGTH' => length( $_[1] ) ); +} + +sub _image { join ' => ', &_decompose; } + + +package Net::DNS::RR::OPT::CHAIN; # RFC7901 +use Net::DNS::DomainName; + +sub _compose { + my ( $class, %argument ) = @_; + my ($trust_point) = values %argument; + Net::DNS::DomainName->new($trust_point)->encode; +} + +sub _decompose { + my ( $class, $payload ) = @_; + my $fqdn = Net::DNS::DomainName->decode( \$payload )->string; + my @payload = ( 'CLOSEST-TRUST-POINT' => $fqdn ); +} + +sub _image { join ' => ', &_decompose; } + + +package Net::DNS::RR::OPT::KEY_TAG; # RFC8145 + +sub _compose { + my ( $class, @argument ) = @_; + pack 'n*', @argument; +} + +sub _decompose { + my @payload = unpack 'n*', $_[1]; +} + +sub _image { &_decompose; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $packet = new Net::DNS::Packet( ... ); + + $packet->header->do(1); # extended flag + + $packet->edns->size(1280); # UDP payload size + + $packet->edns->option( COOKIE => $cookie ); + + $packet->edns->print; + + ;; EDNS version 0 + ;; flags: 8000 + ;; rcode: NOERROR + ;; size: 1280 + ;; option: DAU => ( 8, 10, 13, 14, 15, 16 ) + ;; DHU => ( 1, 2, 4 ) + ;; COOKIE => ( CLIENT-COOKIE => 7261776279746573, + ;; SERVER-COOKIE => ) + + +=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 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 = $rr->version; + +The version of EDNS used by this OPT record. + +=head2 size + + $size = $packet->edns->size; + $more = $packet->edns->size(1280); + +size() 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; + $incomplete_rcode = $packet->edns->rcode; + +The 12 bit extended RCODE. The most significant 8 bits reside in the OPT +record. The least significant 4 bits can only be obtained from the packet +header. + +=head2 flags + + $edns_flags = $packet->edns->flags; + + $do = $packet->header->do; + $packet->header->do(1); + +16 bit field containing EDNS extended header flags. + +=head2 options, option + + @option = $packet->edns->options; + + $octets = $packet->edns->option($option_code); + + $packet->edns->option( COOKIE => $cookie ); + $packet->edns->option( 10 => $cookie ); + +When called in a list context, options() returns a list of option codes +found in the OPT record. + +When called in a scalar context with a single argument, +option() returns the uninterpreted octet string +corresponding to the specified option. +The method returns undef if the specified option is absent. + +Options can be added or replaced by providing the (name => string) pair. +The option is deleted if the value is undefined. + + +When option() is called in a list context with a single argument, +the returned array provides a structured interpretation +appropriate to the specified option. + +For the example above: + + %hash = $packet->edns->option(10); + + %hash = ( + 'CLIENT-COOKIE' => 'rawbytes', + 'SERVER-COOKIE' => '' + ); + + +For some options, an array is more appropriate: + + @algorithms = $packet->edns->option(6); + + +Similar forms of array syntax may be used to construct the option value: + + $packet->edns->option( DHU => [1, 2, 4] ); + $packet->edns->option( 6 => (1, 2, 4) ); + + $packet->edns->option( COOKIE => {'CLIENT-COOKIE' => $cookie} ); + $packet->edns->option( 10 => ('CLIENT-COOKIE' => $cookie) ); + + +=head1 COPYRIGHT + +Copyright (c)2001,2002 RIPE NCC. Author Olaf M. Kolkman. + +Portions Copyright (c)2012,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 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 +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, RFC6891, RFC3225 + +=cut diff --git a/lib/lib/Net/DNS/RR/PTR.pm b/lib/lib/Net/DNS/RR/PTR.pm new file mode 100644 index 0000000..3bd4a5d --- /dev/null +++ b/lib/lib/Net/DNS/RR/PTR.pm @@ -0,0 +1,127 @@ +package Net::DNS::RR::PTR; + +# +# $Id: PTR.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + + $self->{ptrdname} = decode Net::DNS::DomainName1035(@_); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $ptrdname = $self->{ptrdname}; + $ptrdname->encode(@_); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $ptrdname = $self->{ptrdname}; + $ptrdname->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->ptrdname(shift); +} + + +sub ptrdname { + my $self = shift; + + $self->{ptrdname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{ptrdname}->name if $self->{ptrdname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1035 Section 3.3.12 + +=cut diff --git a/lib/lib/Net/DNS/RR/PX.pm b/lib/lib/Net/DNS/RR/PX.pm new file mode 100644 index 0000000..3ecfef8 --- /dev/null +++ b/lib/lib/Net/DNS/RR/PX.pm @@ -0,0 +1,177 @@ +package Net::DNS::RR::PX; + +# +# $Id: PX.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + ( $self->{map822}, $offset ) = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); + ( $self->{mapx400}, $offset ) = decode Net::DNS::DomainName2535( $data, $offset + 0, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $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 ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( $self->preference, $self->{map822}->string, $self->{mapx400}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->map822(shift); + $self->mapx400(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub map822 { + my $self = shift; + + $self->{map822} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{map822}->name if $self->{map822}; +} + + +sub mapx400 { + my $self = shift; + + $self->{mapx400} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{mapx400}->name if $self->{mapx400}; +} + + +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 = new Net::DNS::RR('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 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 +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, RFC2163 + +=cut diff --git a/lib/lib/Net/DNS/RR/RP.pm b/lib/lib/Net/DNS/RR/RP.pm new file mode 100644 index 0000000..8fd949b --- /dev/null +++ b/lib/lib/Net/DNS/RR/RP.pm @@ -0,0 +1,154 @@ +package Net::DNS::RR::RP; + +# +# $Id: RP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + ( $self->{mbox}, $offset ) = decode Net::DNS::Mailbox2535( $data, $offset, @opaque ); + $self->{txtdname} = decode Net::DNS::DomainName2535( $data, $offset, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $txtdname = $self->{txtdname}; + my $rdata = $self->{mbox}->encode( $offset, @opaque ); + $rdata .= $txtdname->encode( $offset + length($rdata), @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my @rdata = ( $self->{mbox}->string, $self->{txtdname}->string ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->mbox(shift); + $self->txtdname(shift); +} + + +sub mbox { + my $self = shift; + + $self->{mbox} = new Net::DNS::Mailbox2535(shift) if scalar @_; + $self->{mbox}->address if $self->{mbox}; +} + + +sub txtdname { + my $self = shift; + + $self->{txtdname} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{txtdname}->name if $self->{txtdname}; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1183 Section 2.2 + +=cut diff --git a/lib/lib/Net/DNS/RR/RRSIG.pm b/lib/lib/Net/DNS/RR/RRSIG.pm new file mode 100644 index 0000000..69fc912 --- /dev/null +++ b/lib/lib/Net/DNS/RR/RRSIG.pm @@ -0,0 +1,889 @@ +package Net::DNS::RR::RRSIG; + +# +# $Id: RRSIG.pm 1709 2018-09-07 08:03:09Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1709 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::RRSIG - DNS RRSIG resource record + +=cut + + +use integer; + +use Carp; +use MIME::Base64; +use Time::Local; + +use Net::DNS::Parameters; + +use constant DEBUG => 0; + +use constant UTIL => defined eval 'use Scalar::Util 1.25; 1;'; + +# IMPORTANT: Distros MUST NOT create dependencies on Net::DNS::SEC (Prohibited in many territories) +use constant PRIVATE => 'Net::DNS::SEC::Private'; +use constant DSA => 'Net::DNS::SEC::DSA'; +use constant RSA => 'Net::DNS::SEC::RSA'; +use constant ECDSA => 'Net::DNS::SEC::ECDSA'; +use constant EdDSA => 'Net::DNS::SEC::EdDSA'; +use constant ECCGOST => 'Net::DNS::SEC::ECCGOST'; + +use constant EXISTS => join '', qw(r e q u i r e); # Defeat static analysers and grep +use constant DNSSEC => defined( eval join ' ', EXISTS, PRIVATE ); + +my ($DSA) = grep { DNSSEC && defined( eval join ' ', EXISTS, $_ ) } DSA; +my ($RSA) = grep { DNSSEC && defined( eval join ' ', EXISTS, $_ ) } RSA; + +my ($ECDSA) = grep { DNSSEC && defined( eval join ' ', EXISTS, $_ ) } ECDSA; +my ($EdDSA) = grep { DNSSEC && defined( eval join ' ', EXISTS, $_ ) } EdDSA; +use constant GOST => defined( eval join ' ', EXISTS, 'Digest::GOST' ); +my ($ECCGOST) = grep { DNSSEC && GOST && defined( eval join ' ', EXISTS, $_ ) } ECCGOST; + +my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; + ( $self->{signame}, $offset ) = decode Net::DNS::DomainName( $data, $offset + 18 ); + $self->{sigbin} = substr $$data, $offset, $limit - $offset; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $signame = $self->{signame}; + 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+/, encode_base64( $self->sigbin ); + my @rdata = ( map( $self->$_, @field ), $signame->string, @sig64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach ( @field, qw(signame) ) { $self->$_(shift) } + $self->signature(@_); +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->sigval(30); +} + + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + 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] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; 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 "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +my %DNSSEC_verify = ( + 1 => $RSA, + 3 => $DSA, + 5 => $RSA, + 6 => $DSA, + 7 => $RSA, + 8 => $RSA, + 10 => $RSA, + 12 => $ECCGOST, + 13 => $ECDSA, + 14 => $ECDSA, + 15 => $EdDSA, + 16 => $EdDSA, + ); + +my %DNSSEC_sign = ( + %DNSSEC_verify, + 1 => 0, ## deprecated ## + 3 => 0, ## deprecated ## + 6 => 0, ## deprecated ## + 12 => 0, ## deprecated ## + ); + + +sub typecovered { + my $self = shift; + $self->{typecovered} = typebyname(shift) if scalar @_; + my $typecode = $self->{typecovered}; + typebyval($typecode) if defined wantarray && defined $typecode; +} + + +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 = shift; + + $self->{labels} = 0 + shift if scalar @_; + $self->{labels} || 0; +} + + +sub orgttl { + my $self = shift; + + $self->{orgttl} = 0 + shift if scalar @_; + $self->{orgttl} || 0; +} + + +sub sigexpiration { + my $self = shift; + $self->{sigexpiration} = _string2time(shift) if scalar @_; + my $time = $self->{sigexpiration}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub siginception { + my $self = shift; + $self->{siginception} = _string2time(shift) if scalar @_; + my $time = $self->{siginception}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub sigex { &sigexpiration; } ## historical + +sub sigin { &siginception; } ## historical + +sub sigval { + my $self = shift; + no integer; + ( $self->{sigval} ) = map int( 86400 * $_ ), @_; +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $self->{keytag} || 0; +} + + +sub signame { + my $self = shift; + + $self->{signame} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{signame}->name if $self->{signame}; +} + + +sub sig { + my $self = shift; + return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @_; + $self->sigbin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub sigbin { + my $self = shift; + + $self->{sigbin} = shift if scalar @_; + $self->{sigbin} || ""; +} + + +sub signature { &sig; } + + +sub create { + unless (DNSSEC) { + croak 'Net::DNS::SEC support not available'; + } 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; + my @ttl = grep $_->ttl != $ttl, @$rrsetref; + croak 'RRs in RRset do not have same TTL' if scalar @ttl; + + 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 = new Net::DNS::RR( + 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}; + + $self->_CreateSig( $self->_CreateSigData($rrsetref), $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. + + if (DNSSEC) { + 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 recurse for each key that matches algorithm and key-id + # and return when there is a successful verification. + # If not, we will continue so that we can survive key-id collision. + # The downside of this is that the error string only matches the + # last error. + + print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; + my @error; + my $i; + foreach my $keyrr (@$keyref) { + my $result = $self->verify( $rrsetref, $keyrr ); + return $result if $result; + my $error = $self->{vrfyerrstr}; + $i++; + push @error, "key $i: $error"; + print "key $i: $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; + } + + $self->_VerifySig( $self->_CreateSigData($rrsetref), $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; + $self->{vrfyerrstr}; +} + + +######################################## + +sub _ordered($$) { ## irreflexive 32-bit partial ordering + use integer; + my ( $a, $b ) = @_; + + return defined $b unless defined $a; # ( undef, any ) + return 0 unless defined $b; # ( any, undef ) + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + if ( $a < 0 ) { # translate $a<0 region + $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 + $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 + } + + return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 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; + croak 'undefined time' unless defined $arg; + 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; + croak 'undefined time' unless defined $arg; + 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; +} + + +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; + + croak 'SIG0 using RRSIG not permitted' unless ref($rrsetref); + + my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + 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 = shift; + + my $algorithm = $self->algorithm; + my $class = $DNSSEC_sign{$algorithm}; + + eval { + die "algorithm $algorithm not supported" unless $class; + $self->sigbin( $class->sign(@_) ); + } || croak "${@}signature generation failed"; + } +} + + +sub _VerifySig { + if (DNSSEC) { + my $self = shift; + + my $algorithm = $self->algorithm; + my $class = $DNSSEC_verify{$algorithm}; + + my $retval = eval { + die "algorithm $algorithm not supported" unless $class; + $class->verify( @_, $self->sigbin ); + }; + + unless ($retval) { + $self->{vrfyerrstr} = "${@}signature verification failed"; + print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; + return 0; + } + + # uncoverable branch true # bug in Net::DNS::SEC or dependencies + croak "unknown error in $class->verify" unless $retval == 1; + print "\nalgorithm $algorithm verification successful\n" if DEBUG; + return 1; + } +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name RRSIG typecovered algorithm labels + orgttl sigexpiration siginception + keytag signame signature'); + + use Net::DNS::SEC; + $sigrr = create Net::DNS::RR::RRSIG( \@rrset, $keypath, + sigex => 20181231010101 + sigin => 20181201010101 + ); + + $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 = create Net::DNS::RR::RRSIG( \@rrsetref, $keypath ); + + $sigrr = create Net::DNS::RR::RRSIG( \@rrsetref, $keypath, + sigex => 20181231010101 + sigin => 20181201010101 + ); + $sigrr->print; + + + # Alternatively use Net::DNS::SEC::Private + + $private = Net::DNS::SEC::Private->new($keypath); + + $sigrr= create Net::DNS::RR::RRSIG( \@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 => 20181231010101, # signature expiration + sigin => 20181201010101, # signature inception + sigval => 30, # validity window (days) + ttl => 3600 # TTL + +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 -f ksk rsa.example. + dnssec-keygen -a 10 -b 1024 rsa.example. + + dnssec-keygen -a 14 -f ksk ecdsa.example. + dnssec-keygen -a 14 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 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 +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, +RFC4034, RFC6840, RFC3755, +L, +L, +L, +L + +L + +L + +=cut diff --git a/lib/lib/Net/DNS/RR/RT.pm b/lib/lib/Net/DNS/RR/RT.pm new file mode 100644 index 0000000..d3e6e74 --- /dev/null +++ b/lib/lib/Net/DNS/RR/RT.pm @@ -0,0 +1,156 @@ +package Net::DNS::RR::RT; + +# +# $Id: RT.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + $self->{preference} = unpack( "\@$offset n", $$data ); + $self->{intermediate} = decode Net::DNS::DomainName2535( $data, $offset + 2, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + pack 'n a*', $self->preference, $self->{intermediate}->encode( $offset + 2, @opaque ); +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + join ' ', $self->preference, $self->{intermediate}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->preference(shift); + $self->intermediate(shift); +} + + +sub preference { + my $self = shift; + + $self->{preference} = 0 + shift if scalar @_; + $self->{preference} || 0; +} + + +sub intermediate { + my $self = shift; + + $self->{intermediate} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{intermediate}->name if $self->{intermediate}; +} + + +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 = new Net::DNS::RR('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 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 +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, RFC1183 Section 3.3 + +=cut diff --git a/lib/lib/Net/DNS/RR/SIG.pm b/lib/lib/Net/DNS/RR/SIG.pm new file mode 100644 index 0000000..1b97968 --- /dev/null +++ b/lib/lib/Net/DNS/RR/SIG.pm @@ -0,0 +1,822 @@ + +# pre-5.14.0 perl inadvertently destroys signal handlers +# http://rt.perl.org/rt3/Public/Bug/Display.html?id=76138 +# +BEGIN { ## capture %SIG before compilation + use constant RT_76138 => $] < 5.014; + @::SIG_BACKUP = %SIG if RT_76138; +} + +sub UNITCHECK { ## restore %SIG after compilation + %SIG = @::SIG_BACKUP if RT_76138; +} + + +package Net::DNS::RR::SIG; + +# +# $Id: SIG.pm 1709 2018-09-07 08:03:09Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1709 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::SIG - DNS SIG resource record + +=cut + + +use integer; + +use Carp; +use Time::Local; + +eval 'require MIME::Base64'; + +use Net::DNS::Parameters; + +use constant DEBUG => 0; + +use constant UTIL => defined eval 'use Scalar::Util 1.25; 1;'; + +# IMPORTANT: Distros MUST NOT create dependencies on Net::DNS::SEC (Prohibited in many territories) +use constant PRIVATE => 'Net::DNS::SEC::Private'; +use constant DSA => 'Net::DNS::SEC::DSA'; +use constant RSA => 'Net::DNS::SEC::RSA'; +use constant ECDSA => 'Net::DNS::SEC::ECDSA'; +use constant EdDSA => 'Net::DNS::SEC::EdDSA'; +use constant ECCGOST => 'Net::DNS::SEC::ECCGOST'; + +use constant EXISTS => join '', qw(r e q u i r e); # Defeat static analysers and grep +use constant DNSSEC => defined( eval join ' ', EXISTS, PRIVATE ); + +my ($DSA) = grep { DNSSEC && defined( eval join ' ', EXISTS, $_ ) } DSA; +my ($RSA) = grep { DNSSEC && defined( eval join ' ', EXISTS, $_ ) } RSA; + +my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset, @opaque ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{@field} = unpack "\@$offset n C2 N3 n", $$data; + ( $self->{signame}, $offset ) = decode Net::DNS::DomainName2535( $data, $offset + 18 ); + $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; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my ( $hash, $packet ) = @opaque; + + my $signame = $self->{signame}; + + if ( DNSSEC && !$self->{sigbin} ) { + my $private = delete $self->{private}; # one shot is all you get + my $sigdata = $self->_CreateSigData($packet); + $self->_CreateSig( $sigdata, $private || die 'missing key reference' ); + } + + pack 'n C2 N3 n a* a*', @{$self}{@field}, $signame->encode, $self->sigbin; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $signame = $self->{signame} || return ''; + my @sig64 = split /\s+/, MIME::Base64::encode( $self->sigbin ); + my @rdata = ( map( $self->$_, @field ), $signame->string, @sig64 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach ( @field, qw(signame) ) { $self->$_(shift) } + $self->signature(@_); +} + + +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); +} + + +# +# source: http://www.iana.org/assignments/dns-sec-alg-numbers +# +{ + 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] + + 'INDIRECT' => 252, # [RFC4034] + 'PRIVATEDNS' => 253, # [RFC4034] + 'PRIVATEOID' => 254, # [RFC4034] + ## Reserved => 255, # [RFC4034] + ); + + my %algbyval = reverse @algbyname; + + my @algrehash = map /^\d/ ? ($_) x 3 : do { s/[\W_]//g; 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 "unknown algorithm $arg"; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value} || return $value; + } +} + + +my %DNSSEC_sign = ( + 1 => $RSA, + 3 => $DSA, + 5 => $RSA, + 6 => $DSA, + 7 => $RSA, + 8 => $RSA, + 10 => $RSA, + ); + +my %DNSSEC_verify = %DNSSEC_sign; + +my %siglen = ( + 1 => 128, + 3 => 41, + 5 => 256, + 6 => 41, + 7 => 256, + 8 => 256, + 10 => 256, + ); + + +sub _size { ## estimate encoded size + my $self = shift; + my $clone = bless {%$self}, ref($self); # shallow clone + $clone->sigbin( 'x' x $siglen{$self->algorithm} ); + length $clone->encode(); +} + + +sub typecovered { + my $self = shift; # uncoverable pod + $self->{typecovered} = typebyname(shift) if scalar @_; + my $typecode = $self->{typecovered}; + typebyval($typecode) if defined wantarray && defined $typecode; +} + + +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 { + shift->{labels} = 0; # uncoverable pod +} + + +sub orgttl { + shift->{orgttl} = 0; # uncoverable pod +} + + +sub sigexpiration { + my $self = shift; + $self->{sigexpiration} = _string2time(shift) if scalar @_; + my $time = $self->{sigexpiration}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub siginception { + my $self = shift; + $self->{siginception} = _string2time(shift) if scalar @_; + my $time = $self->{siginception}; + return unless defined wantarray && defined $time; + return UTIL ? Scalar::Util::dualvar( $time, _time2string($time) ) : _time2string($time); +} + +sub sigex { &sigexpiration; } ## historical + +sub sigin { &siginception; } ## historical + +sub sigval { + my $self = shift; + no integer; + ( $self->{sigval} ) = map int( 60.0 * $_ ), @_; +} + + +sub keytag { + my $self = shift; + + $self->{keytag} = 0 + shift if scalar @_; + $self->{keytag} || 0; +} + + +sub signame { + my $self = shift; + + $self->{signame} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{signame}->name if $self->{signame}; +} + + +sub sig { + my $self = shift; + return MIME::Base64::encode( $self->sigbin(), "" ) unless scalar @_; + $self->sigbin( MIME::Base64::decode( join "", @_ ) ); +} + + +sub sigbin { + my $self = shift; + + $self->{sigbin} = shift if scalar @_; + $self->{sigbin} || ""; +} + + +sub signature { &sig; } + + +sub create { + unless (DNSSEC) { + croak 'Net::DNS::SEC support not available'; + } 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 = new Net::DNS::RR( + 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. + + if (DNSSEC) { + my ( $self, $dataref, $keyref ) = @_; + + if ( my $isa = ref($dataref) ) { + print '$dataref argument is ', $isa, "\n" if DEBUG; + croak '$dataref can not be ', $isa unless $isa =~ /^Net::DNS::/; + croak '$dataref can not be ', $isa unless $dataref->isa('Net::DNS::Packet'); + } + + print '$keyref argument is of class ', ref($keyref), "\n" if DEBUG; + if ( ref($keyref) eq "ARRAY" ) { + + # We will recurse for each key that matches algorithm and key-id + # and return when there is a successful verification. + # If not, we'll continue so that we even survive key-id collision. + # The downside of this is that the error string only matches the + # last error. + + print "Iterating over ", scalar(@$keyref), " keys\n" if DEBUG; + my @error; + my $i; + foreach my $keyrr (@$keyref) { + my $result = $self->verify( $dataref, $keyrr ); + return $result if $result; + my $error = $self->{vrfyerrstr}; + $i++; + push @error, "key $i: $error"; + print "key $i: $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'; + } + + + if (DEBUG) { + print "\n ---------------------- SIG DEBUG ----------------------"; + print "\n SIG:\t", $self->string; + print "\n KEY:\t", $keyref->string; + print "\n -------------------------------------------------------\n"; + } + + croak "Trying to verify SIG0 using non-SIG0 signature" if $self->{typecovered}; + + $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 { + shift->{vrfyerrstr}; +} + + +######################################## + +sub _ordered($$) { ## irreflexive 32-bit partial ordering + use integer; + my ( $a, $b ) = @_; + + return defined $b unless defined $a; # ( undef, any ) + return 0 unless defined $b; # ( any, undef ) + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + if ( $a < 0 ) { # translate $a<0 region + $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 + $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 + } + + return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 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; + croak 'undefined time' unless defined $arg; + 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 ); + $z -= 86400 unless $z < 1456704000 + 86400; # expunge 29 Feb 2100 + return $z + $y2054; + } + return ( timegm( reverse(@dhms), $m - 1, $y - 56 ) + $y2054 ) - $y1998; +} + + +sub _time2string { ## format time specification string + my $arg = shift; + croak 'undefined time' unless defined $arg; + 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; +} + + +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->data; + my ( $id, $status ) = unpack 'n2', $data; + my $hbin = pack 'n6 a*', $id, $status, @size; + $message = $hbin . substr $data, length $hbin; + } + + my @field = qw(typecovered algorithm labels orgttl sigexpiration siginception keytag); + 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; + join '', $sigdata, $message; + } +} + + +######################################## + +sub _CreateSig { + if (DNSSEC) { + my $self = shift; + + my $algorithm = $self->algorithm; + my $class = $DNSSEC_sign{$algorithm}; + + eval { + die "algorithm $algorithm not supported" unless $class; + $self->sigbin( $class->sign(@_) ); + } || croak "${@}signature generation failed"; + } +} + + +sub _VerifySig { + if (DNSSEC) { + my $self = shift; + + my $algorithm = $self->algorithm; + my $class = $DNSSEC_verify{$algorithm}; + + my $retval = eval { + die "algorithm $algorithm not supported" unless $class; + $class->verify( @_, $self->sigbin ); + }; + + unless ($retval) { + $self->{vrfyerrstr} = "${@}signature verification failed"; + print "\n", $self->{vrfyerrstr}, "\n" if DEBUG; + return 0; + } + + # uncoverable branch true # bug in Net::DNS::SEC or dependencies + croak "unknown error in $class->verify" unless $retval == 1; + print "\nalgorithm $algorithm verification successful\n" if DEBUG; + return 1; + } +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SIG typecovered algorithm labels + orgttl sigexpiration siginception + keytag signame signature'); + + use Net::DNS::SEC; + $sigrr = create Net::DNS::RR::SIG( $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 = create Net::DNS::RR::SIG( $data, $keypath ); + + $sigrr = create Net::DNS::RR::SIG( $data, $keypath, + sigval => 10 + ); + $sigrr->print; + + + # Alternatively use Net::DNS::SEC::Private + + $private = Net::DNS::SEC::Private->new($keypath); + + $sigrr= create Net::DNS::RR::SIG( $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 => 20181201010101, # signature inception + sigex => 20181201011101, # 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. + +=over 4 + +=item * + +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). + +=back + +=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 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 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 +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, +RFC4034, RFC3755, RFC2535, RFC2931, RFC3110, RFC3008, +L, +L + +L + +L + +=cut diff --git a/lib/lib/Net/DNS/RR/SMIMEA.pm b/lib/lib/Net/DNS/RR/SMIMEA.pm new file mode 100644 index 0000000..226d5cb --- /dev/null +++ b/lib/lib/Net/DNS/RR/SMIMEA.pm @@ -0,0 +1,229 @@ +package Net::DNS::RR::SMIMEA; + +# +# $Id: SMIMEA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $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; +} + + +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 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->usage(shift); + $self->selector(shift); + $self->matchingtype(shift); + $self->cert(@_); +} + + +sub usage { + my $self = shift; + + $self->{usage} = 0 + shift if scalar @_; + $self->{usage} || 0; +} + + +sub selector { + my $self = shift; + + $self->{selector} = 0 + shift if scalar @_; + $self->{selector} || 0; +} + + +sub matchingtype { + my $self = shift; + + $self->{matchingtype} = 0 + shift if scalar @_; + $self->{matchingtype} || 0; +} + + +sub cert { + my $self = shift; + return unpack "H*", $self->certbin() unless scalar @_; + $self->certbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub certbin { + my $self = shift; + + $self->{certbin} = shift if scalar @_; + $self->{certbin} || ""; +} + + +sub certificate { &cert; } + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC8162, +RFC6698 + +=cut diff --git a/lib/lib/Net/DNS/RR/SOA.pm b/lib/lib/Net/DNS/RR/SOA.pm new file mode 100644 index 0000000..3a15c19 --- /dev/null +++ b/lib/lib/Net/DNS/RR/SOA.pm @@ -0,0 +1,317 @@ +package Net::DNS::RR::SOA; + +# +# $Id: SOA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + ( $self->{mname}, $offset ) = decode Net::DNS::DomainName1035(@_); + ( $self->{rname}, $offset ) = decode Net::DNS::Mailbox1035( $data, $offset, @opaque ); + @{$self}{qw(serial refresh retry expire minimum)} = unpack "\@$offset N5", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $rname = $self->{rname}; + my $rdata = $self->{mname}->encode(@_); + $rdata .= $rname->encode( $offset + length($rdata), @opaque ); + $rdata .= pack 'N5', $self->serial, @{$self}{qw(refresh retry expire minimum)}; +} + + +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"; + my @rdata = $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 = shift; + + $self->mname(shift); + $self->rname(shift); + $self->serial(shift); + for (qw(refresh retry expire minimum)) { + $self->$_( Net::DNS::RR::ttl( {}, shift ) ) if scalar @_; + } +} + + +sub _defaults { ## specify RR attribute default values + my $self = shift; + + $self->_parse_rdata(qw(. . 0 4h 1h 3w 1h)); + delete $self->{serial}; +} + + +sub mname { + my $self = shift; + + $self->{mname} = new Net::DNS::DomainName1035(shift) if scalar @_; + $self->{mname}->name if $self->{mname}; +} + + +sub rname { + my $self = shift; + + $self->{rname} = new Net::DNS::Mailbox1035(shift) if scalar @_; + $self->{rname}->address if $self->{rname}; +} + + +sub serial { + my $self = shift; + + return $self->{serial} || 0 unless scalar @_; # current/default value + + my $value = shift; # replace if in sequence + return $self->{serial} = 0 + ( $value || 0 ) if _ordered( $self->{serial}, $value ); + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + my $serial = ( 0 + $self->{serial} ) & 0xFFFFFFFF; + return $self->{serial} = $serial ^ 0xFFFFFFFF if ( $serial & 0x7FFFFFFF ) == 0x7FFFFFFF; # wrap + return $self->{serial} = $serial + 1; # increment +} + + +sub refresh { + my $self = shift; + + $self->{refresh} = 0 + shift if scalar @_; + $self->{refresh} || 0; +} + + +sub retry { + my $self = shift; + + $self->{retry} = 0 + shift if scalar @_; + $self->{retry} || 0; +} + + +sub expire { + my $self = shift; + + $self->{expire} = 0 + shift if scalar @_; + $self->{expire} || 0; +} + + +sub minimum { + my $self = shift; + + $self->{minimum} = 0 + shift if scalar @_; + $self->{minimum} || 0; +} + + +######################################## + +sub _ordered($$) { ## irreflexive 32-bit partial ordering + use integer; + my ( $a, $b ) = @_; + + return 1 unless defined $a; # ( undef, any ) + return 0 unless defined $b; # ( any, undef ) + + # unwise to assume 64-bit arithmetic, or that 32-bit integer overflow goes unpunished + if ( $a < 0 ) { # translate $a<0 region + $a = ( $a ^ 0x80000000 ) & 0xFFFFFFFF; # 0 <= $a < 2**31 + $b = ( $b ^ 0x80000000 ) & 0xFFFFFFFF; # -2**31 <= $b < 2**32 + } + + return $a < $b ? ( $a > ( $b - 0x80000000 ) ) : ( $b < ( $a - 0x80000000 ) ); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1035 Section 3.3.13, RFC1982 + +=cut diff --git a/lib/lib/Net/DNS/RR/SPF.pm b/lib/lib/Net/DNS/RR/SPF.pm new file mode 100644 index 0000000..d7849a3 --- /dev/null +++ b/lib/lib/Net/DNS/RR/SPF.pm @@ -0,0 +1,115 @@ +package Net::DNS::RR::SPF; + +# +# $Id: SPF.pm 1593 2017-09-04 14:23:26Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1593 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR::TXT); + +=head1 NAME + +Net::DNS::RR::SPF - DNS SPF resource record + +=cut + + +use integer; + + +sub spfdata { + my @spf = shift->char_str_list(@_); + wantarray ? @spf : join '', @spf; +} + +sub txtdata { &spfdata; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('name SPF spfdata ...'); + + $rr = new Net::DNS::RR( name => 'name', + type => 'SPF', + spfdata => 'single text string' + ); + + $rr = new Net::DNS::RR( name => 'name', + type => 'SPF', + spfdata => [ 'multiple', 'strings', ... ] + ); + +=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 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 +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, RFC7208 + +=cut diff --git a/lib/lib/Net/DNS/RR/SRV.pm b/lib/lib/Net/DNS/RR/SRV.pm new file mode 100644 index 0000000..d564681 --- /dev/null +++ b/lib/lib/Net/DNS/RR/SRV.pm @@ -0,0 +1,199 @@ +package Net::DNS::RR::SRV; + +# +# $Id: SRV.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset, @opaque ) = @_; + + @{$self}{qw(priority weight port)} = unpack( "\@$offset n3", $$data ); + + $self->{target} = decode Net::DNS::DomainName2535( $data, $offset + 6, @opaque ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + my ( $offset, @opaque ) = @_; + + my $target = $self->{target}; + my @nums = ( $self->priority, $self->weight, $self->port ); + 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 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + foreach my $attr (qw(priority weight port target)) { + $self->$attr(shift); + } +} + + +sub priority { + my $self = shift; + + $self->{priority} = 0 + shift if scalar @_; + $self->{priority} || 0; +} + + +sub weight { + my $self = shift; + + $self->{weight} = 0 + shift if scalar @_; + $self->{weight} || 0; +} + + +sub port { + my $self = shift; + + $self->{port} = 0 + shift if scalar @_; + $self->{port} || 0; +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::DomainName2535(shift) if scalar @_; + $self->{target}->name if $self->{target}; +} + + +# order RRs by numerically increasing priority, decreasing weight +my $function = sub { + my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); + $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 = new Net::DNS::RR('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 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 +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, RFC2782 + +=cut diff --git a/lib/lib/Net/DNS/RR/SSHFP.pm b/lib/lib/Net/DNS/RR/SSHFP.pm new file mode 100644 index 0000000..c53ef09 --- /dev/null +++ b/lib/lib/Net/DNS/RR/SSHFP.pm @@ -0,0 +1,208 @@ +package Net::DNS::RR::SSHFP; + +# +# $Id: SSHFP.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $size = $self->{rdlength} - 2; + @{$self}{qw(algorithm fptype fpbin)} = unpack "\@$offset C2 a$size", $$data; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + 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 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->algorithm(shift); + $self->fptype(shift); + $self->fp(@_); +} + + +sub algorithm { + my $self = shift; + + $self->{algorithm} = 0 + shift if scalar @_; + $self->{algorithm} || 0; +} + + +sub fptype { + my $self = shift; + + $self->{fptype} = 0 + shift if scalar @_; + $self->{fptype} || 0; +} + + +sub fp { + my $self = shift; + return unpack "H*", $self->fpbin() unless scalar @_; + $self->fpbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub fpbin { + my $self = shift; + + $self->{fpbin} = shift if scalar @_; + $self->{fpbin} || ""; +} + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->fpbin ) : ''; +} + + +sub fingerprint { &fp; } ## historical + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC4255 + +=cut diff --git a/lib/lib/Net/DNS/RR/TKEY.pm b/lib/lib/Net/DNS/RR/TKEY.pm new file mode 100644 index 0000000..bc3f9a2 --- /dev/null +++ b/lib/lib/Net/DNS/RR/TKEY.pm @@ -0,0 +1,255 @@ +package Net::DNS::RR::TKEY; + +# +# $Id: TKEY.pm 1528 2017-01-18 21:44:58Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1528 $)[1]; + + +use strict; +use warnings; +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; +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 = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + + ( $self->{algorithm}, $offset ) = decode Net::DNS::DomainName(@_); + + @{$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 +} + + +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 { ## overide RR method + return 'ANY'; +} + +sub encode { ## overide 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 = shift; + + $self->{algorithm} = new Net::DNS::DomainName(shift) if scalar @_; + $self->{algorithm}->name if $self->{algorithm}; +} + + +sub inception { + my $self = shift; + + $self->{inception} = 0 + shift if scalar @_; + $self->{inception} || 0; +} + + +sub expiration { + my $self = shift; + + $self->{expiration} = 0 + shift if scalar @_; + $self->{expiration} || 0; +} + + +sub mode { + my $self = shift; + + $self->{mode} = 0 + shift if scalar @_; + $self->{mode} || 0; +} + + +sub error { + my $self = shift; + + $self->{error} = 0 + shift if scalar @_; + $self->{error} || 0; +} + + +sub key { + my $self = shift; + + $self->{key} = shift if scalar @_; + $self->{key} || ""; +} + + +sub other { + my $self = shift; + + $self->{other} = shift if scalar @_; + $self->{other} || ""; +} + + +sub other_data { &other; } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + +=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 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 +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, RFC2930 + +=cut diff --git a/lib/lib/Net/DNS/RR/TLSA.pm b/lib/lib/Net/DNS/RR/TLSA.pm new file mode 100644 index 0000000..fb1e74b --- /dev/null +++ b/lib/lib/Net/DNS/RR/TLSA.pm @@ -0,0 +1,227 @@ +package Net::DNS::RR::TLSA; + +# +# $Id: TLSA.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $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; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + 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 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->usage(shift); + $self->selector(shift); + $self->matchingtype(shift); + $self->cert(@_); +} + + +sub usage { + my $self = shift; + + $self->{usage} = 0 + shift if scalar @_; + $self->{usage} || 0; +} + + +sub selector { + my $self = shift; + + $self->{selector} = 0 + shift if scalar @_; + $self->{selector} || 0; +} + + +sub matchingtype { + my $self = shift; + + $self->{matchingtype} = 0 + shift if scalar @_; + $self->{matchingtype} || 0; +} + + +sub cert { + my $self = shift; + return unpack "H*", $self->certbin() unless scalar @_; + $self->certbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub certbin { + my $self = shift; + + $self->{certbin} = shift if scalar @_; + $self->{certbin} || ""; +} + + +sub certificate { &cert; } + + +sub babble { + return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->certbin ) : ''; +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC6698 + +=cut diff --git a/lib/lib/Net/DNS/RR/TSIG.pm b/lib/lib/Net/DNS/RR/TSIG.pm new file mode 100644 index 0000000..27e661f --- /dev/null +++ b/lib/lib/Net/DNS/RR/TSIG.pm @@ -0,0 +1,836 @@ +package Net::DNS::RR::TSIG; + +# +# $Id: TSIG.pm 1718 2018-10-22 14:39:29Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1718 $)[1]; + + +use strict; +use warnings; +use base qw(Net::DNS::RR); + +=head1 NAME + +Net::DNS::RR::TSIG - DNS TSIG resource record + +=cut + + +use integer; + +use Carp; + +eval 'require Digest::HMAC'; +eval 'require Digest::MD5'; +eval 'require Digest::SHA'; +eval 'require MIME::Base64'; + +use Net::DNS::DomainName; +use Net::DNS::Parameters; + +use constant ANY => classbyname qw(ANY); +use constant TSIG => typebyname qw(TSIG); + +{ + # source: http://www.iana.org/assignments/tsig-algorithm-names + my @algbyname = ( + 'HMAC-MD5.SIG-ALG.REG.INT' => 157, + 'HMAC-SHA1' => 161, + '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 : do { s/[\W_]//g; uc($_) }, @algbyname, @algalias; + my %algbyname = @algrehash; # work around broken cperl + + sub _algbyname { + my $key = uc shift; # synthetic key + $key =~ s/[\W_]//g; # strip non-alphanumerics + $algbyname{$key}; + } + + sub _algbyval { + my $value = shift; + $algbyval{$value}; + } +} + + +sub _decode_rdata { ## decode rdata from wire-format octet string + my $self = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + ( $self->{algorithm}, $offset ) = decode Net::DNS::DomainName(@_); + + # 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; +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $macbin = $self->macbin; + unless ($macbin) { + my ( $offset, undef, $packet ) = @_; + + my $sigdata = $self->sig_data($packet); # form data to be signed + $macbin = $self->macbin( $self->_mac_function($sigdata) ); + $self->original_id( $packet->header->id ); + } + + 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(''); +} + + +sub _size { ## estimate encoded size + my $self = shift; + my $clone = bless {%$self}, ref($self); # shallow clone + length $clone->encode( 0, undef, new Net::DNS::Packet() ); +} + + +sub encode { ## overide RR method + my $self = shift; + + my $kname = $self->{owner}->encode(); # uncompressed key name + my $rdata = eval { $self->_encode_rdata(@_) } || ''; + pack 'a* n2 N n a*', $kname, TSIG, ANY, 0, length $rdata, $rdata; +} + + +sub string { ## overide 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 { &_algorithm; } + + +sub key { + my $self = shift; + + $self->keybin( MIME::Base64::decode( join "", @_ ) ) if scalar @_; + MIME::Base64::encode( $self->keybin(), "" ) if defined wantarray; +} + + +sub keybin { &_keybin; } + + +sub time_signed { + my $self = shift; + + $self->{time_signed} = 0 + shift if scalar @_; + $self->{time_signed} = time() unless $self->{time_signed}; +} + + +sub fudge { + my $self = shift; + + $self->{fudge} = 0 + shift if scalar @_; + $self->{fudge} || 0; +} + + +sub mac { + my $self = shift; + + $self->macbin( pack "H*", map { die "!hex!" if m/[^0-9A-Fa-f]/; $_ } join "", @_ ) if scalar @_; + unpack "H*", $self->macbin() if defined wantarray; +} + + +sub macbin { + my $self = shift; + + $self->{macbin} = shift if scalar @_; + $self->{macbin} || ""; +} + + +sub prior_mac { + my $self = shift; + return unpack "H*", $self->prior_macbin() unless scalar @_; + $self->prior_macbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub prior_macbin { + my $self = shift; + + $self->{prior_macbin} = shift if scalar @_; + $self->{prior_macbin} || ""; +} + + +sub request_mac { + my $self = shift; + return unpack "H*", $self->request_macbin() unless scalar @_; + $self->request_macbin( pack "H*", map /[^\dA-F]/i ? croak "corrupt hex" : $_, join "", @_ ); +} + + +sub request_macbin { + my $self = shift; + + $self->{request_macbin} = shift if scalar @_; + $self->{request_macbin} || ""; +} + + +sub original_id { + my $self = shift; + + $self->{original_id} = 0 + shift if scalar @_; + $self->{original_id} || 0; +} + + +sub error { + my $self = shift; + $self->{error} = rcodebyname(shift) if scalar @_; + rcodebyval( $self->{error} ); +} + + +sub other { + my $self = shift; + $self->{other} = shift if scalar @_; + my $time = $self->{error} == 18 ? pack 'xxN', time() : ''; + $self->{other} = $time unless $self->{other}; +} + + +sub other_data { &other; } # uncoverable pod + + +sub sig_function { + my $self = shift; + + return $self->{sig_function} unless scalar @_; + $self->{sig_function} = shift; +} + +sub sign_func { &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->data; + my $hbin = pack 'n6', $message->{id}, $message->{status}, @size; + $message = join '', $hbin, substr $data, length $hbin; + } + } + + # 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 = shift; + my $karg = shift; + 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 new Net::DNS::RR( # ( request, options ) + name => $sigrr->name, + type => 'TSIG', + algorithm => $sigrr->algorithm, + request_macbin => $sigrr->macbin, + @_ + ); + + } elsif ( ref($karg) eq __PACKAGE__ ) { + my $tsig = $karg->_chain; + $tsig->{macbin} = undef; + return $tsig; + + } elsif ( ref($karg) eq 'Net::DNS::RR::KEY' ) { + return new Net::DNS::RR( + name => $karg->name, + type => 'TSIG', + algorithm => $karg->algorithm, + key => $karg->key, + @_ + ); + } + + croak "Usage: create $class(keyfile)\n\tcreate $class(keyname, key)"; + + } elsif ( scalar(@_) == 1 ) { + my $key = shift; # ( keyname, key ) + return new Net::DNS::RR( + name => $karg, + type => 'TSIG', + key => $key + ); + + } elsif ( $karg =~ /private$/ ) { # ( keyfile, options ) + require File::Spec; + require Net::DNS::ZoneFile; + my $keyfile = new Net::DNS::ZoneFile($karg); + my ( $alg, $key, $junk ); + while ( $keyfile->_getline ) { + ( $junk, $alg ) = split if /Algorithm:/; + ( $junk, $key ) = split if /Key:/; + } + + my ( $vol, $dir, $file ) = File::Spec->splitpath( $keyfile->name ); + croak 'misnamed private key' unless $file =~ /^K([^+]+)+.+private$/; + my $kname = $1; + return new Net::DNS::RR( + name => $kname, + type => 'TSIG', + algorithm => $alg, + key => $key, + @_ + ); + + } else { # ( keyfile, options ) + require Net::DNS::ZoneFile; + my $keyrr = new Net::DNS::ZoneFile($karg)->read; + croak 'key file incompatible with TSIG' unless $keyrr->type eq 'KEY'; + return new Net::DNS::RR( + name => $keyrr->name, + type => 'TSIG', + algorithm => $keyrr->algorithm, + key => $keyrr->key, + @_ + ); + } +} + + +sub verify { + my $self = shift; + my $data = shift; + + unless ( abs( time() - $self->time_signed ) < $self->fudge ) { + $self->error(18); # bad time + return; + } + + if ( scalar @_ ) { + my $arg = shift; + + unless ( ref($arg) ) { + $self->error(16); # bad sig (multi-packet) + return; + } + + my $signerkey = lc( join '+', $self->name, $self->algorithm ); + if ( $arg->isa('Net::DNS::Packet') ) { + my $request = $arg->sigrr; # request TSIG + my $rqstkey = lc( join '+', $request->name, $request->algorithm ); + $self->error(17) unless $signerkey eq $rqstkey; + $self->request_macbin( $request->macbin ); + + } elsif ( $arg->isa(__PACKAGE__) ) { + my $priorkey = lc( join '+', $arg->name, $arg->algorithm ); + $self->error(17) unless $signerkey eq $priorkey; + $self->prior_macbin( $arg->macbin ); + + } else { + croak 'Usage: $tsig->verify( $reply, $query )'; + } + } + return 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; + my $minlen = length($tsigmac) >> 1; # per RFC4635, 3.1 + $self->error(16) unless $macbin eq substr $tsigmac, 0, $maclen; + $self->error(1) if $maclen < $minlen or $maclen < 10 or $maclen > length $tsigmac; + + return $self->{error} ? undef : $tsig; +} + +sub vrfyerrstr { + my $self = shift; + return $self->error; +} + + +######################################## + +{ + 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} = new Net::DNS::DomainName($algname); + + } else { + $algname = _algbyval($digtype); + $self->{algorithm} = new Net::DNS::DomainName($algname); + + my ( $hash, @param ) = @{$digest{$digtype}}; + my ( undef, @block ) = @param; + my $digest = new $hash(@param); + my $function = sub { + my $hmac = new Digest::HMAC( shift, $digest, @block ); + $hmac->add(shift); + return $hmac->digest; + }; + + $self->sig_function($function); + + my $keyname = ( $self->{owner} || return )->canonical; + $keytable{$keyname}{digest} = $function; + } + } + + return $self->{algorithm}->name if defined wantarray; + } + + + sub _keybin { ## install key in key table + my $self = shift; + croak 'Unauthorised access to TSIG key material denied' unless scalar @_; + my $keyref = $keytable{$self->{owner}->canonical} ||= {}; + my $private = shift; # closure keeps private key private + $keyref->{key} = sub { + my $function = $keyref->{digest}; + return &$function( $private, @_ ); + }; + return undef; + } + + + sub _mac_function { ## apply keyed hash function to argument + my $self = shift; + + 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}; + &$function(@_); + } +} + + +# _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; + bless {%$self, link => $self}, ref($self); +} + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $tsig = create Net::DNS::RR::TSIG( $keyfile ); + + $tsig = create Net::DNS::RR::TSIG( $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 + + $mac = $rr->mac; + +Returns the message authentication code (MAC) as a string of hex +characters. The programmer must call the Net::DNS::Packet data() +object method before this will return anything meaningful. + +=cut + + +=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 RFC 2845 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 = new Digest::HMAC( $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 RFC2845 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 = create Net::DNS::RR::TSIG( $keyfile ); + + $tsig = create Net::DNS::RR::TSIG( $keyfile, + fudge => 300 + ); + +Returns a TSIG RR constructed using the parameters in the specified +key file, which is assumed to have been generated by dnssec-keygen. + + $tsig = create Net::DNS::RR::TSIG( $keyname, $key ); + +The two argument form is supported for backward compatibility. + +=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 + +TSIG keys are symmetric keys generated using dnssec-keygen: + + $ dnssec-keygen -a HMAC-SHA1 -b 160 -n HOST + + The key will be stored as a private and public keyfile pair + K+161+.private and K+161+.key + + where + is the DNS name of the key. + + is the (generated) numerical identifier used to + distinguish this key. + +Other algorithms may be substituted for HMAC-SHA1 in the above example. + +It is recommended that the keyname be globally unique and incorporate +the fully qualified domain names of the resolver and nameserver in +that order. It should be possible for more than one key to be in use +simultaneously between any such pair of hosts. + +Although the formats differ, the private and public keys are identical +and both should be stored and handled as secret data. + + +=head1 Configuring BIND Nameserver + +The following lines must be added to the /etc/named.conf file: + + key { + algorithm HMAC-SHA1; + secret ""; + }; + + is the name of the key chosen when the key was generated. + + is the key string extracted from the generated key file. + + +=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. + +TSIG verification, BIND keyfile handling and support for HMAC-SHA1, +HMAC-SHA224, HMAC-SHA256, HMAC-SHA384 and HMAC-SHA512 functions was +added by Dick Franks. + + +=head1 BUGS + +A 32-bit representation of time is used, contrary to RFC2845 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 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 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 +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, RFC2845, RFC4635 + +L + +=cut diff --git a/lib/lib/Net/DNS/RR/TXT.pm b/lib/lib/Net/DNS/RR/TXT.pm new file mode 100644 index 0000000..21cd0e4 --- /dev/null +++ b/lib/lib/Net/DNS/RR/TXT.pm @@ -0,0 +1,165 @@ +package Net::DNS::RR::TXT; + +# +# $Id: TXT.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + my $text; + my $txtdata = $self->{txtdata} = []; + while ( $offset < $limit ) { + ( $text, $offset ) = decode Net::DNS::Text( $data, $offset ); + push @$txtdata, $text; + } + + croak('corrupt TXT data') unless $offset == $limit; # more or less FUBAR +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $txtdata = $self->{txtdata}; + join '', map $_->encode, @$txtdata; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + my $txtdata = $self->{txtdata}; + my @txtdata = map $_->string, @$txtdata; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->{txtdata} = [map Net::DNS::Text->new($_), @_]; +} + + +sub txtdata { + my $self = shift; + + $self->{txtdata} = [map Net::DNS::Text->new($_), @_] if scalar @_; + + my $txtdata = $self->{txtdata} || []; + + return ( map $_->value, @$txtdata ) if wantarray; + + join ' ', map $_->value, @$txtdata if defined wantarray; +} + + +sub char_str_list { return (&txtdata); } # uncoverable pod + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR( 'name TXT txtdata ...' ); + + $rr = new Net::DNS::RR( name => 'name', + type => 'TXT', + txtdata => 'single text string' + ); + + $rr = new Net::DNS::RR( name => 'name', + type => 'TXT', + txtdata => [ 'multiple', 'strings', ... ] + ); + + use utf8; + $rr = new Net::DNS::RR( '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 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 +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, RFC1035 Section 3.3.14, RFC3629 + +=cut diff --git a/lib/lib/Net/DNS/RR/URI.pm b/lib/lib/Net/DNS/RR/URI.pm new file mode 100644 index 0000000..ae25d83 --- /dev/null +++ b/lib/lib/Net/DNS/RR/URI.pm @@ -0,0 +1,181 @@ +package Net::DNS::RR::URI; + +# +# $Id: URI.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + my $limit = $offset + $self->{rdlength}; + @{$self}{qw(priority weight)} = unpack( "\@$offset n2", $$data ); + $offset += 4; + $self->{target} = decode Net::DNS::Text( $data, $offset, $limit - $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + my $target = $self->{target}; + 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 ); +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + map $self->$_(shift), qw(priority weight target); +} + + +sub priority { + my $self = shift; + + $self->{priority} = 0 + shift if scalar @_; + $self->{priority} || 0; +} + + +sub weight { + my $self = shift; + + $self->{weight} = 0 + shift if scalar @_; + $self->{weight} || 0; +} + + +sub target { + my $self = shift; + + $self->{target} = new Net::DNS::Text(shift) if scalar @_; + $self->{target}->value if $self->{target}; +} + + +# order RRs by numerically increasing priority, decreasing weight +my $function = sub { + my ( $a, $b ) = ( $Net::DNS::a, $Net::DNS::b ); + $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 = new Net::DNS::RR('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 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 +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, +RFC7553 + +=cut diff --git a/lib/lib/Net/DNS/RR/X25.pm b/lib/lib/Net/DNS/RR/X25.pm new file mode 100644 index 0000000..fa9e108 --- /dev/null +++ b/lib/lib/Net/DNS/RR/X25.pm @@ -0,0 +1,132 @@ +package Net::DNS::RR::X25; + +# +# $Id: X25.pm 1597 2017-09-22 08:04:02Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1597 $)[1]; + + +use strict; +use warnings; +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 = shift; + my ( $data, $offset ) = @_; + + $self->{address} = decode Net::DNS::Text( $data, $offset ); +} + + +sub _encode_rdata { ## encode rdata as wire-format octet string + my $self = shift; + + $self->{address}->encode; +} + + +sub _format_rdata { ## format rdata portion of RR string. + my $self = shift; + + $self->{address}->string; +} + + +sub _parse_rdata { ## populate RR from rdata in argument list + my $self = shift; + + $self->address(shift); +} + + +sub address { + my $self = shift; + + $self->{address} = new Net::DNS::Text(shift) if scalar @_; + $self->{address}->value if $self->{address}; +} + + +sub PSDNaddress { &address; } + + +1; +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + $rr = new Net::DNS::RR('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 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 +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, RFC1183 Section 3.1 + +=cut diff --git a/lib/lib/Net/DNS/Resolver.pm b/lib/lib/Net/DNS/Resolver.pm new file mode 100644 index 0000000..7449647 --- /dev/null +++ b/lib/lib/Net/DNS/Resolver.pm @@ -0,0 +1,777 @@ +package Net::DNS::Resolver; + +# +# $Id: Resolver.pm 1717 2018-10-12 13:14:42Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1717 $)[1]; + +=head1 NAME + +Net::DNS::Resolver - DNS resolver class + +=cut + + +use strict; +use warnings; + +use constant CONFIG => defined eval "require Net::DNS::Resolver::$^O"; + +use constant OS_CONF => join '::', __PACKAGE__, CONFIG ? $^O : 'UNIX'; + +use base OS_CONF; + + +1; + +__END__ + + +=head1 SYNOPSIS + + use Net::DNS; + + $resolver = new Net::DNS::Resolver(); + + # 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 = new Net::DNS::Packet( ... ); + $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 = new Net::DNS::Resolver(); + + # Use my own configuration file + $resolver = new Net::DNS::Resolver( config_file => '/my/dns.conf' ); + + # Set options in the constructor + $resolver = new Net::DNS::Resolver( + nameservers => [ '10.1.1.128', '10.1.2.128' ], + 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 + +B address + +IP address of a name server that the resolver should query. + +B localdomain + +The domain suffix to be appended to a short non-absolute name. + +B domain ... + +A space-separated list of domains in the desired search path. + +B option:value ... + +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. + + + # Use my own configuration file + $resolver = new Net::DNS::Resolver( config_file => '/my/dns.conf' ); + +You can include a configuration file of your own when creating a +resolver object. This is supported on both Unix and Windows. + +If a custom configuration file is specified at first instantiation, +all other configuration files and environment variables are ignored. + + + # Set options in the constructor + $resolver = new Net::DNS::Resolver( + nameservers => [ '10.1.1.128', '10.1.2.128' ], + recurse => 0 + ); + +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( 'mailhost' ); + $packet = $resolver->query( 'mailhost.example.com' ); + $packet = $resolver->query( '192.0.2.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( 'mailhost' ); + $packet = $resolver->search( 'mailhost.example.com' ); + $packet = $resolver->search( '192.0.2.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( 'mailhost.example.com' ); + $packet = $resolver->query( '192.0.2.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( 'Khmac-sha1.example.+161+24053.private' ); + @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( 'Khmac-sha1.example.+161+24053.private' ); + $iterator = $resolver->axfr( 'example.com' ); + + while ( $rr = $iterator->() ) { + $rr->print; + } + + +=head2 bgsend + + $handle = $resolver->bgsend( $packet ) || die $resolver->errorstring; + + $handle = $resolver->bgsend( 'mailhost.example.com' ); + $handle = $resolver->bgsend( '192.0.2.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 bgisready + + until ($resolver->bgisready($handle)) { + ... + } + +C is the logical complement of C which is retained +for backward compatibility. + + +=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( '192.0.2.1', '192.0.2.2', '2001:DB8::3' ); + $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('192.0.2.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); # DNSSEC using default packetsize + $resolver->udppacketsize(1250); # lower the 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( $tsig ); + + $resolver->tsig( 'Khmac-sha1.example.+161+24053.private' ); + + $resolver->tsig( 'Khmac-sha1.example.+161+24053.key' ); + + $resolver->tsig( 'Khmac-sha1.example.+161+24053.key', + fudge => 60 + ); + + $resolver->tsig( $key_name, $key ); + + $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="192.0.2.1 192.0.2.2 2001:DB8::3" + export RES_NAMESERVERS + + # C Shell + setenv RES_NAMESERVERS "192.0.2.1 192.0.2.2 2001:DB8::3" + +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 IPv6 TRANSPORT + +The Net::DNS::Resolver library will enable IPv6 transport if the +L library package is available. + +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, IPv6 is not available or 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 search { + $self = shift; + + $cache{"@_"} ||= $self->SUPER::search(@_); + } + + +=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 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 +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, RFC 1034, RFC 1035 + +=cut + diff --git a/lib/lib/Net/DNS/Resolver/Base.pm b/lib/lib/Net/DNS/Resolver/Base.pm new file mode 100644 index 0000000..496cc4c --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/Base.pm @@ -0,0 +1,1268 @@ +package Net::DNS::Resolver::Base; + +# +# $Id: Base.pm 1719 2018-11-04 05:01:43Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1719 $)[1]; + + +# +# 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 USE_SOCKET_IP => defined eval 'use IO::Socket::IP 0.32; 1'; + +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 UNCND => $] < 5.008; ## eval '${^TAINT}' breaks old compilers +use constant TAINT => UNCND || eval '${^TAINT}'; +use constant TESTS => TAINT && defined eval 'require Scalar::Util'; + + +use strict; +use warnings; +use integer; +use Carp; +use IO::Select; +use IO::Socket; + +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 => ( IPv6 ? 0 : 1 ), + force_v6 => 0, # only relevant if IPv6 is supported + prefer_v4 => 0, + prefer_v6 => 0, + }, + __PACKAGE__; + + + sub _defaults { return $defaults; } +} + + +# 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; + $self->$attribute(@value); +} + + +sub _untaint { + return TAINT ? map ref($_) ? [_untaint(@$_)] : do { /^(.*)$/; $1 }, @_ : @_; +} + + +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/:/ ); + } +} + + +sub _read_config_file { ## read resolver config file + my $self = shift; + my $file = shift; + + my $filehandle; + open( $filehandle, '<', $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; +} + + +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 { print &string; } + + +sub domain { + my $self = shift; + my ($head) = $self->searchlist(@_); + my @list = grep defined, $head; + wantarray ? @list : "@list"; +} + +sub searchlist { + my $self = shift; + $self = $self->_defaults unless ref($self); + + return $self->{searchlist} = [@_] unless defined wantarray; + $self->{searchlist} = [@_] if scalar @_; + my @searchlist = @{$self->{searchlist}}; +} + + +sub nameservers { + my $self = shift; + $self = $self->_defaults unless ref($self); + + my @ip; + foreach my $ns ( grep defined, @_ ) { + 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(@_) || !defined(wantarray) ) { + my @ipv4 = grep _ipv4($_), @ip; + my @ipv6 = grep _ipv6($_), @ip; + $self->{nameservers} = \@ip; + $self->{nameserver4} = \@ipv4; + $self->{nameserver6} = \@ipv6; + } + + my @ns4 = $self->{force_v6} ? () : @{$self->{nameserver4}}; + my @ns6 = $self->{force_v4} ? () : @{$self->{nameserver6}}; + my @nameservers = @{$self->{nameservers}}; + @nameservers = ( @ns4, @ns6 ) if $self->{prefer_v4} || !scalar(@ns6); + @nameservers = ( @ns6, @ns4 ) if $self->{prefer_v6} || !scalar(@ns4); + + return @nameservers if scalar @nameservers; + + my $error = 'no nameservers'; + $error = 'IPv4 transport disabled' if scalar(@ns4) < scalar @{$self->{nameserver4}}; + $error = 'IPv6 transport disabled' if scalar(@ns6) < scalar @{$self->{nameserver6}}; + $self->errorstring($error); + return @nameservers; +} + +sub nameserver { &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; + + map $names->{lc( $_->qname )}++, $packet->question; + map $names->{lc( $_->cname )}++, grep $_->can('cname'), $packet->answer; + + my @addr = grep $_->can('address'), $packet->answer; + map $_->address, grep $names->{lc( $_->name )}, @addr; +} + + +sub replyfrom { + return shift->{replyfrom}; +} + +sub answerfrom { &replyfrom; } # uncoverable pod + + +sub _reset_errorstring { + shift->{errorstring} = ''; +} + +sub errorstring { + my $self = shift; + my $text = shift || return $self->{errorstring}; + $self->_diag( 'errorstring:', $text ); + return $self->{errorstring} = $text; +} + + +sub query { + my $self = shift; + my $name = shift || '.'; + + my @sfix = $self->{defnames} && ( $name !~ m/[.:]/ ) ? $self->domain : (); + + my $fqdn = join '.', $name, @sfix; + $self->_diag( 'query(', $fqdn, @_, ')' ); + my $packet = $self->send( $fqdn, @_ ) || return; + return $packet->header->ancount ? $packet : undef; +} + + +sub search { + my $self = shift; + + return $self->query(@_) unless $self->{dnsrch}; + + my $name = shift || '.'; + 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, @_, ')' ); + my $packet = $self->send( $fqname, @_ ) || next; + return $packet if $packet->header->ancount; + } + + return undef; +} + + +sub send { + my $self = shift; + my $packet = $self->_make_query_packet(@_); + my $packet_data = $packet->data; + + $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'); + $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) { + my $socket = $self->_create_tcp_socket($ip) || next; + my $select = IO::Select->new($socket); + + $self->_diag( 'tcp send', "[$ip]" ); + + $socket->send($tcp_packet); + $self->errorstring($!); + + next unless $select->can_read($timeout); # uncoverable branch true + + my $buffer = _read_tcp($socket); + $self->{replyfrom} = $ip; + $self->_diag( 'reply from', "[$ip]", length($buffer), 'bytes' ); + + my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); + $self->errorstring($@); + next unless $self->_accept_reply( $reply, $query ); + $reply->from($ip); + + 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 $socket = $self->_create_udp_socket($ns) || next; + my $dst_sockaddr = $self->_create_dst_sockaddr( $ns, $port ); + $ns = [$socket, $ns, $dst_sockaddr]; + } + + my ( $socket, $ip, $dst_sockaddr, $failed ) = @$ns; + next if $failed; + + $self->_diag( 'udp send', "[$ip]:$port" ); + + $select->add($socket); + $socket->send( $query_data, 0, $dst_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($dst_sockaddr); + + my $reply; + while ( my ($socket) = $select->can_read($timeout) ) { + my $peer = $socket->peerhost; + $self->{replyfrom} = $peer; + + my $buffer = _read_udp( $socket, $self->_packetsz ); + $self->_diag( "reply from [$peer]", length($buffer), 'bytes' ); + + my $packet = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); + $self->errorstring($@); + next unless $self->_accept_reply( $packet, $query ); + $reply = $packet; + $reply->from($peer); + 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 = shift; + my $packet = $self->_make_query_packet(@_); + my $packet_data = $packet->data; + + $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 ) { + my $socket = $self->_create_tcp_socket($ip) || next; + + $self->_diag( 'bgsend', "[$ip]" ); + + $socket->blocking(0); + $socket->send($tcp_packet); + $self->errorstring($!); + + my $expire = time() + $self->{tcp_timeout}; + ${*$socket}{net_dns_bg} = [$expire, $packet]; + return $socket; + } + + return undef; +} + + +sub _bgsend_udp { + my ( $self, $packet, $packet_data ) = @_; + + my $port = $self->{port}; + + foreach my $ip ( $self->nameservers ) { + my $socket = $self->_create_udp_socket($ip) || next; + my $dst_sockaddr = $self->_create_dst_sockaddr( $ip, $port ); + + $self->_diag( 'bgsend', "[$ip]:$port" ); + + $socket->send( $packet_data, 0, $dst_sockaddr ); + $self->errorstring($!); + + # handle failure to detect taint inside $socket->send() + die 'Insecure dependency while running with -T switch' + if TESTS && Scalar::Util::tainted($dst_sockaddr); + + my $expire = time() + $self->{udp_timeout}; + ${*$socket}{net_dns_bg} = [$expire, $packet]; + return $socket; + } + + return undef; +} + + +sub bgbusy { + 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); + + return if $self->{igntc}; + return unless $handle->socktype() == SOCK_DGRAM; + return unless $query; # SpamAssassin 3.4.1 workaround + + my $ans = $self->_bgread($handle); + $$appendix[2] = [$ans]; + return unless $ans; + return unless $ans->header->tc; + + $self->_diag('packet truncated: retrying using TCP'); + my $tcp = $self->_bgsend_tcp( $query, $query->data ) || return; + return defined( $_[1] = $tcp ); +} + + +sub bgisready { ## historical + !&bgbusy; # uncoverable pod +} + + +sub bgread { + while (&bgbusy) { # side effect: TCP retry + IO::Select->new( $_[1] )->can_read(0.02); # use 3 orders of magnitude less CPU + } + &_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); + + unless ( IO::Select->new($handle)->can_read(0) ) { + $self->errorstring('timed out'); + return; + } + + my $peer = $self->{replyfrom} = $handle->peerhost; + + my $dgram = $handle->socktype() == SOCK_DGRAM; + my $buffer = $dgram ? _read_udp( $handle, $self->_packetsz ) : _read_tcp($handle); + $self->_diag( "reply from [$peer]", length($buffer), 'bytes' ); + + my $reply = Net::DNS::Packet->decode( \$buffer, $self->{debug} ); + $self->errorstring($@); + return unless $self->_accept_reply( $reply, $query ); + $reply->from($peer); + + 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; + + $self->errorstring( $header->rcode ); # historical quirk +} + + +sub axfr { ## zone transfer + eval { + my $self = shift; + + # initialise iterator state vector + my ( $select, $verify, @rr, $soa ) = $self->_axfr_start(@_); + + 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->encode eq $soa->encode; + 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; + } + + 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 = shift; # uncoverable pod + defined( $self->{axfr_iter} = $self->axfr(@_) ); +} + + +sub axfr_next { ## historical + shift->{axfr_iter}->(); # uncoverable pod +} + + +sub _axfr_start { + my $self = shift; + my $dname = scalar(@_) ? shift : $self->domain; + my @class = @_; + + my $request = $self->_make_query_packet( $dname, 'AXFR', @class ); + my $content = $request->data; + my $TCP_msg = pack 'n a*', length($content), $content; + + $self->_diag("axfr_start( $dname @class )"); + + my ( $select, $reply, $rcode ); + foreach my $ns ( $self->nameservers ) { + my $socket = $self->_create_tcp_socket($ns) || next; + + $self->_diag("axfr_start nameserver [$ns]"); + + $select = IO::Select->new($socket); + $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 unless $rcode eq '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; + + $self->{replyfrom} = $socket->peerhost; + + my $buffer = _read_tcp($socket); + $self->_diag( 'received', length($buffer), 'bytes' ); + + my $packet = Net::DNS::Packet->new( \$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_tcp { + my $socket = shift; + + my ( $s1, $s2 ); + $socket->recv( $s1, 2 ); # one lump + $socket->recv( $s2, 2 - length $s1 ); # or two? + my $size = unpack 'n', pack( 'a*a*@2', $s1, $s2 ); + + my $buffer = ''; + while ( ( my $read = length $buffer ) < $size ) { + + # During some of my tests recv() returned undef even + # though there was no error. Checking the amount + # of data read appears to work around that problem. + + my $recv_buf; + $socket->recv( $recv_buf, $size - $read ); + + $buffer .= $recv_buf || last; + } + return $buffer; +} + + +# +# Usage: $data = _read_udp($socket, $length); +# +sub _read_udp { + my $socket = shift; + my $buffer = ''; + $socket->recv( $buffer, shift ); + return $buffer; +} + + +sub _create_tcp_socket { + my $self = shift; + my $ip = shift; + + my $sock_key = "TCP[$ip]"; + my $socket; + + 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}, + ) + if USE_SOCKET_IP; + + unless (USE_SOCKET_IP) { + $socket = IO::Socket::INET->new( + LocalAddr => $self->{srcaddr4}, + LocalPort => $self->{srcport} || undef, + PeerAddr => $ip, + PeerPort => $self->{port}, + Proto => 'tcp', + Timeout => $self->{tcp_timeout}, + ) + unless $ip6_addr; + } + + $self->errorstring("no socket $sock_key $!") unless $socket; + $self->{persistent}{$sock_key} = $self->{persistent_tcp} ? $socket : undef; + return $socket; +} + + +sub _create_udp_socket { + my $self = shift; + my $ip = shift; + + my $ip6_addr = IPv6 && _ipv6($ip); + my $sock_key = IPv6 && $ip6_addr ? 'UDP/IPv6' : 'UDP/IPv4'; + my $socket; + return $socket if $socket = $self->{persistent}{$sock_key}; + + $socket = IO::Socket::IP->new( + LocalAddr => $ip6_addr ? $self->{srcaddr6} : $self->{srcaddr4}, + LocalPort => $self->{srcport}, + Proto => 'udp', + Type => SOCK_DGRAM + ) + if USE_SOCKET_IP; + + unless (USE_SOCKET_IP) { + $socket = IO::Socket::INET->new( + LocalAddr => $self->{srcaddr4}, + LocalPort => $self->{srcport} || undef, + Proto => 'udp', + Type => SOCK_DGRAM + ) + unless $ip6_addr; + } + + $self->errorstring("no socket $sock_key $!") unless $socket; + $self->{persistent}{$sock_key} = $self->{persistent_udp} ? $socket : undef; + return $socket; +} + + +{ + no strict qw(subs); + my @udp = ( + flags => Socket::AI_NUMERICHOST, + protocol => Socket::IPPROTO_UDP, + socktype => SOCK_DGRAM + ); + + my $ip4 = USE_SOCKET_IP ? {family => AF_INET, @udp} : {}; + my $ip6 = USE_SOCKET_IP ? {family => AF_INET6, @udp} : {}; + + sub _create_dst_sockaddr { ## create UDP destination sockaddr structure + my ( $self, $ip, $port ) = @_; + + unless (USE_SOCKET_IP) { + return sockaddr_in( $port, inet_aton($ip) ) unless _ipv6($ip); + } + + ( grep ref, Socket::getaddrinfo( $ip, $port, _ipv6($ip) ? $ip6 : $ip4 ), {} )[0]->{addr} + if USE_SOCKET_IP; # NB: errors raised in socket->send + } +} + + +# Lightweight versions of subroutines from Net::IP module, recoded to fix RT#96812 + +sub _ipv4 { + for (shift) { + return if m/[^.0-9]/; # dots and digits only + return m/\.\d+\./; # dots separated by digits + } +} + +sub _ipv6 { + for (shift) { + return 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 + } +} + + +sub _make_query_packet { + my $self = shift; + + my ($packet) = @_; + if ( ref($packet) ) { + my $header = $packet->header; + $header->rd( $self->{recurse} ) if $header->opcode eq 'QUERY'; + + } else { + $packet = Net::DNS::Packet->new(@_); + + 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} ); + } + + $packet->edns->size( $self->{udppacketsize} ); # advertise UDPsize for local stack + + if ( $self->{tsig_rr} ) { + $packet->sign_tsig( $self->{tsig_rr} ) unless $packet->sigrr; + } + + return $packet; +} + + +sub dnssec { + my $self = shift; + + return $self->{dnssec} unless scalar @_; + + # increase default udppacket size if flag set + $self->udppacketsize(2048) if $self->{dnssec} = shift; + + return $self->{dnssec}; +} + + +sub force_v6 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{force_v6}; + $self->{force_v6} = $value ? do { $self->{force_v4} = 0; 1 } : 0; +} + +sub force_v4 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{force_v4}; + $self->{force_v4} = $value ? do { $self->{force_v6} = 0; 1 } : 0; +} + +sub prefer_v6 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{prefer_v6}; + $self->{prefer_v6} = $value ? do { $self->{prefer_v4} = 0; 1 } : 0; +} + +sub prefer_v4 { + my $self = shift; + my $value = scalar(@_) ? shift() : $self->{prefer_v4}; + $self->{prefer_v4} = $value ? do { $self->{prefer_v6} = 0; 1 } : 0; +} + + +sub srcaddr { + my $self = shift; + for (@_) { + my $hashkey = _ipv6($_) ? 'srcaddr6' : 'srcaddr4'; + $self->{$hashkey} = $_; + } + return shift; +} + + +sub tsig { + my $self = shift; + $self->{tsig_rr} = eval { + local $SIG{__DIE__}; + require Net::DNS::RR::TSIG; + Net::DNS::RR::TSIG->create(@_); + }; + croak "${@}unable to create TSIG record" if $@; +} + + +# 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 = shift; + $self->{udppacketsize} = shift if scalar @_; + return $self->_packetsz; +} + + +# +# Keep this method around. Folk depend on it although it is neither documented nor exported. +# +my $warned; + +sub make_query_packet { ## historical + unless ( $warned++ ) { # uncoverable pod + local $SIG{__WARN__}; + carp 'deprecated method; see RT#37104'; + } + &_make_query_packet; +} + + +sub _diag { ## debug output + my $self = shift; + print "\n;; @_\n" if $self->{debug}; +} + + +{ + my $parse_dig = sub { + require Net::DNS::ZoneFile; + + my $dug = new Net::DNS::ZoneFile( \*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; + } + 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; + } +} + + +our $AUTOLOAD; + +sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup) + +sub AUTOLOAD { ## Default method + my ($self) = @_; + + my $name = $AUTOLOAD; + $name =~ s/.*://; + croak qq[unknown method "$name"] unless $public_attr{$name}; + + no strict q/refs/; + *{$AUTOLOAD} = sub { + my $self = shift; + $self = $self->_defaults unless ref($self); + $self->{$name} = shift || 0 if scalar @_; + return $self->{$name}; + }; + + goto &{$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 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 +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.11.4-RedHat-9.11.4-4.fc28 <<>> @b.root-servers.net . -t NS +; (2 servers found) +;; global options: +cmd +;; Got answer: +;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 44111 +;; 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: 4096 +;; QUESTION SECTION: +;. IN NS + +;; ANSWER SECTION: +. 518400 IN NS c.root-servers.net. +. 518400 IN NS k.root-servers.net. +. 518400 IN NS l.root-servers.net. +. 518400 IN NS j.root-servers.net. +. 518400 IN NS b.root-servers.net. +. 518400 IN NS g.root-servers.net. +. 518400 IN NS h.root-servers.net. +. 518400 IN NS d.root-servers.net. +. 518400 IN NS a.root-servers.net. +. 518400 IN NS f.root-servers.net. +. 518400 IN NS i.root-servers.net. +. 518400 IN NS m.root-servers.net. +. 518400 IN NS e.root-servers.net. + +;; ADDITIONAL SECTION: +a.root-servers.net. 3600000 IN A 198.41.0.4 +b.root-servers.net. 3600000 IN A 199.9.14.201 +c.root-servers.net. 3600000 IN A 192.33.4.12 +d.root-servers.net. 3600000 IN A 199.7.91.13 +e.root-servers.net. 3600000 IN A 192.203.230.10 +f.root-servers.net. 3600000 IN A 192.5.5.241 +g.root-servers.net. 3600000 IN A 192.112.36.4 +h.root-servers.net. 3600000 IN A 198.97.190.53 +i.root-servers.net. 3600000 IN A 192.36.148.17 +j.root-servers.net. 3600000 IN A 192.58.128.30 +k.root-servers.net. 3600000 IN A 193.0.14.129 +l.root-servers.net. 3600000 IN A 199.7.83.42 +m.root-servers.net. 3600000 IN A 202.12.27.33 +a.root-servers.net. 3600000 IN AAAA 2001:503:ba3e::2:30 +b.root-servers.net. 3600000 IN AAAA 2001:500:200::b +c.root-servers.net. 3600000 IN AAAA 2001:500:2::c +d.root-servers.net. 3600000 IN AAAA 2001:500:2d::d +e.root-servers.net. 3600000 IN AAAA 2001:500:a8::e +f.root-servers.net. 3600000 IN AAAA 2001:500:2f::f +g.root-servers.net. 3600000 IN AAAA 2001:500:12::d0d +h.root-servers.net. 3600000 IN AAAA 2001:500:1::53 +i.root-servers.net. 3600000 IN AAAA 2001:7fe::53 +j.root-servers.net. 3600000 IN AAAA 2001:503:c27::2:30 +k.root-servers.net. 3600000 IN AAAA 2001:7fd::1 +l.root-servers.net. 3600000 IN AAAA 2001:500:9f::42 +m.root-servers.net. 3600000 IN AAAA 2001:dc3::35 + +;; Query time: 173 msec +;; SERVER: 199.9.14.201#53(199.9.14.201) +;; WHEN: Fri Aug 10 19:03:11 BST 2018 +;; MSG SIZE rcvd: 811 + diff --git a/lib/lib/Net/DNS/Resolver/MSWin32.pm b/lib/lib/Net/DNS/Resolver/MSWin32.pm new file mode 100644 index 0000000..5f7c5ea --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/MSWin32.pm @@ -0,0 +1,145 @@ +package Net::DNS::Resolver::MSWin32; + +# +# $Id: MSWin32.pm 1568 2017-05-27 06:40:20Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1568 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::MSWin32 - MS Windows resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + +use Carp; + +our $Registry; + +use constant WINHLP => defined eval 'require Win32::IPHelper'; +use constant WINREG => defined eval 'use Win32::TieRegistry qw(KEY_READ REG_DWORD); 1'; + + +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(@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; +} + + +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 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 +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 + diff --git a/lib/lib/Net/DNS/Resolver/Recurse.pm b/lib/lib/Net/DNS/Resolver/Recurse.pm new file mode 100644 index 0000000..0465e42 --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/Recurse.pm @@ -0,0 +1,244 @@ +package Net::DNS::Resolver::Recurse; + +# +# $Id: Recurse.pm 1709 2018-09-07 08:03:09Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1709 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::Recurse - DNS recursive resolver + + +=head1 SYNOPSIS + + use Net::DNS::Resolver::Recurse; + + $resolver = new Net::DNS::Resolver::Recurse(); + + $packet = $resolver->query ( 'www.example.com', 'A' ); + $packet = $resolver->search( 'www.example.com', 'A' ); + $packet = $resolver->send ( 'www.example.com', 'A' ); + + +=head1 DESCRIPTION + +This module is a subclass of Net::DNS::Resolver. + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver); + + +=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 $self = shift; + + splice @hints, 0, 0, splice( @hints, int( rand scalar @hints ) ); # cut deck + return @hints unless scalar @_; + $root = []; + @hints = @_; +} + + +=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 { + return &Net::DNS::Resolver::Base::send if ref $_[1]; # send Net::DNS::Packet + + my $self = shift; + my $res = bless {persistent => {'.' => $root}, %$self}, ref($self); + + my $question = new Net::DNS::Question(@_); + my $original = pop(@_); # sneaky extra argument needed + $original = $question unless ref($original); # to preserve original request + + my ( $head, @tail ) = $question->{qname}->label; + my $domain = lc( join( '.', @tail ) || '.' ); + my $nslist = $res->{persistent}->{$domain} ||= []; + unless ( defined $head ) { + my $defres = new Net::DNS::Resolver(); + $defres->nameservers( $res->_hints ); # fall back to inbuilt list + $defres->udppacketsize(1024); # RFC8109 + my @config = $defres->nameserver( $res->hints ); + return $defres->send(qw(. NS)); + } + + if ( scalar @$nslist ) { + $self->_diag("using cached nameservers for $domain"); + } else { + $domain = lc $question->qname if $question->qtype ne 'NULL'; + my $packet = $res->send( $domain, 'NULL', 'IN', $original ); + return unless $packet; + + my @answer = $packet->answer; # return authoritative answer + return $packet if $packet->header->aa && grep $_->name eq $original->qname, @answer; + + my @auth = grep $_->type eq 'NS', $packet->answer, $packet->authority; + my %auth = map { lc $_->nsdname => lc $_->name } @auth; + my %glue; + my @glue = grep $_->can('address'), $packet->additional; + foreach ( grep $auth{lc $_->name}, @glue ) { + push @{$glue{lc $_->name}}, $_->address; + } + + my %zone = reverse %auth; + foreach my $zone ( keys %zone ) { + my @nsname = grep $auth{$_} eq $zone, keys %auth; + my @list = map $glue{$_} ? $glue{$_} : $_, @nsname; + @{$res->{persistent}->{$zone}} = @list; + return $packet if length($zone) > length($domain); + $self->_diag("cache nameservers for $zone"); + @$nslist = @list; + } + } + + my $query = new Net::DNS::Packet(); + $query->{question} = [$original]; + $res = bless {%$res}, qw(Net::DNS::Resolver) if $nslist eq $root; + $res->udppacketsize(1024); + $res->recurse(0); + + splice @$nslist, 0, 0, splice( @$nslist, int( rand scalar @$nslist ) ); # cut deck + + foreach my $ns (@$nslist) { + if ( ref $ns ) { + my @ip = map @$_, grep ref($_), @$nslist; + $res->nameservers(@ip); # cached IP list + } else { + $self->_diag("find missing glue for $ns"); + my $name = $ns; # suppress deep recursion by + $ns = []; # inserting placeholder in cache + $ns = [$res->nameservers($name)]; # substitute IP list in situ + } + + my $reply = $res->send($query); + next unless $reply; + + $self->_callback($reply); + return $reply; + } +} + + +sub query_dorecursion { &send; } # uncoverable pod + + +=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 = shift; + + ( $self->{callback} ) = grep ref($_) eq 'CODE', @_; +} + +sub _callback { + my $callback = shift->{callback}; + $callback->(@_) if $callback; +} + +sub recursion_callback { &callback; } # uncoverable pod + + +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 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 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 +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 + diff --git a/lib/lib/Net/DNS/Resolver/UNIX.pm b/lib/lib/Net/DNS/Resolver/UNIX.pm new file mode 100644 index 0000000..98dfce8 --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/UNIX.pm @@ -0,0 +1,92 @@ +package Net::DNS::Resolver::UNIX; + +# +# $Id: UNIX.pm 1573 2017-06-12 11:03:59Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1573 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::UNIX - Unix resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +my @config_file = grep -f $_ && -r _, '/etc/resolv.conf'; + +my $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +local $ENV{PATH} = '/bin:/usr/bin'; +my $uname = eval {`uname -n 2>/dev/null`} || ''; +chomp $uname; +my ( $host, @domain ) = split /\./, $uname, 2; +__PACKAGE__->domain(@domain); + + +sub _init { + my $defaults = shift->_defaults; + + map $defaults->_read_config_file($_), @config_file; + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +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 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 +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 + diff --git a/lib/lib/Net/DNS/Resolver/android.pm b/lib/lib/Net/DNS/Resolver/android.pm new file mode 100644 index 0000000..2a0255a --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/android.pm @@ -0,0 +1,97 @@ +package Net::DNS::Resolver::android; + +# +# $Id: android.pm 1568 2017-05-27 06:40:20Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1568 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::android - Android resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +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 $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +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; + + + map $defaults->_read_config_file($_), @config_file; + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +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 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 +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 + diff --git a/lib/lib/Net/DNS/Resolver/cygwin.pm b/lib/lib/Net/DNS/Resolver/cygwin.pm new file mode 100644 index 0000000..b6fe806 --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/cygwin.pm @@ -0,0 +1,182 @@ +package Net::DNS::Resolver::cygwin; + +# +# $Id: cygwin.pm 1719 2018-11-04 05:01:43Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1719 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::cygwin - Cygwin resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +sub _getregkey { + my $key = join '/', @_; + + my $filehandle; + open( $filehandle, '<', $key ) or return ''; + my $value = <$filehandle>; + $value =~ s/\0+$// if $value; + close($filehandle); + + 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; +} + + +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 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 +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 + diff --git a/lib/lib/Net/DNS/Resolver/os2.pm b/lib/lib/Net/DNS/Resolver/os2.pm new file mode 100644 index 0000000..526f386 --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/os2.pm @@ -0,0 +1,87 @@ +package Net::DNS::Resolver::os2; + +# +# $Id: os2.pm 1568 2017-05-27 06:40:20Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1568 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::os2 - OS2 resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +my $config_file = 'resolv'; +my @config_path = ( $ENV{ETC} || '/etc' ); +my @config_file = grep -f $_ && -r _, map "$_/$config_file", @config_path; + +my $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +sub _init { + my $defaults = shift->_defaults; + + map $defaults->_read_config_file($_), @config_file; + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +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 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 +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 + diff --git a/lib/lib/Net/DNS/Resolver/os390.pm b/lib/lib/Net/DNS/Resolver/os390.pm new file mode 100644 index 0000000..9e5bd02 --- /dev/null +++ b/lib/lib/Net/DNS/Resolver/os390.pm @@ -0,0 +1,185 @@ +package Net::DNS::Resolver::os390; + +# +# $Id: os390.pm 1719 2018-11-04 05:01:43Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1719 $)[1]; + + +=head1 NAME + +Net::DNS::Resolver::os390 - IBM OS/390 resolver class + +=cut + + +use strict; +use warnings; +use base qw(Net::DNS::Resolver::Base); + + +local $ENV{PATH} = '/bin:/usr/bin'; +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 $dotfile = '.resolv.conf'; +my @dotpath = grep defined, $ENV{HOME}, '.'; +my @dotfile = grep -f $_ && -o _, map "$_/$dotfile", @dotpath; + + +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} = '/bin:/usr/bin'; + + foreach my $dataset ( Net::DNS::Resolver::Base::_untaint( grep defined, @dataset ) ) { + eval { + my $filehandle; # "cat" able to read MVS dataset + open( $filehandle, '-|', qq[cat "$dataset" 2>/dev/null] ) or die "$dataset: $!"; + + my @nameserver; + my @searchlist; + local $_; + + while (<$filehandle>) { + 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($filehandle); + + $defaults->nameserver(@nameserver) if @nameserver && !$stop{nameserver}++; + $defaults->searchlist(@searchlist) if @searchlist && !$stop{search}++; + }; + warn $@ if $@; + } + + %$defaults = Net::DNS::Resolver::Base::_untaint(%$defaults); + + map $defaults->_read_config_file($_), @dotfile; + + $defaults->_read_env; +} + + +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 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 +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 + diff --git a/lib/lib/Net/DNS/Text.pm b/lib/lib/Net/DNS/Text.pm new file mode 100644 index 0000000..c126a6f --- /dev/null +++ b/lib/lib/Net/DNS/Text.pm @@ -0,0 +1,323 @@ +package Net::DNS::Text; + +# +# $Id: Text.pm 1698 2018-07-24 15:29:05Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1698 $)[1]; + + +=head1 NAME + +Net::DNS::Text - DNS text representation + +=head1 SYNOPSIS + + use Net::DNS::Text; + + $object = new Net::DNS::Text('example'); + $string = $object->string; + + $object = decode Net::DNS::Text( \$data, $offset ); + ( $object, $next ) = decode Net::DNS::Text( \$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 strict; +use warnings; +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 = new Net::DNS::Text('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, %unescape ); ## precalculated ASCII escape tables + +sub new { + my $self = bless [], shift; + croak 'argument undefined' unless defined $_[0]; + + local $_ = &_encode_utf8; + + s/^\042(.*)\042$/$1/s; # strip paired quotes + + s/\134\134/\134\060\071\062/g; # disguise escaped escape + s/\134([\060-\071]{3})/$unescape{$1}/eg; # numeric escape + s/\134(.)/$1/g; # character escape + + while ( length $_ > 255 ) { + my $chunk = substr( $_, 0, 255 ); # carve into chunks + substr( $chunk, -length($1) ) = '' if $chunk =~ /.([\300-\377][\200-\277]*)$/; + push @$self, $chunk; + substr( $_, 0, length $chunk ) = ''; + } + push @$self, $_; + + return $self; +} + + +=head2 decode + + $object = decode Net::DNS::Text( \$buffer, $offset ); + + ( $object, $next ) = decode Net::DNS::Text( \$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; + 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; + 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; + _decode_utf8( join '', @$self ); +} + + +=head2 string + + $string = $text->string; + +Conditionally quoted 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 $string = _decode_utf8( join '', map $escape{$_}, @s ); + + return $string unless $string =~ /[ \t\n\r\f]|^$|;$/; # unquoted contiguous + + $string =~ s/\\([^"0-9])/$1/g; # unescape printable characters except \" + join '', '"', $string, '"'; # quoted 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 + ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->decode($_), $z ) : $_; +} + + +sub _encode_utf8 { ## perl internal encoding to UTF-8 + local $_ = shift; + + # 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 + ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_; +} + + +%escape = eval { ## precalculated ASCII/UTF-8 escape table + my %table; + my @C0 = ( 0 .. 31 ); # control characters + my @NA = UTF8 ? ( 192, 193, 216 .. 223, 245 .. 255 ) : ( 128 .. 255 ); + + foreach ( 0 .. 255 ) { # transparent + $table{pack( 'C', $_ )} = pack 'C', $_; + } + + foreach ( 34, 40, 41, 59 ) { # character escape " ( ) ; + $table{pack( 'C', $_ )} = pack 'C2', 92, $_; + } + + foreach my $n ( @C0, 92, 127, @NA ) { # numerical escape + my $codepoint = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $codepoint =~ tr [0-9] [\060-\071]; + + $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint; + } + + return %table; +}; + + +%unescape = eval { ## precalculated numeric escape table + my %table; + + foreach my $n ( 0 .. 255 ) { + my $key = sprintf( '%03u', $n ); + + # partial transliteration for non-ASCII character encodings + $key =~ tr [0-9] [\060-\071]; + + $table{$key} = pack 'C', $n; + $table{$key} = pack 'C2', 92, $n if $n == 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 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 +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, RFC1035, RFC3629, Unicode TR#16 + +=cut + diff --git a/lib/lib/Net/DNS/Update.pm b/lib/lib/Net/DNS/Update.pm new file mode 100644 index 0000000..20d632a --- /dev/null +++ b/lib/lib/Net/DNS/Update.pm @@ -0,0 +1,286 @@ +package Net::DNS::Update; + +# +# $Id: Update.pm 1714 2018-09-21 14:14:55Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1714 $)[1]; + + +=head1 NAME + +Net::DNS::Update - DNS dynamic update packet + +=head1 SYNOPSIS + + use Net::DNS; + + $update = new Net::DNS::Update( 'example.com', 'IN' ); + + $update->push( prereq => nxrrset('foo.example.com. A') ); + $update->push( update => rr_add('foo.example.com. 86400 A 192.168.1.2') ); + +=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 strict; +use warnings; +use integer; +use Carp; + +use base qw(Net::DNS::Packet); + +use Net::DNS::Resolver; + + +=head1 METHODS + +=head2 new + + $update = new Net::DNS::Update; + $update = new Net::DNS::Update( 'example.com' ); + $update = new Net::DNS::Update( 'example.com', 'HS' ); + +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 { + shift; + my ( $zone, @class ) = @_; + + my ($domain) = grep defined && length, $zone, Net::DNS::Resolver->searchlist; + + eval { + local $SIG{__DIE__}; + + my $self = __PACKAGE__->SUPER::new( $domain, 'SOA', @class ); + + my $header = $self->header; + $header->opcode('UPDATE'); + $header->qr(0); + $header->rd(0); + + return $self; + } || croak $@; +} + + +=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 = shift; + my $list = $self->_section(shift); + my @arg = grep ref($_), @_; + + my ($zone) = $self->zone; + my $zclass = $zone->zclass; + my @rr = grep $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ), @arg; + + CORE::push( @$list, @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 = shift; + my $list = $self->_section(shift); + my @arg = grep ref($_), @_; + + my ($zone) = $self->zone; + my $zclass = $zone->zclass; + my @rr = grep $_->class( $_->class =~ /ANY|NONE/ ? () : $zclass ), @arg; + + my %unique = map { ( bless( {%$_, ttl => 0}, ref $_ )->canonical => $_ ) } @rr, @$list; + + scalar( @$list = values %unique ); +} + + +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 = new Net::DNS::Update('example.com'); + + # Prerequisite is that no A records exist for the name. + $update->push( pre => nxrrset('foo.example.com. A') ); + + # Add two A records for the name. + $update->push( update => rr_add('foo.example.com. 86400 A 192.168.1.2') ); + $update->push( update => rr_add('foo.example.com. 86400 A 172.16.3.4') ); + + # Send the update to the zone's primary master. + my $resolver = new Net::DNS::Resolver; + $resolver->nameservers('primary-master.example.com'); + + my $reply = $resolver->send($update); + + # Did it work? + if ($reply) { + if ( $reply->header->rcode eq 'NOERROR' ) { + print "Update succeeded\n"; + } else { + print 'Update failed: ', $reply->header->rcode, "\n"; + } + } else { + print 'Update failed: ', $resolver->errorstring, "\n"; + } + + +=head2 Add an MX record for a name that already exists + + my $update = new Net::DNS::Update('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 = new Net::DNS::Update('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 = new Net::DNS::Update('example.com'); + $update->push( prereq => yxrrset('foo.example.com A') ); + $update->push( update => rr_del('foo.example.com A') ); + +=head2 Delete all RRs for a name + + my $update = new Net::DNS::Update('example.com'); + $update->push( prereq => yxdomain('byebye.example.com') ); + $update->push( update => rr_del('byebye.example.com') ); + +=head2 Perform a DNS update signed using a BIND private key file + + my $update = new Net::DNS::Update('example.com'); + $update->push( update => rr_add('foo.example.com A 10.1.2.3') ); + $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.private" ); + my $reply = $resolver->send( $update ); + $reply->verify( $update ) || die $reply->verifyerr; + +=head2 Signing the DNS update using a BIND public key file + + $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.key" ); + +=head2 Signing the DNS update using a customised TSIG record + + $update->sign_tsig( "$dir/Khmac-sha512.example.com.+165+01018.private", + fudge => 60 + ); + +=head2 Another way to sign a DNS update + + my $key_name = 'tsig-key'; + my $key = 'awwLOtRfpGE+rRKF2+DEiw=='; + + my $tsig = new Net::DNS::RR("$key_name TSIG $key"); + $tsig->fudge(60); + + my $update = new Net::DNS::Update('example.com'); + $update->push( update => rr_add('foo.example.com A 10.1.2.3') ); + $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 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 +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, RFC 2136, RFC 2845 + +=cut + diff --git a/lib/lib/Net/DNS/ZoneFile.pm b/lib/lib/Net/DNS/ZoneFile.pm new file mode 100644 index 0000000..7df7b71 --- /dev/null +++ b/lib/lib/Net/DNS/ZoneFile.pm @@ -0,0 +1,605 @@ +package Net::DNS::ZoneFile; + +# +# $Id: ZoneFile.pm 1709 2018-09-07 08:03:09Z willem $ +# +our $VERSION = (qw$LastChangedRevision: 1709 $)[1]; + + +=head1 NAME + +Net::DNS::ZoneFile - DNS zone file + +=head1 SYNOPSIS + + use Net::DNS::ZoneFile; + + $zonefile = new Net::DNS::ZoneFile( '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 strict; +use warnings; +use integer; +use Carp; +use IO::File; + +use base qw(Exporter); +our @EXPORT = qw(parse read readfh); + +use constant PERLIO => defined eval 'require PerlIO'; + +require Net::DNS::Domain; +require Net::DNS::RR; + + +=head1 METHODS + + +=head2 new + + $zonefile = new Net::DNS::ZoneFile( 'filename', ['example.com'] ); + + $handle = new IO::File( 'filename', '<:encoding(ISO8859-7)' ); + $zonefile = new Net::DNS::ZoneFile( $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. + +Character encoding is 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 $self = bless {}, shift; + my $file = shift; + $self->_origin(shift); + + if ( ref($file) ) { + $self->{filename} = $self->{filehandle} = $file; + $self->{fileopen} = {}; + return $self if ref($file) =~ /IO::File|FileHandle|GLOB|Text/; + croak 'argument not a file handle'; + } + + $self->{filename} = $file ||= ''; + $self->{filehandle} = new IO::File($file) or croak "$! $file"; + $self->{fileopen}{$file}++; + 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 + + local $SIG{__DIE__}; + + if (wantarray) { + my @zone; # return entire zone + eval { + my $rr; + push( @zone, $rr ) while $rr = $self->_getRR; + }; + croak join ' ', $@, ' file', $self->name, 'line', $self->line, "\n " if $@; + return @zone; + } + + my $rr = eval { $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 { new Net::DNS::Domain('@') } )->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 ); + $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); + $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 = new Net::DNS::ZoneFile( _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; + + use overload ( '<>' => 'readline' ); + + sub new { + my $self = bless {}, shift; + my $data = shift; + $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 ); + $listref = Net::DNS::ZoneFile->parse( $string, $include_dir ); + $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 !ref($arg1) && $arg1 eq __PACKAGE__; + my $text = shift; + return &readfh( new Net::DNS::ZoneFile::Text($text), @_ ); +} + + +######################################## + + +{ + + package Net::DNS::ZoneFile::Generator; + + use overload ( '<>' => 'readline' ); + + sub new { + my $self = bless {}, shift; + my ( $range, $template, $line ) = @_; + + $template =~ s/\\\$/\\036/g; # disguise escaped dollar + $template =~ s/\$\$/\\036/g; # disguise escaped dollar + + my ( $bound, $step ) = split m#[/]#, $range; # initial iterator state + my ( $first, $last ) = split m#[-]#, $bound; + $first ||= 0; + $last ||= $first; + $step = abs( $step || 1 ); # coerce step to match range + $step = -$step if $last < $first; + $self->{count} = int( ( $last - $first ) / $step ) + 1; + + @{$self}{qw(instant step template line)} = ( $first, $step, $template, $line ); + return $self; + } + + sub readline { + my $self = shift; + return undef 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 $ + 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 = new Net::DNS::ZoneFile::Generator( $range, $template, $self->line ); + + delete $self->{latest}; # forget previous owner + $self->{parent} = bless {%$self}, ref($self); # save state, create link + $self->{filehandle} = $handle; +} + + +my $LEX_REGEX = q/("[^"]*"|"[^"]*$)|;[^\n]*|([()])|(^\s)|[ \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 (/[(]/) { # concatenate multi-line RR + 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 /$LEX_REGEX/o; + if ( grep( $_ eq '(', @token ) && !grep( $_ eq ')', @token ) ) { + while (<$fh>) { + $_ = pop(@token) . $_; # splice fragmented 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 @part = grep defined && length, split /$LEX_REGEX/o; + push @token, @part; + last if grep $_ eq ')', @part; + } + $_ = join ' ', @token; # reconstitute RR string + } + } + + return $_ unless /^\$/; # RR string + + if (/^\$INCLUDE/) { # directive + my ( $keyword, @argument ) = split; + die '$INCLUDE incomplete' unless @argument; + $fh = $self->_include(@argument); + + } elsif (/^\$GENERATE/) { # directive + my ( $keyword, $range, @template ) = split; + die '$GENERATE incomplete' unless $range; + $fh = $self->_generate( $range, "@template\n" ); + + } elsif (/^\$ORIGIN/) { # directive + my ( $keyword, $origin, @etc ) = split; + die '$ORIGIN incomplete' unless $origin; + my $context = $self->{context}; + &$context( sub { $self->_origin($origin); } ); + + } elsif (/^\$TTL/) { # directive + my ( $keyword, $ttl, @etc ) = split; + die '$TTL incomplete' unless defined $ttl; + $self->{TTL} = Net::DNS::RR::ttl( {}, $ttl ); + + } else { # unrecognised + my ($keyword) = split; + die "unknown '$keyword' directive"; + } + } + + $self->{eom} = $self->line; # end of file + $fh->close(); + my $link = $self->{parent} || return undef; # end of zone + %$self = %$link; # end $INCLUDE + $self->_getline; # resume input +} + + +sub _getRR { ## get RR from current source + my $self = shift; + + local $_; + $self->_getline || return undef; # 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} ); + + $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 = shift; + my $file = _filename(shift); + my $root = shift; + + my $opened = {%{$self->{fileopen}}}; + croak qq(recursive \$INCLUDE $file) if $opened->{$file}++; + + my @discipline = PERLIO ? ( join ':', '<', PerlIO::get_layers $self->{filehandle} ) : (); + my $handle = new IO::File( $file, @discipline ) or croak "$! $file"; + + delete $self->{latest}; # forget previous owner + $self->{parent} = bless {%$self}, ref($self); # save state, create link + $self->{context} = origin Net::DNS::Domain($root) if $root; + $self->{filename} = $file; + $self->{fileopen} = $opened; + return $self->{filehandle} = $handle; +} + + +sub _origin { ## change $ORIGIN (scope: current file) + my $self = shift; + $self->{context} = origin Net::DNS::Domain(shift); + delete $self->{latest}; # forget previous owner +} + + +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 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 +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, RFC1035 Section 5.1, +RFC2308, BIND 9 Administrator Reference Manual + +=cut + diff --git a/lib/lib/Net/HTTP.pm b/lib/lib/Net/HTTP.pm new file mode 100644 index 0000000..fecfc38 --- /dev/null +++ b/lib/lib/Net/HTTP.pm @@ -0,0 +1,307 @@ +package Net::HTTP; +our $VERSION = '6.18'; +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.18 + +=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) + diff --git a/lib/lib/Net/HTTP/Methods.pm b/lib/lib/Net/HTTP/Methods.pm new file mode 100644 index 0000000..c682e3f --- /dev/null +++ b/lib/lib/Net/HTTP/Methods.pm @@ -0,0 +1,669 @@ +package Net::HTTP::Methods; +our $VERSION = '6.18'; +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.18 + +=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 diff --git a/lib/lib/Net/HTTP/NB.pm b/lib/lib/Net/HTTP/NB.pm new file mode 100644 index 0000000..ff70563 --- /dev/null +++ b/lib/lib/Net/HTTP/NB.pm @@ -0,0 +1,121 @@ +package Net::HTTP::NB; +our $VERSION = '6.18'; +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.18 + +=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 + diff --git a/lib/lib/Net/HTTPS.pm b/lib/lib/Net/HTTPS.pm new file mode 100644 index 0000000..2ec04b6 --- /dev/null +++ b/lib/lib/Net/HTTPS.pm @@ -0,0 +1,135 @@ +package Net::HTTPS; +our $VERSION = '6.18'; +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.18 + +=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) + diff --git a/lib/lib/Net/IMAP/Client.pm b/lib/lib/Net/IMAP/Client.pm new file mode 100644 index 0000000..9a0c5e8 --- /dev/null +++ b/lib/lib/Net/IMAP/Client.pm @@ -0,0 +1,2015 @@ +package Net::IMAP::Client; + +use vars qw[$VERSION]; +$VERSION = '0.9505'; + +use strict; +use warnings; + +use List::Util qw( min max first ); +use List::MoreUtils qw( each_array ); +use IO::Socket::INET (); +use IO::Socket::SSL (); +use Socket qw( SO_KEEPALIVE ); + +use Net::IMAP::Client::MsgSummary (); + +our $READ_BUFFER = 4096; +my %UID_COMMANDS = map { $_ => 1 } qw( COPY FETCH STORE SEARCH SORT THREAD ); +my %DEFAULT_ARGS = ( + uid_mode => 1, + timeout => 90, + server => '127.0.0.1', + port => undef, + user => undef, + pass => undef, + ssl => 0, + ssl_verify_peer => 1, + socket => undef, + _cmd_id => 0, + ssl_options => {}, +); + +sub new { + my ($class, %args) = @_; + + my $self = { map { + $_ => exists $args{$_} ? $args{$_} : $DEFAULT_ARGS{$_} + } keys %DEFAULT_ARGS }; + + bless $self, $class; + + $self->{notifications} = []; + eval { + $self->{greeting} = $self->_socket_getline; + }; + return $@ ? undef : $self; +} + +sub DESTROY { + my ($self) = @_; + eval { + $self->quit + if $self->{socket}->opened; + }; +} + +sub uid_mode { + my ($self, $val) = @_; + if (defined($val)) { + return $self->{uid_mode} = $val; + } else { + return $self->{uid_mode}; + } +} + +### imap utilities ### + +sub login { + my ($self, $user, $pass) = @_; + $user ||= $self->{user}; + $pass ||= $self->{pass}; + $self->{user} = $user; + $self->{pass} = $pass; + _string_quote($user); + _string_quote($pass); + my ($ok) = $self->_tell_imap(LOGIN => "$user $pass"); + return $ok; +} + +sub logout { + my ($self) = @_; + $self->_send_cmd('LOGOUT'); + $self->_get_socket->close; + return 1; +} + +*quit = \&logout; + +sub capability { + my ($self, $requirement) = @_; + my $capability = $self->{capability}; + unless ($capability) { + my ($ok, $lines) = $self->_tell_imap('CAPABILITY'); + if ($ok) { + my $line = $lines->[0][0]; + if ($line =~ /^\*\s+CAPABILITY\s+(.*?)\s*$/) { + $capability = $self->{capability} = [ split(/\s+/, $1) ]; + } + } + } + if ($requirement && $capability) { + return first { $_ =~ $requirement } @$capability; + } + return $capability; +} + +sub status { + my $self = shift; + my $a; + my $wants_one = undef; + if (ref($_[0]) eq 'ARRAY') { + my @tmp = @{$_[0]}; + $a = \@tmp; + } else { + $a = [ shift ]; + $wants_one = 1; + } + foreach (@$a) { + _string_quote($_); + $_ = "STATUS $_ (MESSAGES RECENT UNSEEN UIDNEXT UIDVALIDITY)"; + } + my $results = $self->_tell_imap2(@$a); + + # remove "NO CLIENT BUG DETECTED" lines as they serve no + # purpose beyond the religious zeal of IMAP implementors + for my $row (@$results) { + if (@{$row->[1]} > 1) { + $row->[1] = [ grep { $_->[0] !~ /NO CLIENT BUG DETECTED: STATUS on selected mailbox:/ } @{$row->[1]} ]; + } + } + + my %ret; + my $name; + foreach my $i (@$results) { + if ($i->[0]) { # was successful? + my $tokens = _parse_tokens($i->[1]->[0]); + $name = $tokens->[2]; + $tokens = $tokens->[3]; + my %tmp = @$tokens; + $tmp{name} = $name; + $ret{$name} = \%tmp; + } + } + return $wants_one + ? (defined $name and $ret{$name}) # avoid data on undef key + : \%ret; +} + +sub select { + my ($self, $folder) = @_; + $self->_select_or_examine($folder, 'SELECT'); +} +sub examine { + my ($self, $folder) = @_; + $self->_select_or_examine($folder, 'EXAMINE'); +} + +sub _select_or_examine { + my ($self, $folder, $operation) = @_; + my $quoted = $folder; + _string_quote($quoted); + my ($ok, $lines) = $self->_tell_imap($operation => $quoted); + if ($ok) { + $self->{selected_folder} = $folder; + my %info = (); + foreach my $tmp (@$lines) { + my $line = $tmp->[0]; + if ($line =~ /^\*\s+(\d+)\s+EXISTS/i) { + $info{messages} = $1 + 0; + } elsif ($line =~ /^\*\s+FLAGS\s+\((.*?)\)/i) { + $info{flags} = [ split(/\s+/, $1) ]; + } elsif ($line =~ /^\*\s+(\d+)\s+RECENT/i) { + $info{recent} = $1 + 0; + } elsif ($line =~ /^\*\s+OK\s+\[(.*?)\s+(.*?)\]/i) { + my ($flag, $value) = ($1, $2); + if ($value =~ /\((.*?)\)/) { + $info{sflags}->{$flag} = [split(/\s+/, $1)]; + } else { + $info{sflags}->{$flag} = $value; + } + } + } + $self->{FOLDERS} ||= {}; + $self->{FOLDERS}{$folder} = \%info; + } + return $ok; +} + +sub separator { + my ($self) = @_; + my $sep = $self->{separator}; + if (!$sep) { + my ($ok, $lines) = $self->_tell_imap(LIST => '"" ""'); + if ($ok) { + my $tokens = _parse_tokens($lines->[0]); + $sep = $self->{separator} = $tokens->[3]; + } else { + $sep = undef; + } + } + return $sep; +} + +sub folders { + my ($self) = @_; + my ($ok, $lines) = $self->_tell_imap(LIST => '"" "*"'); + if ($ok) { + my @ret = map { _parse_tokens($_)->[4] } @$lines; + return wantarray ? @ret : \@ret; + } + return undef; +} + +sub _mk_namespace { + my ($ns) = @_; + if ($ns) { + foreach my $i (@$ns) { + $i = { + prefix => $i->[0], + sep => $i->[1], + }; + } + } + return $ns; +} + +sub namespace { + my ($self) = @_; + my ($ok, $lines) = $self->_tell_imap('NAMESPACE'); + if ($ok) { + my $ret = _parse_tokens($lines->[0]); + splice(@$ret, 0, 2); + return { + personal => _mk_namespace($ret->[0]), + other => _mk_namespace($ret->[1]), + shared => _mk_namespace($ret->[2]), + }; + } +} + +sub folders_more { + my ($self) = @_; + my ($ok, $lines) = $self->_tell_imap(LIST => '"" "*"'); + if ($ok) { + my %ret = map { + my $tokens = _parse_tokens($_); + my $flags = $tokens->[2]; + my $sep = $tokens->[3]; + my $name = $tokens->[4]; + ( $name, { flags => $flags, sep => $sep } ); + } @$lines; + return \%ret; + } + return undef; +} + +sub noop { + my ($self) = @_; + my ($ok) = $self->_tell_imap('NOOP', undef, 1); + return $ok; +} + +sub seq_to_uid { + my ($self, @seq_ids) = @_; + my $ids = join(',', @seq_ids); + + my $save_uid_mode = $self->uid_mode; + $self->uid_mode(0); + my ($ok, $lines) = $self->_tell_imap(FETCH => "$ids UID", 1); + $self->uid_mode($save_uid_mode); + + if ($ok) { + my %ret = map { + $_->[0] =~ /^\*\s+(\d+)\s+FETCH\s*\(\s*UID\s+(\d+)/ + && ( $1, $2 ); + } @$lines; + return \%ret; + } + return undef; +} + +sub search { + my ($self, $criteria, $sort, $charset) = @_; + + $charset ||= 'UTF-8'; + + my $cmd = $sort ? 'SORT' : 'SEARCH'; + if ($sort) { + if (ref($sort) eq 'ARRAY') { + $sort = uc '(' . join(' ', @$sort) . ')'; + } elsif ($sort !~ /^\(/) { + $sort = uc "($sort)"; + } + $sort =~ s/\s*$/ /; + $sort =~ s/\^/REVERSE /g; + } else { + $charset = "CHARSET $charset"; + $sort = ''; + } + + if (ref($criteria) eq 'HASH') { + my @a; + while (my ($key, $val) = each %$criteria) { + my $quoted = $val; + # don't quote range + _string_quote($quoted) unless uc $key eq 'UID'; + push @a, uc $key, $quoted; + } + $criteria = '(' . join(' ', @a) . ')'; + } + + my ($ok, $lines) = $self->_tell_imap($cmd => "$sort$charset $criteria", 1); + if ($ok) { + # it makes no sense to employ the full token parser here + # read past progress messages lacking initial '*' + foreach my $line (@{$lines->[0]}) { + if ($line =~ s/^\*\s+(?:SEARCH|SORT)\s+//ig) { + $line =~ s/\s*$//g; + return [ map { $_ + 0 } split(/\s+/, $line) ]; + } + } + } + + return undef; +} + +sub get_rfc822_body { + my ($self, $msg) = @_; + my $wants_many = undef; + if (ref($msg) eq 'ARRAY') { + $msg = join(',', @$msg); + $wants_many = 1; + } + my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg RFC822", 1); + if ($ok) { + my @ret = map { $_->[1] } @$lines; + return $wants_many ? \@ret : $ret[0]; + } + return undef; +} + +sub get_part_body { + my ($self, $msg, $part) = @_; + $part = "BODY[$part]"; + my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg $part", 1); + if ($ok) { + # it can contain FLAGS notification, i.e. \Seen flag becomes set + my $tokens = _parse_tokens($lines->[0], 1); + my %hash = @{$tokens->[3]}; + if ($hash{FLAGS}) { + $self->_handle_notification($tokens); + } + return $hash{$part}; + } + return undef; +} + +sub get_parts_bodies { + my ($self, $msg, $parts) = @_; + my $tmp = join(' ', map { "BODY[$_]" } @$parts); + my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg ($tmp)", 1); + if ($ok) { + # it can contain FLAGS notification, i.e. \Seen flag becomes set + my $tokens = _parse_tokens($lines->[0], 1); + my %hash = @{$tokens->[3]}; + if ($hash{FLAGS}) { + $self->_handle_notification($tokens); + } + my %ret = map {( $_, $hash{"BODY[$_]"} )} @$parts; + return \%ret; + } + return undef; +} + +sub get_summaries { + my ($self, $msg, $headers) = @_; + if (!$msg) { + $msg = '1:*'; + } elsif (ref $msg eq 'ARRAY') { + $msg = join(',', @$msg); + } + if ($headers) { + $headers = " BODY.PEEK[HEADER.FIELDS ($headers)]"; + } else { + $headers = ''; + } + my ($ok, $lp) = $self->_tell_imap(FETCH => qq[$msg (UID FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODYSTRUCTURE$headers)], 1); + if ($ok) { + my @ret; + foreach (@$lp) { + my $summary; + my $tokens = _parse_tokens($_); ## in form: [ '*', ID, 'FETCH', [ tokens ]] + if ($tokens->[2] eq 'FETCH') { + my %hash = @{$tokens->[3]}; + if ($hash{ENVELOPE}) { + # full fetch + $summary = Net::IMAP::Client::MsgSummary->new(\%hash, undef, !!$headers); + $summary->{seq_id} = $tokens->[1]; + } else { + # 'FETCH' (probably FLAGS) notification! + $self->_handle_notification($tokens); + } + } else { + # notification! + $self->_handle_notification($tokens); + } + push @ret, $summary + if $summary; + } + return \@ret; + } else { + return undef; + } +} + +sub fetch { + my ($self, $msg, $keys) = @_; + my $wants_many = undef; + if (ref $msg eq 'ARRAY') { + $msg = join(',', @$msg); + $wants_many = 1; + } + if (ref $keys eq 'ARRAY') { + $keys = join(' ', @$keys); + } + my ($ok, $lp) = $self->_tell_imap(FETCH => qq[$msg ($keys)], 1); + if ($ok) { + my @ret; + foreach (@$lp) { + my $tokens = _parse_tokens($_)->[3]; + push @ret, { @$tokens }; + } + return $wants_many || @ret > 1 ? \@ret : $ret[0]; + } +} + +sub create_folder { + my ($self, $folder) = @_; + my $quoted = $folder; + _string_quote($quoted); + my ($ok) = $self->_tell_imap(CREATE => $quoted); + return $ok; +} + +# recursively removes any subfolders! +sub delete_folder { + my ($self, $folder) = @_; + my $quoted = $folder . $self->separator . '*'; + _string_quote($quoted); + my ($ok, $lines) = $self->_tell_imap(LIST => qq{"" $quoted}); + if ($ok) { + my @subfolders; + foreach my $line (@$lines) { + my $tokens = _parse_tokens($line); + push @subfolders, $tokens->[4]; + } + @subfolders = sort { length($b) - length($a) } @subfolders; + foreach (@subfolders) { + _string_quote($_); + ($ok) = $self->_tell_imap(DELETE => $_); + } + $quoted = $folder; + _string_quote($quoted); + ($ok) = $self->_tell_imap(DELETE => $quoted); + } + return $ok; +} + +sub append { + my ($self, $folder, $rfc822, $flags, $date) = @_; + die 'message body passed to append() must be a SCALAR reference' + unless ref $rfc822 eq 'SCALAR'; + my $quoted = $folder; + _string_quote($quoted); + my $args = [ "$quoted " ]; + if ($flags) { + # my @tmp = @$flags; + # $quoted = join(' ', map { _string_quote($_) } @tmp); + # push @$args, "($quoted) "; + push @$args, '(' . join(' ', @$flags) . ') '; + } + if ($date) { + my $tmp = $date; + _string_quote($tmp); + push @$args, "$tmp "; + } + push @$args, $rfc822; + my ($ok) = $self->_tell_imap(APPEND => $args, 1); + return $ok; +} + +sub copy { + my ($self, $msg, $folder) = @_; + my $quoted = $folder; + _string_quote($quoted); + if (ref $msg eq 'ARRAY') { + $msg = join(',', @$msg); + } + my ($ok) = $self->_tell_imap(COPY => "$msg $quoted", 1); + return $ok; +} + +sub get_flags { + my ($self, $msg) = @_; + my $wants_many = undef; + if (ref($msg) eq 'ARRAY') { + $msg = join(',', @$msg); + $wants_many = 1; + } + my ($ok, $lines) = $self->_tell_imap(FETCH => "$msg (UID FLAGS)", 1); + if ($ok) { + my %ret = map { + my $tokens = _parse_tokens($_)->[3]; + my %hash = @$tokens; + $hash{UID} => $hash{FLAGS}; + } @$lines; + return $wants_many ? \%ret : $ret{$msg}; + } + return undef; +} + +sub get_threads { + my ($self, $algo, $msg) = @_; + $algo ||= "REFERENCES"; + my ($ok, $lines) = $self->_tell_imap(THREAD => "$algo UTF-8 ALL"); + if ($ok) { + my $result = $lines->[0][0]; + $result =~ s/^\*\s+THREAD\s+//; + my $parsed = _parse_tokens([ $result ]); + if ($msg) { + (my $left = $result) =~ s/\b$msg\b.*$//; + my $thr = 0; + my $par = 0; + for (my $i = 0; $i < length($left); ++$i) { + my $c = substr($left, $i, 1); + if ($c eq '(') { + $par++; + } elsif ($c eq ')') { + $par--; + if ($par == 0) { + $thr++; + } + } + } + $parsed = $parsed->[$thr]; + } + return $parsed; + } + return $ok; +} + +sub _store_helper { + my ($self, $msg, $flags, $cmd) = @_; + if (ref $msg eq 'ARRAY') { + $msg = join(',', @$msg); + } + unless (ref $flags) { + $flags = [ $flags ]; + } + $flags = '(' . join(' ', @$flags) . ')'; + $self->_tell_imap(STORE => "$msg $cmd $flags", 1); +} + +sub store { + my ($self, $msg, $flags) = @_; + $self->_store_helper($msg, $flags, 'FLAGS'); +} + +sub add_flags { + my ($self, $msg, $flags) = @_; + $self->_store_helper($msg, $flags, '+FLAGS'); +} + +sub del_flags { + my ($self, $msg, $flags) = @_; + $self->_store_helper($msg, $flags, '-FLAGS'); +} + +sub delete_message { + my ($self, $msg) = @_; + $self->add_flags($msg, '\\Deleted'); +} + +sub expunge { + my ($self) = @_; + my ($ok, $lines) = $self->_tell_imap('EXPUNGE' => undef, 1); + if ($ok && $lines && @$lines) { + my $ret = $lines->[0][0]; + if ($ret =~ /^\*\s+(\d+)\s+EXPUNGE/) { + return $1 + 0; + } + } + return $ok ? -1 : undef; +} + +sub last_error { + my ($self) = @_; + $self->{_error} =~ s/\s+$//s; # remove trailing carriage return + return $self->{_error}; +} + +sub notifications { + my ($self) = @_; + my $tmp = $self->{notifications}; + $self->{notifications} = []; + return wantarray ? @$tmp : $tmp; +} + +##### internal stuff ##### + +sub _get_port { + my ($self) = @_; + return $self->{port} || ($self->{ssl} ? 993 : 143); +} + +sub _get_timeout { + my ($self) = @_; + return $self->{timeout} || 90; +} + +sub _get_server { + my ($self) = @_; + return $self->{server}; +} + +sub _get_ssl_config { + my ($self) = @_; + if (!$self->{ssl_verify_peer} + || !$self->{ssl_ca_path} + && !$self->{ssl_ca_file} + && $^O ne 'linux') { + return SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE; + } + + my %ssl_config = ( SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_PEER ); + + if ($^O eq 'linux' && !$self->{ssl_ca_path} && !$self->{ssl_ca_file}) { + $ssl_config{SSL_ca_path} = '/etc/ssl/certs/'; + -d $ssl_config{SSL_ca_path} + or die "$ssl_config{SSL_ca_path}: SSL certification directory not found"; + } + $ssl_config{SSL_ca_path} = $self->{ssl_ca_path} if $self->{ssl_ca_path}; + $ssl_config{SSL_ca_file} = $self->{ssl_ca_file} if $self->{ssl_ca_file}; + + return %ssl_config; +} +sub _get_socket { + my ($self) = @_; + my $socket = $self->{socket} ||= ($self->{ssl} ? 'IO::Socket::SSL' : 'IO::Socket::INET')->new( + ( ( %{$self->{ssl_options}} ) x !!$self->{ssl} ), + PeerAddr => $self->_get_server, + PeerPort => $self->_get_port, + Timeout => $self->_get_timeout, + Proto => 'tcp', + Blocking => 1, + $self->_get_ssl_config, + ) or die "failed connect or ssl handshake: $!,$IO::Socket::SSL::SSL_ERROR"; + $socket->sockopt(SO_KEEPALIVE, 1); + return $socket; +} + +sub _get_next_id { + return ++$_[0]->{_cmd_id}; +} + +sub _socket_getline { + local $/ = "\r\n"; + return $_[0]->_get_socket->getline; +} + +sub _socket_write { + my $self = shift; + # open LOG, '>>:raw', '/tmp/net-imap-client.log'; + # print LOG @_; + # close LOG; + $self->_get_socket->write(@_); +} + +sub _send_cmd { + my ($self, $cmd, $args) = @_; + + local $\; + use bytes; + my $id = $self->_get_next_id; + if ($self->uid_mode && exists($UID_COMMANDS{$cmd})) { + $cmd = "UID $cmd"; + } + my @literals = (); + if (ref $args eq 'ARRAY') { + # may contain literals + foreach (@$args) { + if (ref $_ eq 'SCALAR') { + push @literals, $_; + $_ = '{' . length($$_) . "}\r\n"; + } + } + $args = join('', @$args); + } + my $socket = $self->_get_socket; + if (@literals == 0) { + $cmd = "NIC$id $cmd" . ($args ? " $args" : '') . "\r\n"; + $self->_socket_write($cmd); + } else { + $cmd = "NIC$id $cmd "; + $self->_socket_write($cmd); + my @split = split(/\r\n/, $args); + + my $ea = each_array(@split, @literals); + while (my ($tmp, $lit) = $ea->()) { + $self->_socket_write($tmp . "\r\n"); + my $line = $self->_socket_getline; + # print STDERR "$line - $tmp\n"; + if ($line =~ /^\+/) { + $self->_socket_write($$lit); + } else { + $self->{_error} = "Expected continuation, got: $line"; + # XXX: it's really bad if we get here, what to do? + return undef; + } + } + $self->_socket_write("\r\n"); # end of command! + } + $socket->flush; + return "NIC$id"; +} + +sub _read_literal { + my ($self, $count) = @_; + + my $buf; + my @lines = (); + my $sock = $self->_get_socket; + # print STDERR "\033[1;31m ::: Reading $count bytes ::: \033[0m \n"; + while ($count > 0) { + my $read = $sock->read($buf, min($count, $READ_BUFFER)); + # print STDERR "GOT $read / $buf"; + $count -= $read; + last if !$read; + push @lines, $buf; + } + + $buf = join('', @lines); + return \$buf; +} + +sub _cmd_ok { + my ($self, $res, $id) = @_; + $id ||= $self->{_cmd_id}; + + if ($res =~ /^NIC$id\s+OK/i) { + return 1; + } elsif ($res =~ /^NIC$id\s+(?:NO|BAD)(?:\s+(.+))?/i) { + my $error = $1 || 'unknown error'; + $self->{_error} = $error; + return 0; + } + return undef; +} + +sub _cmd_ok2 { + my ($self, $res) = @_; + + if ($res =~ /^(NIC\d+)\s+OK/i) { + my $id = $1; + return ($id, 1); + } elsif ($res =~ /^(NIC\d+)\s+(?:NO|BAD)(?:\s+(.+))?/i) { + my $id = $1; + my $error = $2 || 'unknown error'; + $self->{_error} = $error; + return ($id, 0, $error); + } + return (); +} + +sub _reconnect_if_needed { + my ($self, $force) = @_; + if ($force || !$self->_get_socket->connected) { + $self->{socket} = undef; + $self->{greeting} = $self->_socket_getline; + if ($self->login) { + if ($self->{selected_folder}) { + $self->select($self->{selected_folder}); + } + return 1; + } + return undef; + } + return 0; +} + +sub _tell_imap { + my ($self, $cmd, $args, $do_notf) = @_; + + $cmd = uc $cmd; + + my ($lineparts, $ok, $res); + + RETRY1: { + $self->_send_cmd($cmd, $args); + redo RETRY1 if $self->_reconnect_if_needed; + } + + $lineparts = []; # holds results in boxes + my $accumulator = []; # box for collecting results + while ($res = $self->_socket_getline) { + # print STDERR ">>>>$res<<<<<\n"; + + if ($res =~ /^\*/) { + + # store previous box and start a new one + + push @$lineparts, $accumulator if @$accumulator; + $accumulator = []; + } + if ($res =~ /(.*)\{(\d+)\}\r\n/) { + my ($line, $len) = ($1, $2 + 0); + push @$accumulator, + $line, + $self->_read_literal($len); + } else { + $ok = $self->_cmd_ok($res); + if (defined($ok)) { + last; + } else { + push @$accumulator, $res; + } + } + } + # store last box + push @$lineparts, $accumulator if @$accumulator; + + unless (defined $res) { + goto RETRY1 if $self->_reconnect_if_needed(1); + } + + if ($do_notf) { + no warnings 'uninitialized'; + for (my $i = scalar(@$lineparts); --$i >= 0;) { + my $line = $lineparts->[$i]; + + # 1. notifications don't contain literals + last if scalar(@$line) != 1; + + my $text = $line->[0]; + + # 2. FETCH notifications only contain FLAGS. We make a + # promise never to FETCH flags alone intentionally. + + # 3. Other notifications will have a first token different + # from the running command + + if ( $text =~ /^\*\s+\d+\s+FETCH\s*\(\s*FLAGS\s*\([^\)]*?\)\)/ + || $text !~ /^\*\s+(?:\d+\s+)?$cmd/ ) { + my $tokens = _parse_tokens($line); + if ($self->_handle_notification($tokens, 1)) { + splice @$lineparts, $i, 1; + } + next; + } + + last; + } + } + + return wantarray ? ($ok, $lineparts) : $ok ? $lineparts : undef; +} + +# Variant of the above method that sends multiple commands. After +# sending all commands to the server, it waits until all results are +# returned and puts them in an array, in the order the commands were +# sent. +sub _tell_imap2 { + my ($self, @cmd) = @_; + + my %results; + my @ids; + + RETRY2: { + @ids = (); + foreach (@cmd) { + push @ids, $self->_send_cmd($_); + redo RETRY2 if $self->_reconnect_if_needed; + } + } + + %results = (); + for (0..$#cmd) { + my $lineparts = []; + my $accumulator = []; + my $res; + while ($res = $self->_socket_getline) { + # print STDERR "2: $res"; + if ($res =~ /^\*/) { + push @$lineparts, $accumulator if @$accumulator; + $accumulator = []; + } + if ($res =~ /(.*)\{(\d+)\}\r\n/) { + my ($line, $len) = ($1, $2); + push @$accumulator, + $line, + $self->_read_literal($len); + } else { + my ($cmdid, $ok, $error) = $self->_cmd_ok2($res); + if (defined($ok)) { + $results{$cmdid} = [ $ok, $lineparts, $error ]; + last; + } else { + push @$accumulator, $res; + } + } + } + push @$lineparts, $accumulator if @$accumulator; + unless (defined $res) { + goto RETRY2 if $self->_reconnect_if_needed(1); + } + } + + my @ret = @results{@ids}; + return \@ret; +} + +sub _string_quote { + $_[0] =~ s/\\/\\\\/g; + $_[0] =~ s/\"/\\\"/g; + $_[0] = "\"$_[0]\""; +} + +sub _string_unquote { + if ($_[0] =~ s/^"//g) { + $_[0] =~ s/"$//g; + $_[0] =~ s/\\\"/\"/g; + $_[0] =~ s/\\\\/\\/g; + } +} + +##### parse imap response ##### +# +# This is probably the simplest/dumbest way to parse the IMAP output. +# Nevertheless it seems to be very stable and fast. +# +# $input is an array ref containing IMAP output. Normally it will +# contain only one entry -- a line of text -- but when IMAP sends +# literal data, we read it separately (see _read_literal) and store it +# as a scalar reference, therefore it can be like this: +# +# [ '* 11 FETCH (RFC822.TEXT ', \$DATA, ')' ] +# +# so that's why the routine looks a bit more complicated. +# +# It returns an array of tokens. Literal strings are dereferenced so +# for the above text, the output will be: +# +# [ '*', '11', 'FETCH', [ 'RFC822.TEXT', $DATA ] ] +# +# note that lists are represented as arrays. +# +sub _parse_tokens { + my ($input, $no_deref) = @_; + + my @tokens = (); + my @stack = (\@tokens); + + while (my $text = shift @$input) { + if (ref $text) { + push @{$stack[-1]}, ($no_deref ? $text : $$text); + next; + } + while (1) { + $text =~ m/\G\s+/gc; + if ($text =~ m/\G[([]/gc) { + my $sub = []; + push @{$stack[-1]}, $sub; + push @stack, $sub; + } elsif ($text =~ m/\G(BODY\[[a-zA-Z0-9._() -]*\])/gc) { + push @{$stack[-1]}, $1; # let's consider this an atom too + } elsif ($text =~ m/\G[])]/gc) { + pop @stack; + } elsif ($text =~ m/\G\"((?:\\.|[^\"\\])*)\"/gc) { + my $str = $1; + # unescape + $str =~ s/\\\"/\"/g; + $str =~ s/\\\\/\\/g; + push @{$stack[-1]}, $str; # found string + } elsif ($text =~ m/\G(\d+)/gc) { + push @{$stack[-1]}, $1 + 0; # found numeric + } elsif ($text =~ m/\G([a-zA-Z0-9_\$\\.+\/*&-]+)/gc) { + my $atom = $1; + if (lc $atom eq 'nil') { + $atom = undef; + } + push @{$stack[-1]}, $atom; # found atom + } else { + last; + } + } + } + + return \@tokens; +} + +sub _handle_notification { + my ($self, $tokens, $reverse) = @_; + + no warnings 'uninitialized'; + my $not; + + my $sf = $self->{selected_folder}; + if ($sf) { # otherwise we shouldn't get any notifications, but whatever + $sf = $self->{FOLDERS}{$sf}; + if ($tokens->[2] eq 'FETCH') { + my %data = @{$tokens->[3]}; + if (my $flags = $data{FLAGS}) { + $not = { seq => $tokens->[1] + 0, + flags => $flags }; + if (first { $_ eq '\\Deleted' } @$flags) { + --$sf->{messages}; + $not->{deleted} = 1; + } + if ($data{UID}) { + $not->{uid} = $data{UID}; + } + } + + } elsif ($tokens->[2] eq 'EXISTS') { + $sf->{messages} = $tokens->[1] + 0; + $not = { messages => $tokens->[1] + 0 }; + + } elsif ($tokens->[2] eq 'EXPUNGE') { + --$sf->{messages}; + $not = { seq => $tokens->[1] + 0, destroyed => 1 }; + + } elsif ($tokens->[2] eq 'RECENT') { + $sf->{recent} = $tokens->[1] + 0; + $not = { recent => $tokens->[1] + 0 }; + + } elsif ($tokens->[1] eq 'FLAGS') { + $sf->{flags} = $tokens->[2]; + $not = { flags => $tokens->[2] }; + + } elsif ($tokens->[1] eq 'OK') { + $sf->{sflags}{$tokens->[2][0]} = $tokens->[2][1]; + } + } + + if (defined $not) { + $not->{folder} = $self->{selected_folder}; + if ($reverse) { + unshift @{$self->{notifications}}, $not; + } else { + push @{$self->{notifications}}, $not; + } + return 1; + } + + return 0; +} + +1; + +__END__ + +=pod + +=encoding utf8 + +=head1 NAME + +Net::IMAP::Client - Not so simple IMAP client library + +=head1 SYNOPSIS + + use Net::IMAP::Client; + + my $imap = Net::IMAP::Client->new( + + server => 'mail.you.com', + user => 'USERID', + pass => 'PASSWORD', + ssl => 1, # (use SSL? default no) + ssl_verify_peer => 1, # (use ca to verify server, default yes) + ssl_ca_file => '/etc/ssl/certs/certa.pm', # (CA file used for verify server) or + # ssl_ca_path => '/etc/ssl/certs/', # (CA path used for SSL) + port => 993 # (but defaults are sane) + + ) or die "Could not connect to IMAP server"; + + # everything's useless if you can't login + $imap->login or + die('Login failed: ' . $imap->last_error); + + # let's see what this server knows (result cached on first call) + my $capab = $imap->capability; + # or + my $knows_sort = $imap->capability( qr/^sort/i ); + + # get list of folders + my @folders = $imap->folders; + + # get total # of messages, # of unseen messages etc. (fast!) + my $status = $imap->status(@folders); # hash ref! + + # select folder + $imap->select('INBOX'); + + # get folder hierarchy separator (cached at first call) + my $sep = $imap->separator; + + # fetch all message ids (as array reference) + my $messages = $imap->search('ALL'); + + # fetch all ID-s sorted by subject + my $messages = $imap->search('ALL', 'SUBJECT'); + # or + my $messages = $imap->search('ALL', [ 'SUBJECT' ]); + + # fetch ID-s that match criteria, sorted by subject and reverse date + my $messages = $imap->search({ + FROM => 'foo', + SUBJECT => 'bar', + }, [ 'SUBJECT', '^DATE' ]); + + # fetch message summaries (actually, a lot more) + my $summaries = $imap->get_summaries([ @msg_ids ]); + + foreach (@$summaries) { + print $_->uid, $_->subject, $_->date, $_->rfc822_size; + print join(', ', @{$_->from}); # etc. + } + + # fetch full message + my $data = $imap->get_rfc822_body($msg_id); + print $$data; # it's reference to a scalar + + # fetch full messages + my @msgs = $imap->get_rfc822_body([ @msg_ids ]); + print $$_ for (@msgs); + + # fetch single attachment (message part) + my $data = $imap->get_part_body($msg_id, '1.2'); + + # fetch multiple attachments at once + my $hash = $imap->get_parts_bodies($msg_id, [ '1.2', '1.3', '2.2' ]); + my $part1_2 = $hash->{'1.2'}; + my $part1_3 = $hash->{'1.3'}; + my $part2_2 = $hash->{'2.2'}; + print $$part1_2; # need to dereference it + + # copy messages between folders + $imap->select('INBOX'); + $imap->copy(\@msg_ids, 'Archive'); + + # delete messages ("Move to Trash") + $imap->copy(\@msg_ids, 'Trash'); + $imap->add_flags(\@msg_ids, '\\Deleted'); + $imap->expunge; + +=head1 DESCRIPTION + +Net::IMAP::Client provides methods to access an IMAP server. It aims +to provide a simple and clean API, while employing a rigorous parser +for IMAP responses in order to create Perl data structures from them. +The code is simple, clean and extensible. + +It started as an effort to improve L but then I +realized that I needed to change a lot of code and API so I started it +as a fresh module. Still, the design is influenced by +Net::IMAP::Simple and I even stole a few lines of code from it ;-) +(very few, honestly). + +This software was developed for creating a web-based email (IMAP) +client: www.xuheki.com. Xhueki uses Net::IMAP::Client. + +=head1 API REFERENCE + +Unless otherwise specified, if a method fails it returns I and +you can inspect the error by calling $imap->last_error. For a +successful call most methods will return a meaningful value but +definitely not I. + +=head2 new(%args) # constructor + + my $imap = Net::IMAP::Client->new(%args); + +Pass to the constructor a hash of arguments that can contain: + +=over + +=item - B (STRING) + +Host name or IP of the IMAP server. + +=item - B (STRING) + +User ID (I) + +=item - B (STRING) + +Password + +=item - B (BOOL, optional, default FALSE) + +Pass a true value if you want to use IO::Socket::SSL + +=item - B (BOOL, optional, default TRUE) + +Pass a false value if you do not want to use SSL CA to verify server + +only need when you set ssl to true + +=item - B (STRING, optional) + +Pass a file path which used as CA file to verify server + +at least one of ssl_ca_file and ssl_ca_path is needed for ssl verify + server + +=item -B (STRING, optional) + +Pass a dir which will be used as CA file search dir, found CA file +will be used to verify server + +On linux, by default is '/etc/ssl/certs/' + +at least one of ssl_ca_file and ssl_ca_path is needed for ssl verify + server + +=item - B (HASHREF, optional) + +Optional arguments to be passed to the L object. + +=item - B (BOOL, optional, default TRUE) + +Whether to use UID command (see RFC3501). Recommended. + +=item - B (IO::Handle, optional) + +If you already have a socket connected to the IMAP server, you can +pass it here. + +=back + +The B and B only need when you set +B to TRUE. + +If you havn't apply an B and B, on linux, +the B will use the value '/etc/ssl/certs/', on other +platform B will be disabled. + +The constructor doesn't login to the IMAP server -- you need to call +$imap->login for that. + +=head2 last_error + +Returns the last error from the IMAP server. + +=head2 login($user, $pass) + +Login to the IMAP server. You can pass $user and $pass here if you +wish; if not passed, the values used in constructor will be used. + +Returns I if login failed. + +=head2 logout / quit + +Send EXPUNGE and LOGOUT then close connection. C is an alias +for C. + +=head2 noop + +"Do nothing" method that calls the IMAP "NOOP" command. It returns a +true value upon success, I otherwise. + +This method fetches any notifications that the server might have for +us and you can get them by calling $imap->notifications. See the +L method. + +=head2 capability() / capability(qr/^SOMETHING/) + +With no arguments, returns an array of all capabilities advertised by +the server. If you're interested in a certain capability you can pass +a RegExp. E.g. to check if this server knows 'SORT', you can do this: + + if ($imap->capability(/^sort$/i)) { + # speaks it + } + +This data is cached, the server will be only hit once. + +=head2 select($folder) + +Selects the current IMAP folder. On success this method also records +some information about the selected folder in a hash stored in +$self->{FOLDERS}{$folder}. You might want to use Data::Dumper to find +out exactly what, but at the time of this writing this is: + +=over + +=item - B + +Total number of messages in this folder + +=item - B + +Flags available for this folder (as array ref) + +=item - B + +Total number of recent messages in this folder + +=item - B + +Various other flags here, such as PERMANENTFLAGS of UIDVALIDITY. You +might want to take a look at RFC3501 at this point. :-p + +=back + +This method is basically stolen from Net::IMAP::Simple. + +=head2 examine($folder) + +Selects the current IMAP folder in read-only (EXAMINE) mode. +Otherwise identical to select. + +=head2 status($folder), status(\@folders) + +Returns the status of the given folder(s). + +If passed an array ref, the return value is a hash ref mapping folder +name to folder status (which are hash references in turn). If passed +a single folder name, it returns the status of that folder only. + + my $inbox = $imap->status('INBOX'); + print $inbox->{UNSEEN}, $inbox->{MESSAGES}; + print Data::Dumper::Dumper($inbox); + + my $all = $imap->status($imap->folders); + while (my ($name, $status) = each %$all) { + print "$name : $status->{MESSAGES}/$status->{UNSEEN}\n"; + } + +This method is designed to be very fast when passed multiple folders. +It's I faster to call: + + $imap->status(\@folders); + +than: + + $imap->status($_) foreach (@folders); + +because it sends all the STATUS requests to the IMAP server before it +starts receiving the answers. In my tests with my remote IMAP server, +for 40 folders this method takes 0.6 seconds, compared to 6+ seconds +when called individually for each folder alone. + +=head2 separator + +Returns the folder hierarchy separator. This is provided as a result +of the following IMAP command: + + FETCH "" "*" + +I don't know of any way to change this value on a server so I have to +assume it's a constant. Therefore, this method caches the result and +it won't hit the server a second time on subsequent calls. + +=head2 folders + +Returns a list of all folders available on the server. In scalar +context it returns a reference to an array, i.e.: + + my @a = $imap->folders; + my $b = $imap->folders; + # now @a == @$b; + +=head2 folders_more + +Returns an hash reference containing more information about folders. +It maps folder name to an hash ref containing the following: + + - flags -- folder flags (array ref; i.e. [ '\\HasChildren' ]) + - sep -- one character containing folder hierarchy separator + - name -- folder name (same as the key -- thus redundant) + +=head2 namespace + +Returns an hash reference containing the namespaces for this server +(see RFC 2342). Since the RFC defines 3 possible types of namespaces, +the hash contains the following keys: + + - `personal' -- the personal namespace + - `other' -- "other users" namespace + - `shared' -- shared namespace + +Each one can be I if the server returned "NIL", or an array +reference. If an array reference, each element is in the form: + + { + sep => '.', + prefix => 'INBOX.' + } + +(I is the separator for this hierarchy, and I is the +prefix). + +=head2 seq_to_uid(@sequence_ids) + +I recommend usage of UID-s only (see L) but this isn't +always possible. Even when C is on, the server will +sometimes return notifications that only contain message sequence +numbers. To convert these to UID-s you can use this method. + +On success it returns an hash reference which maps sequence numbers to +message UID-s. Of course, on failure it returns I. + +=head2 search($criteria, $sort, $charset) + +Executes the "SEARCH" or "SORT" IMAP commands (depending on wether +$sort is I) and returns the results as an array reference +containing message ID-s. + +Note that if you use C<$sort> and the IMAP server doesn't have this +capability, this method will fail. Use L to investigate. + +=over + +=item - B<$criteria> + +Can be a string, in which case it is passed literally to the IMAP +command (which can be "SEARCH" or "SORT"). + +It can also be an hash reference, in which case keys => values are +collected into a string and values are properly quoted, i.e.: + + { subject => 'foo', + from => 'bar' } + +will translate to: + + 'SUBJECT "foo" FROM "bar"' + +which is a valid IMAP SEARCH query. + +If you want to retrieve all messages (no search criteria) then pass +'ALL' here. + +=item - B<$sort> + +Can be a string or an array reference. If it's an array, it will +simply be joined with a space, so for instance passing the following +is equivalent: + + 'SUBJECT DATE' + [ 'SUBJECT', 'DATE' ] + +The SORT command in IMAP allows you to prefix a sort criteria with +'REVERSE' which would mean descending sorting; this module will allow +you to prefix it with '^', so again, here are some equivalent +constructs: + + 'SUBJECT REVERSE DATE' + 'SUBJECT ^DATE' + [ 'SUBJECT', 'REVERSE', 'DATE' ] + [ 'subject', 'reverse date' ] + [ 'SUBJECT', '^DATE' ] + +It'll also uppercase whatever you passed here. + +If you omit $sort (or pass I) then this method will use the +SEARCH command. Otherwise it uses the SORT command. + +=item - B<$charset> + +The IMAP SORT recommendation [2] requires a charset declaration for +SORT, but not for SEARCH. Interesting, huh? + +Our module is a bit more paranoid and it will actually add charset for +both SORT and SEARCH. If $charset is omitted (or I) the it +will default to "UTF-8", which, supposedly, is supported by all IMAP +servers. + +=back + +=head2 get_rfc822_body($msg_id) + +Fetch and return the full RFC822 body of the message. B<$msg_id> can +be a scalar but also an array of ID-s. If it's an array, then all +bodies of those messages will be fetched and the return value will be +a list or an array reference (depending how you call it). + +Note that the actual data is returned as a reference to a scalar, to +speed things up. + +Examples: + + my $data = $imap->get_rfc822_body(10); + print $$data; # need to dereference it + + my @more = $imap->get_rfc822_body([ 11, 12, 13 ]); + print $$_ foreach @more; + + or + + my $more = $imap->get_rfc822_body([ 11, 12, 13 ]); + print $$_ foreach @$more; + +=head2 get_part_body($msg_id, $part_id) + +Fetches and returns the body of a certain part of the message. Part +ID-s look like '1' or '1.1' or '2.3.1' etc. (see RFC3501 [1], "FETCH +Command"). + +=head3 Scalar reference + +Note that again, this data is returned as a reference to a scalar +rather than the scalar itself. This decision was taken purely to save +some time passing around potentially large data from Perl subroutines. + +=head3 Undecoded + +One other thing to note is that the data is not decoded. One simple +way to decode it is use Email::MIME::Encodings, i.e.: + + use Email::MIME::Encodings; + my $summary = $imap->get_summaries(10)->[0]; + my $part = $summary->get_subpart('1.1'); + my $body = $imap->get_part_body('1.1'); + my $cte = $part->transfer_encoding; # Content-Transfer-Encoding + $body = Email::MIME::Encodings::decode($cte, $$body); + + # and now you should have the undecoded (perhaps binary) data. + +See get_summaries below. + +=head2 get_parts_bodies($msg_id, \@part_ids) + +Similar to get_part_body, but this method is capable to retrieve more +parts at once. It's of course faster than calling get_part_body for +each part alone. Returns an hash reference which maps part ID to part +body (the latter is a reference to a scalar containing the actual +data). Again, the data is not unencoded. + + my $parts = $imap->get_parts_bodies(10, [ '1.1', '1.2', '2.1' ]); + print ${$parts->{'1.1'}}; + +=head2 get_summaries($msg, $headers) / get_summaries(\@msgs, $headers) + +(C<$headers> is optional). + +Fetches, parses and returns "message summaries". $msg can be an array +ref, or a single id. The return value is always an array reference, +even if a single message is queried. + +If $headers is passed, it must be a string containing name(s) of the +header fields to fetch (space separated). Example: + + $imap->get_summaries([1, 2, 3], 'References X-Original-To') + +The result contains L objects. The +best way to understand the result is to actually call this function +and use Data::Dumper to see its structure. + +Following is the output for a pretty complicated message, which +contains an HTML part with an embedded image and an attached message. +The attached message in turn contains an HTML part and an embedded +message. + + bless( { + 'message_id' => '<48A71D17.1000109@foobar.com>', + 'date' => 'Sat, 16 Aug 2008 21:31:51 +0300', + 'to' => [ + bless( { + 'at_domain_list' => undef, + 'name' => undef, + 'mailbox' => 'kwlookup', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'cc' => undef, + 'from' => [ + bless( { + 'at_domain_list' => undef, + 'name' => 'Mihai Bazon', + 'mailbox' => 'justme', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'flags' => [ + '\\Seen', + 'NonJunk', + 'foo_bara' + ], + 'uid' => '11', + 'subject' => 'test with message attachment', + 'rfc822_size' => '12550', + 'in_reply_to' => undef, + 'bcc' => undef, + 'internaldate' => '16-Aug-2008 21:29:23 +0300', + 'reply_to' => [ + bless( { + 'at_domain_list' => undef, + 'name' => 'Mihai Bazon', + 'mailbox' => 'justme', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'sender' => [ + bless( { + 'at_domain_list' => undef, + 'name' => 'Mihai Bazon', + 'mailbox' => 'justme', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'parts' => [ + bless( { + 'part_id' => '1', + 'parts' => [ + bless( { + 'parameters' => { + 'charset' => 'UTF-8' + }, + 'subtype' => 'html', + 'part_id' => '1.1', + 'encoded_size' => '365', + 'cid' => undef, + 'type' => 'text', + 'description' => undef, + 'transfer_encoding' => '7bit' + }, 'Net::IMAP::Client::MsgSummary' ), + bless( { + 'disposition' => { + 'inline' => { + 'filename' => 'someimage.png' + } + }, + 'language' => undef, + 'encoded_size' => '4168', + 'description' => undef, + 'transfer_encoding' => 'base64', + 'parameters' => { + 'name' => 'someimage.png' + }, + 'subtype' => 'png', + 'part_id' => '1.2', + 'type' => 'image', + 'cid' => '', + 'md5' => undef + }, 'Net::IMAP::Client::MsgSummary' ) + ], + 'multipart_type' => 'related' + }, 'Net::IMAP::Client::MsgSummary' ), + bless( { + 'message_id' => '<48A530CE.3050807@foobar.com>', + 'date' => 'Fri, 15 Aug 2008 10:31:26 +0300', + 'encoded_size' => '6283', + 'to' => [ + bless( { + 'at_domain_list' => undef, + 'name' => undef, + 'mailbox' => 'kwlookup', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'subtype' => 'rfc822', + 'cc' => undef, + 'from' => [ + bless( { + 'at_domain_list' => undef, + 'name' => 'Mihai Bazon', + 'mailbox' => 'justme', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'subject' => 'Test with images', + 'in_reply_to' => undef, + 'description' => undef, + 'transfer_encoding' => '7bit', + 'parameters' => { + 'name' => 'Attached Message' + }, + 'bcc' => undef, + 'part_id' => '2', + 'sender' => [ + bless( { + 'at_domain_list' => undef, + 'name' => 'Mihai Bazon', + 'mailbox' => 'justme', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'reply_to' => [ + bless( { + 'at_domain_list' => undef, + 'name' => 'Mihai Bazon', + 'mailbox' => 'justme', + 'host' => 'foobar.com' + }, 'Net::IMAP::Client::MsgAddress' ) + ], + 'parts' => [ + bless( { + 'parameters' => { + 'charset' => 'UTF-8' + }, + 'subtype' => 'html', + 'part_id' => '2.1', + 'encoded_size' => '344', + 'cid' => undef, + 'type' => 'text', + 'description' => undef, + 'transfer_encoding' => '7bit' + }, 'Net::IMAP::Client::MsgSummary' ), + bless( { + 'disposition' => { + 'inline' => { + 'filename' => 'logo.png' + } + }, + 'language' => undef, + 'encoded_size' => '4578', + 'description' => undef, + 'transfer_encoding' => 'base64', + 'parameters' => { + 'name' => 'logo.png' + }, + 'subtype' => 'png', + 'part_id' => '2.2', + 'type' => 'image', + 'cid' => '', + 'md5' => undef + }, 'Net::IMAP::Client::MsgSummary' ) + ], + 'cid' => undef, + 'type' => 'message', + 'multipart_type' => 'related' + }, 'Net::IMAP::Client::MsgSummary' ) + ], + 'multipart_type' => 'mixed' + }, 'Net::IMAP::Client::MsgSummary' ); + +As you can see, the parser retrieves all data, including from the +embedded messages. + +There are many other modules you can use to fetch such information. +L and L are great. The only problem is +that you have to have fetched already the full (RFC822) body of the +message, which is impractical over IMAP. When you want to quickly +display a folder summary, the only practical way is to issue a FETCH +command and retrieve only those headers that you are interested in +(instead of full body). C does exactly that (issues a +FETCH (FLAGS INTERNALDATE RFC822.SIZE ENVELOPE BODYSTRUCTURE)). It's +acceptably fast even for huge folders. + +=head2 fetch($msg_id, $attributes) + +This is a low level interface to FETCH. It calls the imap FETCH +command and returns a somewhat parsed hash of the results. + +C<$msg_id> can be a single message ID or an array of IDs. If a single +ID is given, the return value will be a hash reference containing the +requested values. If C<$msg_id> is an array, even if it contains a +single it, then the return value will be an array of hashes. + +C<$attributes> is a string of attributes to FETCH, separated with a +space, or an array (ref) of attributes. + +Examples: + +# retrieve the UID of the most recent message + + my $last_uid = $imap->fetch('*', 'UID')->{UID}; + +# fetch the flags of the first message + + my $flags = $imap->fetch(1, 'FLAGS')->{FLAGS}; + +# fetch flags and some headers (Subject and From) + + my $headers = 'BODY[HEADER.FIELDS (Subject From)]'; + my $results = $imap->fetch([1, 2, 3], "FLAGS $headers"); + foreach my $hash (@$results) { + print join(" ", @{$hash->{FLAGS}}), "\n"; + print $hash->{$headers}, "\n"; + } + +=head2 notifications() + +The IMAP server may send various notifications upon execution of +commands. They are collected in an array which is returned by this +method (returns an array ref in scalar context, or a list otherwise). +It clears the notifications queue so on second call it will return an +empty array (unless new notifications were collected in the meantime). + +Each element in this array (notification) is a hash reference +containing one or more or the following: + + - seq : the *sequence number* of the changed message + - uid : UID of the changed message (NOT ALWAYS available!) + - flags : new flags for this message + - deleted : when the \Deleted flag was set for this message + - messages : new number of messages in this folder + - recent : number of recent messages in this folder + - flags : new flags of this folder (seq is missing) + - destroyed : when this message was expunged + - folder : the name of the selected folder + +C is always present. C is present when a message was +changed some flags (in which case you have C) or was expunged +(in which case C is true). When C were changed and +the B<\Deleted> flag is present, you also get C true. + +C is a message sequence number. Pretty dumb, I think it's +preferable to work with UID-s, but that's what the IMAP server +reports. In some cases the UID I be readily available (i.e. my +IMAP server sends notifications in the same body as a response to, +say, a FETCH BODY command), but when it's not, you have to rely on +seq_to_uid(). B that when C is true, the message has +been B; there is no way in this case to retrieve the UID so +you have to rely solely on C in order to update your caches. + +When C is present but no C, it means that the list of +available flags for the C has changed. + +You get C upon an "EXISTS" notification, which usually means +"you have new mail". It indicates the total number of messages in the +folder, not just "new" messages. I've yet to come up with a good way +to measure the number of new/unseen messages, other than calling +C. + +I rarely got C from my IMAP server in my tests; if more +clients are simultaneously logged in as the same IMAP user, only one +of them will receive "RECENT" notifications; others will have to rely +on "EXISTS" to tell when new messages have arrived. Therefore I can +only say that "RECENT" is useless and I advise you to ignore it. + +=head2 append($folder, \$rfc822, $flags, $date) + +Appends a message to the given C<$folder>. You must pass the full +RFC822 body in C<$rfc822>. C<$flags> and C<$date> are optional. If +you pass C<$flags>, it must be an array of strings specifying the +initial flags of the appended message. If I, the message will +be appended with an empty flag set, which amongst other things means +that it will be regarded as an C<\Unseen> message. + +C<$date> specifies the INTERNALDATE of the appended messge. If +I it will default to the current date/time. B this +functionality is not tested; C<$date> should be in a format understood +by IMAP. + +=head2 get_flags($msg_id) / get_flags(\@msg_ids) + +Returns the flags of one or more messages. The return value is an +array (reference) if one message ID was passed, or a hash reference if +an array (of one or more) message ID-s was passed. + +When an array was passed, the returned hash will map each message UID +to an array of flags. + +=head2 store($msg, $flag) / store(\@msgs, \@flags) + +Resets FLAGS of the given message(s) to the given flag(s). C<$msg> +can be an array of ID-s (or UID-s), or a single (U)ID. C<$flags> can +be a single string, or an array reference as well. + +Note that the folder where these messages reside must have been +already selected. + +Examples: + + $imap->store(10, '\\Seen'); + $imap->store([11, 12], '\\Deleted'); + $imap->store(13, [ '\\Seen', '\\Answered' ]); + +The IMAP specification defines certain reserved flags (they all start +with a backslash). For example, a message with the flag C<\Deleted> +should be regarded as deleted and will be permanently discarded by an +EXPUNGE command. Although, it is possible to "undelete" a message by +removing this flag. + +The following reserved flags are defined by the IMAP spec: + + \Seen + \Answered + \Flagged + \Deleted + \Draft + \Recent + +The C<\Recent> flag is considered "read-only" -- you cannot add or +remove it manually; the server itself will do this as appropriate. + +=head2 add_flags($msg, $flag) / add_flags(\@msgs, \@flags) + +Like store() but it doesn't reset all flags -- it just specifies which +flags to B to the message. + +=head2 del_flags($msg, $flag) / del_flags(\@msgs, \@flags) + +Like store() / add_flags() but it B flags. + +=head2 delete_message($msg) / delete_message(\@msgs) + +Stores the \Deleted flag on the given message(s). Equivalent to: + + $imap->add_flags(\@msgs, '\\Deleted'); + +=head2 expunge() + +Permanently removes messages that have the C<\Deleted> flag set from +the current folder. + +=head2 copy($msg, $folder) / copy(\@msg_ids, $folder) + +Copies message(s) from the selected folder to the given C<$folder>. +You can pass a single message ID, or an array of message ID-s. + +=head2 create_folder($folder) + +Creates the folder with the given name. + +=head2 delete_folder($folder) + +Deletes the folder with the given name. This works a bit different +from the IMAP specs. The IMAP specs says that any subfolders should +remain intact. This method actually deletes subfolders recursively. +Most of the time, this is What You Want. + +Note that all messages in C<$folder>, as well as in any subfolders, +are permanently lost. + +=head2 get_threads($algorithm, $msg_id) + +Returns a "threaded view" of the current folder. Both arguments are +optional. + +C<$algorithm> should be I, "REFERENCES" or "SUBJECT". If +undefined, "REFERENCES" is assumed. This selects the threading +algorithm, as per IMAP THREAD AND SORT extensions specification. I +only tested "REFERENCES". + +C<$msg_id> can be undefined, or a message ID. If it's undefined, then +a threaded view of the whole folder will be returned. If you pass a +message ID, then this method will return the top-level thread that +contains the message. + +The return value is an array which actually represents threads. +Elements of this array are message ID-s, or other arrays (which in +turn contain message ID-s or other arrays, etc.). The first element +in an array will represent the start of the thread. Subsequent +elements are child messages or subthreads. + +An example should help (FIXME). + +=head1 TODO + +=over + +=item - authentication schemes other than plain text (B) + +=item - better error handling? + +=back + +=head1 SEE ALSO + +L, L, L + +L, L + +RFC3501 [1] is a must read if you want to do anything fancier than +what this module already supports. + +=head1 REFERENCES + +[1] http://ietfreport.isoc.org/rfc/rfc3501.txt + +[2] http://ietfreport.isoc.org/all-ids/draft-ietf-imapext-sort-20.txt + +=head1 AUTHOR + +Mihai Bazon, + http://www.xuheki.com/ + http://www.dynarchlib.com/ + http://www.bazon.net/mishoo/ + +=head1 COPYRIGHT + +Copyright (c) Mihai Bazon 2008. All rights reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 DISCLAIMER OF WARRANTY + +BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT +WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER +PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, +EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE +TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + +=cut diff --git a/lib/lib/Net/IMAP/Client/MsgAddress.pm b/lib/lib/Net/IMAP/Client/MsgAddress.pm new file mode 100644 index 0000000..0998646 --- /dev/null +++ b/lib/lib/Net/IMAP/Client/MsgAddress.pm @@ -0,0 +1,140 @@ +package Net::IMAP::Client::MsgAddress; + +use Encode (); + +sub new { + my ($class, $struct) = @_; + my $self = { + name => $struct->[0], + at_domain_list => $struct->[1], + mailbox => $struct->[2], + host => $struct->[3], + }; + bless $self, $class; +} + +sub _decode { + my ($str) = @_; + if (defined($str)) { + eval { $str = Encode::decode('MIME-Header', $str); }; + } + return $str; +} + +use overload q("") => \&as_string; + +sub name { _decode($_[0]->{name}) } +sub at_domain_list { _decode($_[0]->{at_domain_list}) } +sub mailbox { _decode($_[0]->{mailbox}) } +sub host { _decode($_[0]->{host}) } + +sub email { + my ($self) = @_; + return $self->mailbox . '@' . $self->host; +} + +sub as_string { + my ($self) = @_; + my $str; + if (($str = $self->name)) { + $str .= ' <' . $self->email . '>'; + } else { + $str = $self->email; + } + return $str; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Net::IMAP::Client::MsgAddress + +=head1 DESCRIPTION + +Represents one email address as returned in an ENVELOPE part of the +FETCH command. + +When used in string context, this object magically translates to +S<"Full Name Eemail@address.comE">. + +=head1 METHODS + +=head2 C # constructor + +Creates a new object from the given array. + +=over + +=item name + +Returns the full name, if any + +=item at_domain_list + +Returns the "at_domain_list" part (WTF is that?) + +=item mailbox + +Returns the mailbox name (i.e. the 'email' part in the example above). + +=item host + +Returns the host name (i.e. the 'address.com' part). + +=item email + +Returns the full email address: C<$self->{mailbox} . '@' . $self->{host}>. + +=item as_string + +Used by stringification. It returns the full name and email address +as in S<"Full Name Eemail@address.comE">. + +=back + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Mihai Bazon, + http://www.dynarchlib.com/ + http://www.bazon.net/mishoo/ + +=head1 COPYRIGHT + +Copyright (c) Mihai Bazon 2008. All rights reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 DISCLAIMER OF WARRANTY + +BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT +WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER +PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, +EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE +TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + +=cut diff --git a/lib/lib/Net/IMAP/Client/MsgSummary.pm b/lib/lib/Net/IMAP/Client/MsgSummary.pm new file mode 100644 index 0000000..0baad42 --- /dev/null +++ b/lib/lib/Net/IMAP/Client/MsgSummary.pm @@ -0,0 +1,593 @@ +package Net::IMAP::Client::MsgSummary; + +use Encode (); +use Net::IMAP::Client::MsgAddress (); + +sub new { + my ($class, $data, $part_id, $has_headers) = @_; + + bless my $self = {}, $class; + + if ($part_id) { + $self->{part_id} = $part_id; + } + + my $tmp = $data->{BODY}; + if ($tmp) { + $self->_parse_body($tmp); + } + + $tmp = $data->{BODYSTRUCTURE}; + if ($tmp) { + $self->_parse_bodystructure($tmp); + } + + $tmp = $data->{ENVELOPE}; + if ($tmp) { + $self->_parse_envelope($tmp); + } + + $self->{flags} = $data->{FLAGS}; + $self->{internaldate} = $data->{INTERNALDATE}; + $self->{rfc822_size} = $data->{'RFC822.SIZE'}; + $self->{uid} = $data->{UID}; + + if ($has_headers) { + while (my ($key, $val) = each %$data) { + if ($key =~ /^body(?:\.peek)?\s*\[\s*header\.fields/i) { + $self->{headers} = $val; + last; + } + } + } + + return $self; +} + +sub _decode { + my ($str) = @_; + if (defined($str)) { + eval { $str = Encode::decode('MIME-Header', $str); }; + } + return $str; +} + +sub type { $_[0]->{type} } + +sub subtype { $_[0]->{subtype} } + +sub parameters { $_[0]->{parameters} } + +sub cid { $_[0]->{cid} } + +sub description { _decode($_[0]->{description}) } + +sub transfer_encoding { $_[0]->{transfer_encoding} } + +sub encoded_size { $_[0]->{encoded_size} } + +sub content_type { + my ($self) = @_; + if ($self->type) { + return $self->type . '/' . $self->subtype; + } + if ($self->multipart) { + return 'multipart/' . $self->multipart; + } + return undef; +} + +sub charset { $_[0]->{parameters}->{charset} } + +sub filename { + my ($self) = @_; + my $disp = $self->{disposition}; + my $filename; + if ($disp) { + while (my ($key, $val) = each %$disp) { + if (ref($val) eq 'HASH') { + $filename = $val->{filename}; + last if $filename; + } + } + } + unless ($filename) { + $filename = $_[0]->{parameters}->{name}; + } + return _decode($filename); +} + +sub name { _decode($_[0]->{parameters}->{name}) } + +sub multipart { $_[0]->{multipart_type} } + +sub parts { $_[0]->{parts} } + +sub rfc822_size { $_[0]->{rfc822_size} } + +sub internaldate { $_[0]->{internaldate} } + +sub flags { $_[0]->{flags} } + +sub uid { $_[0]->{uid} } + +sub part_id { $_[0]->{part_id } } + +sub md5 { $_[0]->{md5} } + +sub disposition { $_[0]->{disposition} } + +sub language { $_[0]->{language} } + +# envelope + +sub date { $_[0]->{date} } + +sub subject { _decode($_[0]->{subject}) } + +sub from { $_[0]->{from} } + +sub sender { $_[0]->{sender} } + +sub reply_to { $_[0]->{reply_to} } + +sub to { $_[0]->{to} } + +sub cc { $_[0]->{cc} } + +sub bcc { $_[0]->{bcc} } + +sub in_reply_to { $_[0]->{in_reply_to} } + +sub message_id { $_[0]->{message_id} } + +sub seq_id { $_[0]->{seq_id} } + +sub headers { $_[0]->{headers} } + +# utils + +sub get_subpart { + my ($self, $part) = @_; + foreach my $index (split(/\./, $part)) { + $self = $self->parts->[$index - 1]; + } + return $self; +} + +my %MT_HAS_ATTACHMENT = ( mixed => 1 ); + +sub has_attachments { + my ($self) = @_; + my $mt = $self->multipart; + return $mt && $MT_HAS_ATTACHMENT{$mt} ? 1 : 0; +} + +sub is_message { $_[0]->content_type eq 'message/rfc822' } + +sub message { $_[0]->{message} } + +sub _parse_body { + my ($self, $struct) = @_; + + if (ref($struct->[0]) eq 'ARRAY') { + my @tmp = @$struct; + my $multipart = pop @tmp; + my $part_id = $self->{part_id} || ''; + $part_id .= '.' + if $part_id; + my $i = 0; + @tmp = map { __PACKAGE__->new({ BODY => $_}, $part_id . ++$i) } @tmp; + $self->{multipart_type} = lc $multipart; + $self->{parts} = \@tmp; + } else { + $self->{type} = lc $struct->[0]; + $self->{subtype} = lc $struct->[1]; + if ($struct->[2]) { + my %tmp = @{$struct->[2]}; + $self->{parameters} = \%tmp; + } + $self->{cid} = $struct->[3]; + $self->{description} = $struct->[4]; + $self->{transfer_encoding} = $struct->[5]; + $self->{encoded_size} = $struct->[6]; + + if ($self->is_message && $struct->[7] && $struct->[8]) { + # continue parsing attached message + $self->{message} = __PACKAGE__->new({ + ENVELOPE => $struct->[7], + BODY => $struct->[8], + }); + } + } +} + +sub _parse_bodystructure { + my ($self, $struct) = @_; + + if (ref($struct->[0]) eq 'ARRAY') { + my $multipart; + my @tmp; + foreach (@$struct) { + if (ref($_) eq 'ARRAY') { + push @tmp, $_; + } else { + $multipart = $_; + last; # XXX: ignoring the rest (extension data) for now. + } + } + my $part_id = $self->{part_id} || ''; + $part_id .= '.' + if $part_id; + my $i = 0; + @tmp = map { __PACKAGE__->new({ BODYSTRUCTURE => $_}, $part_id . ++$i) } @tmp; + $self->{multipart_type} = lc $multipart; + $self->{parts} = \@tmp; + } else { + $self->{type} = lc $struct->[0]; + $self->{subtype} = lc $struct->[1]; + my $a = $struct->[2]; + if ($a) { + __lc_key_in_array($a); + my %tmp = @$a; + $self->{parameters} = \%tmp; + } + $self->{cid} = $struct->[3]; + $self->{description} = $struct->[4]; + $self->{transfer_encoding} = $struct->[5]; + $self->{encoded_size} = $struct->[6]; + + if ($self->is_message && $struct->[7] && $struct->[8]) { + # continue parsing attached message + $self->{message} = __PACKAGE__->new({ + ENVELOPE => $struct->[7], + BODYSTRUCTURE => $struct->[8], + }); + } elsif ($self->type ne 'text') { + $self->{md5} = $struct->[7]; + my $a = $struct->[8]; + if ($a) { + for (my $i = 0; $i < @$a; ++$i) { + $a->[$i] = lc $a->[$i]; + ++$i; + if (ref($a->[$i]) eq 'ARRAY') { + __lc_key_in_array($a->[$i]); + my %foo = @{ $a->[$i] }; + $a->[$i] = \%foo; + } + } + my %tmp = @$a; + $self->{disposition} = \%tmp; + } + $self->{language} = $struct->[9]; + } + } +} + +sub __lc_key_in_array { + my ($a) = @_; + for (my $i = 0; $i < @$a; $i += 2) { + $a->[$i] = lc $a->[$i]; + } +} + +sub _parse_envelope { + my ($self, $struct) = @_; + $self->{date} = $struct->[0]; + $self->{subject} = $struct->[1]; + $self->{from} = _parse_address($struct->[2]); + $self->{sender} = _parse_address($struct->[3]); + $self->{reply_to} = _parse_address($struct->[4]); + $self->{to} = _parse_address($struct->[5]); + $self->{cc} = _parse_address($struct->[6]); + $self->{bcc} = _parse_address($struct->[7]); + $self->{in_reply_to} = $struct->[8]; + $self->{message_id} = $struct->[9]; +} + +sub _parse_address { + my ($adr) = @_; + if ($adr) { + $adr = [ map { Net::IMAP::Client::MsgAddress->new($_) } @$adr ]; + } + return $adr; +} + +1; + +__END__ + +=pod + +=head1 NAME + +Net::IMAP::Client::MsgSummary - parse message (+ subparts) summary info + +=head1 SYNOPSIS + +This object is created internally in Net::IMAP::Client->get_summaries. +You shouldn't need to instantiate it directly. You can skip the +SYNOPSIS, these notes are intended for developers. + + my $imap = Net::IMAP::Client->new( ... ) + $imap->select('INBOX'); + + # retrieve FETCH lines + my ($ok, $lines) = $imap->_tell_imap(FETCH => "$msg_id FULL"); + die 'FETCH failed: ' . $imap->last_error + unless $ok; + + # build parsed tokens + my @tokens = map { Net::IMAP::Client::_parse_tokens($_) } @$lines; + + # they look like this: + [ '*', 'MSGID', 'FETCH', + [ 'FLAGS', [ '\\Seen', '\\Answered' ], + 'INTERNALDATE', '13-Aug-2008 14:43:50 +0300', + 'RFC822.SIZE', '867', + 'ENVELOPE', [ + ... + ] + ... + ] + +Basically it's the IMAP response parsed into a Perl structure (array +of tokens). FIXME: this stuff should be documented in +Net::IMAP::Client. + + # make summaries + my @summaries = map { + my $tokens = $_->[3]; + my %hash = @$tokens; + Net::IMAP::Client::MsgSummary->new(\%hash); + } @tokens; + + my $summary = shift @summaries; + + print $summary->subject; + print $summary->from->[0]; + +=head1 DESCRIPTION + +This object can represent a message or a message part. For example, +for a message containing attachments you will be able to call parts() +in order to fetch parsed Net::IMAP::Client::MsgSummary objects for +each part. Each part in turn may contain other subparts! For +example, if a part is of type C then its C +method will return it's subparts, if any. + +There's a distinction between a message and a message part, although +we use the same object to represent both. A message will have +additional information, fetched from its ENVELOPE (i.e. C, +C, C, C, etc.). For a part only, this information +will be missing. + +If all this sounds confusing, you might want to use Data::Dumper to +inspect the structure of a complex message. See also the +documentation of L's get_summaries method for an +example. + +=head1 API REFERENCE + +It contains only accessors that return data as retrieved by the FETCH +command. Parts that may be MIME-word encoded are automatically +undecoded. + +=head2 C # constructor + +Parses/creates a new object from the given FETCH data. + +=over + +=item C + +Returns the base MIME type (i.e. 'text') + +=item C + +Returns the subtype (i.e. 'plain') + +=item C + +Returns any parameters passed in BODY(STRUCTURE). You shouldn't need +this. + +=item C + +Returns the part's unique identifier (CID). + +=item C + +Returns the part's description (usually I). + +=item C + +Returns the part's content transfer encoding. You'll need this in +order to decode binary parts. + +=item C + +Returns the size of the encoded part. This is actually the size in +octets that will be downloaded from the IMAP server if you fetch this +part only. + +=item C + +Shortcut for C<$self->type . '/' .$self->subtype>. + +=item C + +Returns the charset declaration for this part. + +=item C + +Returns the name of this part, if found in FETCH response. + +=item C + +Returns the file name of this part, if found in FETCH response. If +there's no filename it will try C. + +=item C + +Returns the multipart type (i.e. 'mixed', 'alternative') + +=item C + +Returns the subparts of this part. + +=item C + +Returns the "id" (path) of this part starting from the toplevel +message, i.e. "2.1" (meaning that this is the first subpart of the +second subpart of the toplevel message). + +=item C + +Returns a MD5 of this part or I if not present. + +=item C + +Returns the disposition of this part (I if not present). It's +a hash actually that looks like this: + + { inline => { filename => 'foobar.png' } } + +=item C + +Returns the language of this part or I if not present. + +=item C + +Returns the size of the full message body. + +=item C + +Returns the INTERNALDATE of this message. + +=item C + +Returns the flags of this message. + +=item C + +Returns the UID of this message. + +=item C + +Returns the sequence number of this message, if it has been retrieved! + +=item C + +Returns the date of this message (from the Date header). + +=item C + +Returns the subject of this message. + +=item C, C, C, C, C, C + +Returns an array of Net::IMAP::Client::MsgAddress objects containing +the respective addresses. Note that sometimes this array can be +empty! + +=item C + +Returns the ID of the "parent" message (to which this one has been +replied). This is NOT the "UID" of the message! + +=item C + +Returns the ID of this message (from the Message-ID header). + +=item C ($path) + +Returns the subpart of this message identified by $path, which is in +form '1.2' etc. Returns undef if no such path was found. + +Here's a possible message structure: + + - Container (multipart/mixed) has no path ID; it's the toplevel + message. It contains the following subparts: + + 1 multipart/related + 1.1 text/html + 1.2 image/png (embedded in HTML) + + 2 message/rfc822 (decoded type is actually multipart/related) + 2.1 text/html + 2.2 image/png (also embedded) + +C called on the container will return the respective +Net::IMAP::Client::MsgSummary part, i.e. get_subpart('2.1') will +return the text/html part of the attached message. + +=item C + +Tries to determine if this message has attachments. For now this +checks if the multipart type is 'mixed', which isn't really accurate. + +=item C + +Returns true if this object represents a message (i.e. has +content_type eq 'message/rfc822'). Note that it won't return true for +the toplevel part, but you B that that part represents a +message. ;-) + +=item C + +Returns the attached rfc822 message + +=item C + +Returns (unparsed, as plain text) additional message headers if they +were fetched by get_summaries. You can use L to parse +them. + +=back + +=head1 TODO + +Fix C + +=head1 SEE ALSO + +L, L + +=head1 AUTHOR + +Mihai Bazon, + http://www.dynarchlib.com/ + http://www.bazon.net/mishoo/ + +=head1 COPYRIGHT + +Copyright (c) Mihai Bazon 2008. All rights reserved. + +This module is free software; you can redistribute it and/or modify it +under the same terms as Perl itself. + +=head1 DISCLAIMER OF WARRANTY + +BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT +WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER +PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, +EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. + +IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE +TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + +=cut diff --git a/lib/lib/Net/SMTPS.pm b/lib/lib/Net/SMTPS.pm new file mode 100644 index 0000000..72b427c --- /dev/null +++ b/lib/lib/Net/SMTPS.pm @@ -0,0 +1,284 @@ +# ==== +# SSL/STARTTLS extention for G.Barr's Net::SMTP. +# plus, enable arbitrary SMTP auth mechanism selection. +# IO::Socket::SSL (also Net::SSLeay openssl), +# Authen::SASL, MIME::Base64 should be installed. +# +package Net::SMTPS; + +use vars qw ( $VERSION @ISA ); + +$VERSION = '0.09'; + +use strict; +use base qw ( Net::SMTP ); +use Net::Cmd; # import CMD_OK, CMD_MORE, ... +use Net::Config; + +eval { + require IO::Socket::IP + and unshift @ISA, 'IO::Socket::IP'; +} or eval { + require IO::Socket::INET6 + and unshift @ISA, 'IO::Socket::INET6'; +} or do { + require IO::Socket::INET + and unshift @ISA, 'IO::Socket::INET'; +}; + +# Override to support SSL/TLS. +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 $ssl = delete $arg{doSSL}; + if ($ssl =~ /ssl/i) { + $arg{Port} ||= 465; + } + + my $hosts = defined $host ? $host : $NetConfig{smtp_hosts}; + my $obj; + + # eliminate IO::Socket::SSL from @ISA for multiple call of new. + @ISA = grep { !/IO::Socket::SSL/ } @ISA; + + my %_args = map { +"$_" => $arg{$_} } grep {! /^SSL/} keys %arg; + + my $h; + $_args{PeerPort} = $_args{Port} || 'smtp(25)'; + $_args{Proto} = 'tcp'; + $_args{Timeout} = defined $_args{Timeout} ? $_args{Timeout} : 120; + + foreach $h (@{ref($hosts) ? $hosts : [$hosts]}) { + $_args{PeerAddr} = ($host = $h); + + #if ($_args{Debug}) { + # foreach my $i (keys %_args) { + # print STDERR "$type>>> arg $i: $_args{$i}\n"; + # } + #} + + $obj = $type->SUPER::new( + %_args + ) + and last; + } + + return undef + unless defined $obj; + + $obj->autoflush(1); + + $obj->debug(exists $arg{Debug} ? $arg{Debug} : undef); + + ${*$obj}{'net_smtp_arg'} = \%arg; + +# OverSSL + if (defined($ssl) && $ssl =~ /ssl/i) { + $obj->ssl_start() + or do { + $obj->set_status(500, ["Cannot start SSL"]); + $obj->close; + return undef; + }; + } + + unless ($obj->response() == CMD_OK) { + $obj->close(); + return undef; + } + + ${*$obj}{'net_smtp_exact_addr'} = $arg{ExactAddresses}; + ${*$obj}{'net_smtp_host'} = $host; + + (${*$obj}{'net_smtp_banner'}) = $obj->message; + (${*$obj}{'net_smtp_domain'}) = $obj->message =~ /\A\s*(\S+)/; + + unless ($obj->hello($arg{Hello} || "")) { + $obj->close(); + return undef; + } + +# STARTTLS + if (defined($ssl) && $ssl =~ /starttls/i && defined($obj->supports('STARTTLS')) ) { + #123006 $obj->supports('STARTTLS') returns '' issue. + unless ($obj->starttls()) { + return undef; + } + $obj->hello($arg{Hello} || ""); + } + + $obj; +} + +sub ssl_start { + my $self = shift; + my $type = ref($self); + my %arg = %{ ${*$self}{'net_smtp_arg'} }; + my %ssl_args = map { +"$_" => $arg{$_} } grep {/^SSL/} keys %arg; + + eval { + require IO::Socket::SSL; + } or do { + $self->set_status(500, ["Need working IO::Socket::SSL"]); + $self->close; + return undef; + }; + + my $ssl_debug = (exists $arg{Debug} ? $arg{Debug} : undef); + $ssl_debug = (exists $arg{Debug_SSL} ? $arg{Debug_SSL} : $ssl_debug); + + local $IO::Socket::SSL::DEBUG = $ssl_debug; + + (unshift @ISA, 'IO::Socket::SSL' + and IO::Socket::SSL->start_SSL($self, %ssl_args, @_) + and $self->isa('IO::Socket::SSL') + and bless $self, $type # re-bless 'cause IO::Socket::SSL blesses himself. + ) or return undef; +} + +sub starttls { + my $self = shift; + ( + $self->_STARTTLS() + and $self->ssl_start(@_) + ) or do { + $self->set_status(500, ["Cannot start SSL session"]); + $self->close(); + return undef; + }; +} + + +# Override to specify a certain auth mechanism. +sub auth { + my ($self, $username, $password, $mech) = @_; + + if ($mech) { + $self->debug_print(1, "AUTH-my favorite: ". $mech . "\n") if $self->debug; + + my @cl_mech = split /\s+/, $mech; + my @matched = (); + if (exists ${*$self}{'net_smtp_esmtp'}->{'AUTH'}) { + my $sv = ${*$self}{'net_smtp_esmtp'}->{'AUTH'}; + $self->debug_print(1, "AUTH-server offerred: ". $sv . "\n") if $self->debug; + + foreach my $i (@cl_mech) { + if (index($sv, $i) >= 0 && grep(/$i/i, @matched) == () ) { + push @matched, uc($i); + } + } + } + if (@matched) { + ## override AUTH mech as specified. + ## if multiple mechs are specified, priority is still up to Authen::SASL module. + ${*$self}{'net_smtp_esmtp'}->{'AUTH'} = join " ", @matched; + $self->debug_print(1, "AUTH-negotiated: ". ${*$self}{'net_smtp_esmtp'}->{'AUTH'} . "\n") if $self->debug; + } + } + $self->SUPER::auth($username, $password); +} + + +# Fix #121006 no timeout issue. +sub getline { + my $self = shift; + $self->Net::Cmd::getline(@_); +} + +sub _STARTTLS { shift->command("STARTTLS")->response() == CMD_OK } + +1; + +__END__ + +=head1 NAME + +Net::SMTPS - SSL/STARTTLS support for Net::SMTP + +=head1 SYNOPSYS + + use Net::SMTPS; + + my $ssl = 'starttls'; # 'ssl' / 'starttls' / undef + + my $smtp = Net::SMTPS->new("smtp.example.com", Port => 587, doSSL => $ssl); + +=head1 DESCRIPTION + +This module implements a wrapper for Net::SMTP, enabling over-SSL/STARTTLS support. +This module inherits most of all the methods from Net::SMTP(2.X). You may use all +the friendly options that came bundled with Net::SMTP. +You can control the SSL usage with the options of new() constructor method. +'doSSL' option is the switch, and, If you would like to control detailed SSL settings, +you can set SSL_* options that are brought from IO::Socket::SSL. Please see the +document of IO::Socket::SSL about these options detail. + +Just one method difference from the Net::SMTP, you can select SMTP AUTH mechanism +as the third option of auth() method. + +As of Version 3.10 of Net::SMTP(libnet) includes SSL/STARTTLS capabilities, so +this wrapper module's significance disappareing. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HOST ] [, OPTIONS ] ) + +A few options added to Net::SMTP(2.X). + +B { C | C | undef } - to specify SSL connection type. +C makes connection wrapped with SSL, C uses SMTP command C. + +=back + +=head1 METHODS + +Most of all methods of Net::SMTP are inherited as is, except auth(). + + +=over 4 + +=item auth ( USERNAME, PASSWORD [, AUTHMETHOD]) + +Attempt SASL authentication through Authen::SASL module. AUTHMETHOD is your required +method of authentication, like 'CRAM-MD5', 'LOGIN', ... etc. If your selection does +not match the server-offerred AUTH mechanism, authentication negotiation may fail. + +=item starttls ( SSLARGS ) + +Upgrade existing plain connection to SSL. + +=back + +=head1 BUGS + +Constructor option 'Debug => (N)' (for Net::Cmd) also sets $IO::Socket::SSL::DEBUG when SSL is enabled. You can set 'Debug_SSL => {0-3}' separately. + + +=head1 SEE ALSO + +L, +L, +L + +=head1 AUTHOR + +Tomo.M + +=head1 COPYRIGHT + +Copyright (c) 2017 Tomo.M All rights reserved. +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/lib/Net/SSH2.pm b/lib/lib/Net/SSH2.pm new file mode 100644 index 0000000..4764c2b --- /dev/null +++ b/lib/lib/Net/SSH2.pm @@ -0,0 +1,1487 @@ +package Net::SSH2; + +our $VERSION = '0.69'; + +use 5.006; +use strict; +use warnings; +use warnings::register; +use Carp; + +require Net::SSH2::Constants; + +use Socket; +use IO::File; +use File::Basename; +use Errno; + +# load IO::Socket::IP when available, otherwise fallback to IO::Socket::INET. + +my $socket_class = do { + local ($SIG{__DIE__}, $SIG{__WARN__}, $@, $!); + eval { + require IO::Socket::IP; + 'IO::Socket::IP'; + } +} || do { + require IO::Socket::INET; + 'IO::Socket::INET' +}; + +# methods + +sub new { + my ($class, %opts) = @_; + my $self = $class->_new; + + for (qw(trace timeout debug)) { + $self->$_($opts{$_}) if defined $opts{$_} + } + $self->flag(COMPRESS => $opts{compress}) + if defined $opts{compress} and (version())[1] >= 0x10500; + $self->flag(SIGPIPE => $opts{sigpipe}) + if defined $opts{sigpipe}; + + return $self; +} + +sub die_with_error { + my $self = shift; + if (my ($code, $name, $string) = $self->error) { + croak join(": ", @_, "$string ($code $name)"); + } + else { + croak join(": ", @_, "no libssh2 error registered"); + } +} + +sub method { + my $self = shift; + my $method_type = shift; + $self->_method($method_type => (@_ ? join(',', @_) : ())); +} + +my $connect_opts_warned; +my $connect_fd_warned; +my $connect_void_warned; +sub connect { + my $self = shift; + defined $_[0] or croak "Net::SSH2::connect: hostname argument is undefined"; + + # try to connect, or get a file descriptor + my ($fd, $sock); + if (@_ == 1) { + $sock = shift; + if ($sock =~ /^\d{1,10}$/) { + $connect_fd_warned++ or + warnings::warnif($self, "Passing a file descriptor number to connect is deprecated"); + $fd = $sock; + } elsif(ref $sock) { + # handled below + } else { + @_ = ($sock, 'ssh'); + } + } + + my %opts = (@_ > 2 ? splice(@_, 2) : ()); + if (%opts) { + $connect_opts_warned++ or + warnings::warnif($self, "Passing options to connect is deprecated"); + $self->timeout(1000 * $opts{Timeout}) if $opts{Timeout}; + if ($opts{Compress} and + ($self->version)[1] >= 0x10500) { + $self->flag(COMPRESS => 1); + } + } + + my ($hostname, $port); + if (@_ == 2) { + ($hostname, $port) = @_; + if (not defined $port) { + $port = getservbyname('ssh', 'tcp') || 22; + } + elsif ($port =~ /\D/) { + $port = getservbyname($port, 'tcp'); + unless (defined $port) { + $self->_set_error(LIBSSH2_ERROR_SOCKET_NONE(), "Unable to resolve TCP service name $_[1]"); + goto error; + } + } + + my $timeout = $self->timeout; + $sock = $socket_class->new( PeerHost => $hostname, + PeerPort => $port, + Blocking => $self->blocking, + (defined($timeout) ? (Timeout => 0.001 * $timeout) : ()) ); + unless ($sock) { + $self->_set_error(LIBSSH2_ERROR_SOCKET_NONE(), "Unable to connect to remote host: $!"); + goto error; + } + $sock->sockopt(SO_LINGER, pack('SS', 0, 0)); + } + + # get a file descriptor + unless (defined $fd) { + $fd = fileno($sock); + unless (defined $fd) { + $self->_set_error(LIBSSH2_ERROR_SOCKET_NONE(), "Unable to get file descriptor from socket: $!"); + goto error; + } + } + + if ($^O eq 'MSWin32') { + require Win32API::File; + $fd = Win32API::File::FdGetOsFHandle($fd); + } + + { + local ($@, $SIG{__DIE__}); + $port = eval { $sock->peerport } || 22 + unless defined $port; + $hostname = eval { $sock->peername } + unless defined $hostname; + } + + # pass it in, do protocol + return $self->_startup($fd, $sock, $hostname, $port); + + error: + unless (defined wantarray) { + unless ($connect_void_warned++) { + local $!; + warnings::warnif($self, "Calling connect in void context is deprecated"); + } + croak "Net::SSH2: failed to connect to ". join(':', grep defined, @_[0,1]) .": $!"; + } + return; +} + +sub _auth_methods { + return { + 'agent' => { + ssh => 'publickey', + method => \&auth_agent, + params => [qw(_fallback username)], + }, + 'hostbased' => { + ssh => 'hostbased', + method => \&auth_hostbased, + params => [qw(username publickey privatekey + hostname local_username? passphrase?)], + }, + 'publickey' => { + ssh => 'publickey', + method => \&auth_publickey, + params => [qw(username publickey? privatekey passphrase?)], + }, + 'keyboard' => { + ssh => 'keyboard-interactive', + method => \&auth_keyboard, + params => [qw(_interact _fallback username cb_keyboard?)] + }, + 'keyboard-auto' => { + ssh => 'keyboard-interactive', + method => \&auth_keyboard, + params => [qw(username password)], + }, + 'password' => { + ssh => 'password', + method => \&auth_password, + params => [qw(username password cb_password?)], + }, + 'password-interact' => { + ssh => 'password', + method => \&auth_password_interact, + params => [qw(_interact _fallback username cb_password?)], + }, + 'none' => { + ssh => 'none', + method => \&auth_password, + params => [qw(username)], + }, + }; +} + +my @rank_default = qw(hostbased publickey keyboard-auto password agent keyboard password-interact none); + +sub _auth_rank { + my ($self, $rank) = @_; + $rank ||= \@rank_default; + my $libver = ($self->version)[1] || 0; + return @$rank if $libver > 0x010203; + return grep { $_ ne 'agent' } @$rank; +} + +sub _local_user { + for (qw(USER LOGNAME)) { + return $ENV{$_} if defined $ENV{$_} + } + + local ($@, $SIG{__DIE__}, $SIG{__WARN__}); + + my $u = eval { getlogin }; + return $u if defined $u; + + eval { getpwuid $< } +} + +my $password_when_you_mean_passphrase_warned; +sub auth { + my ($self, %p) = @_; + + $self->_set_error(LIBSSH2_ERROR_AUTHENTICATION_FAILED(), + "Authentication failed"); # default error + + $p{username} = _local_user unless defined $p{username}; + + my @rank = $self->_auth_rank(delete $p{rank}); + my $remote_rank; + $remote_rank = { map { $_ => 1 } $self->auth_list($p{username}) } + if defined $p{username}; + + # if fallback is set, interact with the user even when a password + # is given + $p{fallback} = 1 unless defined $p{password} or defined $p{passphrase}; + + TYPE: for(my $i = 0; $i < @rank; $i++) { + my $type = $rank[$i]; + my $data = $self->_auth_methods->{$type}; + unless ($data) { + carp "unknown authentication method '$type'"; + next; + } + next if $remote_rank and !$remote_rank->{$data->{ssh}}; + + # do we have the required parameters? + my @pass; + for my $param(@{$data->{params}}) { + my $p = $param; + my $opt = $p =~ s/\?$//; + my $pseudo = $p =~ s/^_//; + + if ($p eq 'passphrase' and not exists $p{$p} and defined $p{password}) { + $p = 'password'; + $password_when_you_mean_passphrase_warned++ + or carp "Using the key 'password' to refer to a passphrase is deprecated. Use 'passphrase' instead"; + } + + if ($pseudo) { + next TYPE unless $p{$p}; + } + else { + next TYPE unless $opt or defined $p{$p}; + push @pass, $p{$p}; # if it's optional, store undef + } + } + + # invoke the authentication method + return $type if $data->{method}->($self, @pass) and $self->auth_ok; + } + + return 'none' if $self->auth_ok; + return; # failure +} + +my $term_readkey_unavailable_warned; +my $term_readkey_loaded; +sub _load_term_readkey { + return 1 if $term_readkey_loaded ||= do { + local ($@, $!, $SIG{__DIE__}, $SIG{__WARN__}); + eval { require Term::ReadKey; 1 } + }; + + carp "Unable to load Term::ReadKey, will not ask for passwords at the console!" + unless $term_readkey_unavailable_warned++; + return; +} + +sub _print_stderr { + my $self = shift; + my $ofh = select STDERR; local $|= 1; select $ofh; + print STDERR $_ for @_; +} + +sub _ask_user { + my ($self, $prompt, $echo) = @_; + my $timeout; + if (($self->version)[1] >= 0x10209) { + $timeout = $self->timeout || 0; + $timeout = ($timeout + 999) / 1000; + } + _load_term_readkey or return; + $self->_print_stderr($prompt); + Term::ReadKey::ReadMode('noecho') unless $echo; + my $reply = Term::ReadKey::ReadLine($timeout); + Term::ReadKey::ReadMode('normal') unless $echo; + $self->_print_stderr("\n") + unless $echo and defined $reply; + if (defined $reply) { + chomp $reply + } + else { + $self->_set_error(LIBSSH2_ERROR_SOCKET_TIMEOUT(), + "Timeout waiting for user response!"); + } + return $reply; +} + +sub auth_password_interact { + my ($self, $username, $cb) = @_; + _load_term_readkey or return; + my $rc; + for (0..2) { + my $password = $self->_ask_user("${username}'s password? ", 0); + $rc = $self->auth_password($username, $password, $cb); + last if $rc or $self->error != LIBSSH2_ERROR_AUTHENTICATION_FAILED(); + my $ofh = select STDERR; local $|= 1; select $ofh; + $self->_print_stderr("Password authentication failed!\n"); + } + return $rc; +} + +sub _local_home { + return $ENV{HOME} if defined $ENV{HOME}; + local ($@, $SIG{__DIE__}, $SIG{__WARN__}); + my $home = eval { (getpwuid($<))[7] }; + return $home; +} + +my $check_hostkey_void_ctx_warned; +sub check_hostkey { + my ($self, $policy, $path, $comment) = @_; + + defined wantarray or $check_hostkey_void_ctx_warned++ or + warnings::warnif($self, "Calling check_hostkey in void context is useless"); + + my $cb; + if (not defined $policy) { + $policy = LIBSSH2_HOSTKEY_POLICY_STRICT(); + } + elsif (ref $policy eq 'CODE') { + $cb = $policy; + } + else { + $policy = _parse_constant(HOSTKEY_POLICY => $policy); + } + + my $hostname = $self->hostname; + croak("hostname unknown: in order to use check_hostkey the peer host name ". + "must be given (or discoverable) at connect time") + unless defined $hostname; + + unless (defined $path) { + my $home = _local_home; + unless (defined $home) { + $self->_set_error(LIBSSH2_ERROR_FILE(), "Unable to determine known_hosts location"); + return; + } + require File::Spec; + $path = File::Spec->catfile($home, '.ssh', 'known_hosts'); + } + + my ($check, $key, $type, $flags); + my $kh = $self->known_hosts; + if ($kh and defined $kh->readfile($path)) { + + ($key, $type) = $self->remote_hostkey; + $flags = ( LIBSSH2_KNOWNHOST_TYPE_PLAIN() | + LIBSSH2_KNOWNHOST_KEYENC_RAW() | + (($type + 1) << LIBSSH2_KNOWNHOST_KEY_SHIFT()) ); + + $check = $kh->check($hostname, $self->port, $key, $flags); + $check == LIBSSH2_KNOWNHOST_CHECK_MATCH() and return "00"; + } + else { + $check = LIBSSH2_KNOWNHOST_CHECK_FAILURE(); + } + + if ($cb) { + my $ok = $cb->($self, $check, $comment); + $ok or $self->_set_error(LIBSSH2_ERROR_KNOWN_HOSTS(), 'Host key verification failed'); + return $ok; + } + + return $check + if $policy == LIBSSH2_HOSTKEY_POLICY_ADVISORY(); # user doesn't care! + + if ($check == LIBSSH2_KNOWNHOST_CHECK_NOTFOUND()) { + $self->_set_error(LIBSSH2_ERROR_KNOWN_HOSTS(), 'Unable to verify host key, host not found'); + unless ($policy == LIBSSH2_HOSTKEY_POLICY_TOFU()) { + if ($policy == LIBSSH2_HOSTKEY_POLICY_ASK()) { + my $fp = unpack 'H*', $self->hostkey_hash(LIBSSH2_HOSTKEY_HASH_SHA1()); + my $yes = $self->_ask_user("The authenticity of host '$hostname' can't be established.\n" . + "Key fingerprint is SHA1:$fp.\n" . + "Are you sure you want to continue connecting (yes/no)? ", 1); + unless ($yes =~ /^y(es)?$/i) { + $self->_set_error(LIBSSH2_ERROR_KNOWN_HOSTS(), 'Host key verification failed: user did not accept the key'); + return undef; + } + } + } + + $comment = '(Net::SSH2)' unless defined $comment; + # we ignore errors here, that is the usual SSH client behaviour + $kh->add($hostname, $self->port, $key, $comment, $flags) and + $kh->writefile($path); + + return $check; + } + + $self->_set_error(LIBSSH2_ERROR_KNOWN_HOSTS(), 'Host key verification failed: '. + ( ($check == LIBSSH2_KNOWNHOST_CHECK_NOTFOUND()) + ? "key not found in '$path'" + : "unable to perform the check")); + return undef; +} + +sub scp_get { + my ($self, $remote, $path) = @_; + $path = basename $remote if not defined $path; + + my %stat; + $self->blocking(1); + my $chan = $self->_scp_get($remote, \%stat) or return; + + # read and commit blocks until we're finished + my $file; + if (ref $path) { + $file = $path; + } + else { + my $mode = $stat{mode} & 0777; + $file = IO::File->new($path, O_WRONLY | O_CREAT | O_TRUNC, $mode); + unless ($file) { + $self->_set_error(LIBSSH2_ERROR_FILE(), "Unable to open local file: $!"); + return; + } + binmode $file; + } + + my $size = $stat{size}; + while ($size > 0) { + my $bytes_read = $chan->read(my($buf), (($size > 40000 ? 40000 : $size))); + if ($bytes_read) { + $size -= $bytes_read; + while (length $buf) { + my $bytes_written = $file->syswrite($buf, length $buf); + if ($bytes_written) { + substr $buf, 0, $bytes_written, ''; + } + elsif ($! != Errno::EAGAIN() && + $! != Errno::EINTR()) { + $self->_set_error(LIBSSH2_ERROR_FILE(), "Unable to write to local file: $!"); + return; + } + } + } + elsif (!defined($bytes_read) and + $self->error != LIBSSH2_ERROR_EAGAIN()) { + return; + } + } + + # process SCP acknowledgment and send same + $chan->read(my $eof, 1); + $chan->write("\0"); + return 1; +} + +sub scp_put { + my ($self, $path, $remote) = @_; + $remote = basename $path if not defined $remote; + + my $file; + if (ref $path) { + $file = $path; + } + else { + $file = IO::File->new($path, O_RDONLY); + unless ($file) { + $self->_set_error(LIBSSH2_ERROR_FILE(), "Unable to open local file: $!"); + return; + } + binmode $file; + } + + my @stat = $file->stat; + unless (@stat) { + $self->_set_error(LIBSSH2_ERROR_FILE(), "Unable to stat local file: $!"); + return; + } + + my $mode = $stat[2] & 0777; # mask off extras such as S_IFREG + $self->blocking(1); + my $chan = $self->_scp_put($remote, $mode, @stat[7, 8, 9]) or return; + + # read and transmit blocks until we're finished + my $size = $stat[7]; + while ($size > 0) { + my $bytes_read = $file->sysread(my($buf), ($size > 32768 ? 32768 : $size)); + if ($bytes_read) { + $size -= $bytes_read; + while (length $buf) { + my $bytes_written = $chan->write($buf); + if (defined $bytes_written) { + substr($buf, 0, $bytes_written, ''); + } + elsif ($chan->error != LIBSSH2_ERROR_EAGAIN()) { + return; + } + } + } + elsif (defined $bytes_read) { + $self->_set_error(LIBSSH2_ERROR_FILE(), "Unexpected end of local file"); + return; + } + elsif ($! != Errno::EAGAIN() and + $! != Errno::EINTR()) { + $self->_set_error(LIBSSH2_ERROR_FILE(), "Unable to read local file: $!"); + return; + } + } + + # send/receive SCP acknowledgement + $chan->write("\0"); + return $chan->read(my($eof), 1) || undef; +} + +my %Event; + +sub _init_poll { + for my $event(qw( + pollin pollpri pollext pollout pollerr pollhup pollnval pollex + session_closed channel_closed listener_closed + )) { + no strict 'refs'; + my $name = 'LIBSSH2_POLLFD_'.uc($event); + (my $_event = $event) =~ s/^poll//; + $Event{$_event} = &$name; + } +} + +sub poll { + my ($self, $timeout, $event) = @_; + $timeout ||= 0; + + # map incoming event structure (files to handles, events to integers) + my @event; + for my $in (@$event) { + my ($handle, $events) = @{$in}{qw(handle events)}; + $handle = fileno $handle + unless ref $handle and ref($handle) =~ /^Net::SSH2::/; + my $out = { handle => $handle, events => 0 }; + $events = [$events] if not ref $events and $events =~ /^\D+$/; + if (UNIVERSAL::isa($events, 'ARRAY')) { + for my $name(@$events) { + my $value = $Event{$name}; + croak "Net::SSH2::poll: can't translate event '$name'" + unless defined $value; + $out->{events} |= $value; + } + } else { + $out->{events} = $events || 0; + } + push @event, $out; + } + + my $count = $self->_poll($timeout, \@event); + return if not defined $count; + + # map received event structure (bitmask to hash of flags) + my $i = 0; + for my $item(@event) { + my $revents = $item->{revents}; + my $out = $event->[$i++]->{revents} = { value => $revents }; + my $found = 0; # can't mask off values, since there are dupes + while (my ($name, $value) = each %Event) { + $out->{$name} = 1, $found |= $value if $revents & $value; + } + $out->{unknown} = $revents & ~$found if $revents & ~$found; + } + $count +} + +sub _cb_kbdint_response_default { + my ($self, $user, $name, $instr, @prompt) = @_; + _load_term_readkey or return; + + my $prompt = "[user $user] "; + $prompt .= "$name\n" if $name; + $prompt .= "$instr\n" if $instr; + $prompt =~ s/ $/\n/; + $self->_print_stderr($prompt); + + return map $self->_ask_user($_->{text}, $_->{echo}), @prompt; +} + +my $hostkey_warned; +sub hostkey { + $hostkey_warned++ or carp "Net::SSH2 'hostkey' method is obsolete, use 'hostkey_hash' instead"; + shift->hostkey_hash(@_); +} + +sub auth_list { + my $auth = shift->_auth_list(@_); + return unless defined $auth; + wantarray ? split(/,/, $auth) : $auth +} + +# mechanics + +sub AUTOLOAD { + # This AUTOLOAD is used to 'autoload' constants from the constant() + # XS function. + + my $constname; + our $AUTOLOAD; + ($constname = $AUTOLOAD) =~ s/.*:://; + croak "&Net::SSH2::constant not defined" if $constname eq 'constant'; + my ($error, $val) = constant($constname); + if ($error) { croak $error; } + { + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + } + goto &$AUTOLOAD; +} + +require XSLoader; +XSLoader::load('Net::SSH2', $VERSION); + +_init_poll(); + +require Net::SSH2::Channel; +require Net::SSH2::SFTP; +require Net::SSH2::File; +require Net::SSH2::Listener; +require Net::SSH2::KnownHosts; + +1; +__END__ + +=head1 NAME + +Net::SSH2 - Support for the SSH 2 protocol via libssh2. + +=head1 SYNOPSIS + + use Net::SSH2; + + my $ssh2 = Net::SSH2->new(); + + $ssh2->connect('example.com') or $ssh2->die_with_error; + + $ssh->check_hostkey('ask') or $ssh2->die_with_error; + + if ($ssh2->auth_keyboard('fizban')) { + my $chan = $ssh2->channel(); + $chan->exec('program'); + + my $sftp = $ssh2->sftp(); + my $fh = $sftp->open('/etc/passwd') or $sftp->die_with_error; + print $_ while <$fh>; + } + +=head1 DESCRIPTION + +Net::SSH2 is a Perl interface to the libssh2 +(L) library. It supports the SSH2 protocol +(there is no support for SSH1) with all of the key exchanges, ciphers, +and compression of libssh2. + +Even if the module can be compiled and linked against very old +versions of the library, nothing below 1.5.0 should really be used +(older versions were quite buggy and unreliable) and version 1.7.0 or +later is recommended. + +=head2 Error handling + +Unless otherwise indicated, methods return a true value on success and +C on failure; use the L method to get extended error +information. + +B: methods in Net::SSH2 not backed by libssh2 functions +(i.e. L or L related methods) require +libssh2 1.7.0 or later in order to set the error state. That means +that after any of those methods fails, L would not return the +real code but just some bogus result when an older version of the +library is used. + +=head2 Typical usage + +The typical usage order is as follows: + +=over 4 + +=item 1 + +Create the SSH2 object calling L. + +=item 2 + +Configure the session if required. For instance, enabling compression +or picking some specific encryption methods. + +=item 3 + +Establish the SSH connection calling the method L. + +=item 4 + +Check the remote host public key calling L. + +=item 5 + +Authenticate calling the required L. + +=item 6 + +Call L and related methods to create new bidirectional +communication channels over the SSH connection. + +=item 7 + +Close the connection letting the Net::SSH2 object go out of scope or +calling L explicitly. + +=back + +=head1 CONSTANTS + +All the constants defined in libssh2 can be imported from +Net::SSH2. + +For instance: + + use Net::SSH2 qw(LIBSSH2_CHANNEL_EXTENDED_DATA_MERGE + LIBSSH2_CHANNEL_FLUSH_ALL + LIBSSH2_HOSTKEY_POLICY_ASK); + +Though note that most methods accept the uncommon part of the +constant name as a string. For instance the following two method calls +are equivalent: + + $channel->ext_data(LIBSSH2_CHANNEL_EXTENDED_DATA_MERGE); + $channel->ext_data('merge'); + +Tags can be used to import the following constant subsets: + + callback channel error socket trace hash method + disconnect policy fx fxf sftp + +The tag C can also be used to import all of them. + +=head1 METHODS + +=head2 new ( %options ) + +Create new Net::SSH2 object representing a SSH session. + +The accepted options are as follows: + +=over 4 + +=item timeout + +Sets the default timeout in milliseconds. See L. + +=item trace + +Sets tracing. See L. + +Example: + + my $ssh2 = Net::SSH2->new(trace => -1); + +Note that tracing requires a version of libssh2 compiled with debugging support. + +=item debug + +Enable debugging. See L. + +=item compress + +Sets flag C. See L. + +=item sigpipe + +Sets flag C. See L. + +=back + +=head2 banner ( text ) + +Set the SSH2 banner text sent to the remote host (prepends required "SSH-2.0-"). + +=head2 version + +In scalar context, returns libssh2 version/patch e.g. 0.18 or "0.18.0-20071110". +In list context, returns that version plus the numeric version (major, minor, +and patch, each encoded as 8 bits, e.g. 0x001200 for version 0.18) and the +default banner text (e.g. "SSH-2.0-libssh2_0.18.0-20071110"). + +=head2 error + +Returns the last error code. In list context, +returns (code, error name, error string). + +Note that the returned error value is only meaningful after some other +method indicates an error by returning false. + +=head2 die_with_error ( [message] ) + +Calls C with the given message and the error information from the +object appended. + +For instance: + + $ssh2->connect("ajhkfhdklfjhklsjhd", 22) + or $ssh2->die_with_error; + # dies as: + # Unable to connect to remote host: Invalid argument (-1 LIBSSH2_ERROR_SOCKET_NONE) + +=head2 sock + +Returns a reference to the underlying L object (usually a +derived class as L or L), or +C if not yet connected. + +=head2 trace + +Calls C with supplied bitmask. In order to enable all +tracing pass C<-1> as follows: + + $ssh2->trace(-1); + +A version of libssh2 compiled with tracing support is required. + +=head2 timeout ( timeout_ms ) + +Enables a global timeout (in milliseconds) which will affect every +action (requires libssh2 1.2.9 or later). + +By default, or if you set the timeout to zero, Net::SSH2 has no +timeout. + +Note that timeout errors may leave the SSH connection in an +inconsistent state and further operations may fail or behave +incorrectly. Actually, some methods are able to recover after a +timeout error and others are not. + +I + +=head2 method ( type [, values... ] ) + +Sets or gets a method preference. For get, pass in the type only; to +set, pass in either a list of values or a comma-separated +string. Values can only be queried after the session is connected. + +The following methods can be set or queried: + +=over 4 + +=item LIBSSH2_METHOD_KEX + +Key exchange method names. Supported values: + +=over 4 + +=item diffie-hellman-group1-sha1 + +Diffie-Hellman key exchange with SHA-1 as hash, and Oakley Group 2 (see RFC +2409). + +=item diffie-hellman-group14-sha1 + +Diffie-Hellman key exchange with SHA-1 as hash, and Oakley Group 14 (see RFC +3526). + +=item diffie-hellman-group-exchange-sha1 + +Diffie-Hellman key exchange with SHA-1 as hash, using a safe-prime/generator +pair (chosen by server) of arbitrary strength (specified by client) (see IETF +draft secsh-dh-group-exchange). + +=back + +=item LIBSSH2_METHOD_HOSTKEY + +Public key algorithms. Supported values: + +=over 4 + +=item ssh-dss + +Based on the Digital Signature Standard (FIPS-186-2). + +=item ssh-rsa + +Based on PKCS#1 (RFC 3447). + +=back + +=item LIBSSH2_METHOD_CRYPT_CS + +Encryption algorithm from client to server. Supported algorithms: + +=over 4 + +=item aes256-cbc + +AES in CBC mode, with 256-bit key. + +=item rijndael-cbc@lysator.liu.se + +Alias for aes256-cbc. + +=item aes192-cbc + +AES in CBC mode, with 192-bit key. + +=item aes128-cbc + +AES in CBC mode, with 128-bit key. + +=item blowfish-cbc + +Blowfish in CBC mode. + +=item arcfour + +ARCFOUR stream cipher. + +=item cast128-cbc + +CAST-128 in CBC mode. + +=item 3des-cbc + +Three-key 3DES in CBC mode. + +=item none + +No encryption. + +=back + +=item LIBSSH2_METHOD_CRYPT_SC + +Encryption algorithm from server to client. See the +C entry above for supported algorithms. + +=item LIBSSH2_METHOD_MAC_CS + +Message Authentication Code (MAC) algorithms from client to server. Supported +values: + +=over 4 + +=item hmac-sha1 + +SHA-1 with 20-byte digest and key length. + +=item hmac-sha1-96 + +SHA-1 with 20-byte key length and 12-byte digest length. + +=item hmac-md5 + +MD5 with 16-byte digest and key length. + +=item hmac-md5-96 + +MD5 with 16-byte key length and 12-byte digest length. + +=item hmac-ripemd160 + +RIPEMD-160 algorithm with 20-byte digest length. + +=item hmac-ripemd160@openssh.com + +Alias for hmac-ripemd160. + +=item none + +No encryption. + +=back + +=item LIBSSH2_METHOD_MAC_SC + +Message Authentication Code (MAC) algorithms from server to client. See +L for supported algorithms. + +=item LIBSSH2_METHOD_COMP_CS + +Compression methods from client to server. Supported values: + +=over 4 + +=item zlib + +The "zlib" compression method as described in RFC 1950 and RFC 1951. + +=item none + +No compression + +=back + +=item LIBSSH2_METHOD_COMP_SC + +Compression methods from server to client. See +L for supported compression methods. + +=back + +=head2 connect ( handle | host [, port]) + +The argument combinations accepted are as follows: + +=over 4 + +=item a glob or C object reference + +Note that tied file handles are not acceptable. The underlying +libssh2 requires real file handles. + +=item host [, port] + +In order to handle IPv6 addresses the optional module +L is required. + +The port number defaults to 22. + +=back + +This method used to accept a C argument. That feature has +been replaced by the constructor C option but note that it +takes milliseconds instead of seconds! + +=head2 disconnect ( [description [, reason [, language]]] ) + +Sends a clean disconnect message to the remote server. Default values are empty +strings for description and language, and C for +the reason. + +=head2 hostname + +The name of the remote host given at connect time or retrieved from +the TCP layer. + +=head2 port + +The port number of the remote SSH server. + +=head2 hostkey_hash ( hash type ) + +Returns a hash of the host key; note that the key is raw data and may contain +nulls or control characters. + +The type may be as follows: + +=over 4 + +=item LIBSSH2_HOSTKEY_HASH_MD5 + +MD5 hash, 16 bytes long (requires libssh2 compiled with MD5 support). + +=item LIBSSH2_HOSTKEY_HASH_SHA1 + +SHA1 hash, 20 bytes long. + +=back + +Note: in previous versions of the module this method was called +C. + +=head2 remote_hostkey + +Returns the public key from the remote host and its type which is one of +C, C, or +C. + +=head2 check_hostkey( [policy, [known_hosts_path [, comment] ] ] ) + +Looks for the remote host key inside the given known host file +(defaults to C<~/.ssh/known_hosts>). + +On success, this method returns the result of the call done under the +hood to C +(i.e. C, +C, +C or +C). + +On failure it returns C. + +The accepted policies are as follows: + +=over 4 + +=item LIBSSH2_HOSTKEY_POLICY_STRICT + +Only host keys already present in the known hosts file are accepted. + +This is the default policy. + +=item LIBSSH2_HOSTKEY_POLICY_ASK + +If the host key is not present in the known hosts file, the user is +asked if it should be accepted or not. + +If accepted, the key is added to the known host file with the given +comment. + +=item LIBSSH2_HOSTKEY_POLICY_TOFU + +Trust On First Use: if the host key is not present in the known hosts +file, it is added there and accepted. + +=item LIBSSH2_HOSTKEY_POLICY_ADVISORY + +The key is always accepted, but it is never saved into the known host +file. + +=item callback + +If a reference to a subroutine is given, it is called when the key is +not present in the known hosts file or a different key is found. The +arguments passed to the callback are the session object, the matching +error (C, +C or +C) and the comment. + +=back + +=head2 auth_list ( [username] ) + +Returns the authentication methods accepted by the server. In scalar +context the methods are returned as a comma separated string. + +When the server accepted an unauthenticated session for the given +username, this method returns C but L returns true. + +=head2 auth_ok + +Returns true when the session is authenticated. + +=head2 auth_password ( username [, password [, callback ]] ) + +Authenticates using a password. + +If the password has expired, if a callback code reference was given, it's +called as C and should return a password. If +no callback is provided, LIBSSH2_ERROR_PASSWORD_EXPIRED is returned. + +=head2 auth_password_interact ( username [, callback]) + +Prompts the user for the password interactively (requires +L). + +=head2 auth_publickey ( username, publickey_path, privatekey_path [, passphrase ] ) + +Authenticate using the given private key and an optional passphrase. + +When libssh2 is compiled using OpenSSL as the crypto backend, passing +this method C as the public key argument is acceptable (OpenSSL +is able to extract the public key from the private one). + +=head2 auth_publickey_frommemory ( username, publickey_blob, privatekey_blob [, passphrase ] ) + +Authenticate using the given public/private key and an optional +passphrase. The keys must be PEM encoded (requires libssh2 1.6.0 or +later with the OpenSSL backend). + +=head2 auth_hostbased ( username, publickey, privatekey, hostname, + [, local username [, passphrase ]] ) + +Host-based authentication using an optional passphrase. The local username +defaults to be the same as the remote username. + +=head2 auth_keyboard ( username, password | callback ) + +Authenticate using C. Takes either a password, +or a callback code reference which is invoked as +C(self, username, name, instruction, prompt...)> (where +each prompt is a hash with C and C keys, signifying the +prompt text and whether the user input should be echoed, respectively) +which should return an array of responses. + +If only a username is provided, the default callback will handle standard +interactive responses (requires L) + +=head2 auth_agent ( username ) + +Try to authenticate using an SSH agent (requires libssh2 1.2.3). + +=head2 auth ( ... ) + +This is a general, prioritizing authentication mechanism that can use +any of the previous methods. You provide it some parameters and +(optionally) a ranked list of methods you want considered (defaults to +all). It will remove any unsupported methods or methods for which it +doesn't have parameters (e.g. if you don't give it a public key, it +can't use publickey or hostkey), and try the rest, returning whichever +one succeeded or C if they all failed. If a parameter is passed +with an C value, a default value will be supplied if possible. + +The parameters are: + +=over 4 + +=item rank + +An optional ranked list of methods to try. The names should be the +names of the L C methods, e.g. C or +C, with the addition of C for automated +C and C which prompts the +user for the password interactively. + +=item username + +=item password + +=item publickey + +=item privatekey + +C and C are file paths. + +=item passphrase + +=item hostname + +=item local_username + +=item interact + +If this option is set to a true value, interactive methods will be enabled. + +=item fallback + +If a password is given but authentication using it fails, the module +will fall back to ask the user for another password if this +parameter is set to a true value. + +=item cb_keyboard + +L callback. + +=item cb_password + +L callback. + +=back + +For historical reasons and in order to maintain backward compatibility +with older versions of the module, when the C argument is +given, it is also used as the passphrase (and a deprecation warning +generated). + +In order to avoid that behaviour the C argument must be +also passed (it could be C). For instance: + + $ssh2->auth(username => $user, + privatekey => $privatekey_path, + publickey => $publickey_path, + password => $password, + passphrase => undef); + +This work around will be removed in a not too distant future version +of the module. + +=head2 flag (key, value) + +Sets the given session flag. + +The currently supported flag values are: + +=over 4 + +=item LIBSSH2_FLAG_COMPRESS + +If set before the connection negotiation is performed, compression +will be negotiated for this connection. + +Compression can also be enabled passing option C to the +constructor L. + +=item LIBSSH2_FLAG_SIGPIPE + +if set, Net::SSH2/libssh2 will not attempt to block SIGPIPEs but will +let them trigger from the underlying socket layer. + +=back + +=head2 keepalive_config(want_reply, interval) + +Set how often keepalive messages should be sent. + +C indicates whether the keepalive messages should request +a response from the server. C is number of seconds that can +pass without any I/O. + +=head2 keepalive_send + +Send a keepalive message if needed. + +On failure returns undef. On success returns how many seconds you can +sleep after this call before you need to call it again. + +Note that the underlying libssh2 function C +can not recover from EAGAIN errors. If this method fails with such +error, the SSH connection may become corrupted. + +The usage of this function is discouraged. + +=head2 channel ( [type, [window size, [packet size]]] ) + +Creates and returns a new channel object. See L. + +Type, if given, must be C (a reminiscence of an old, more +generic, but never working wrapping). + +=head2 tcpip ( host, port [, shost, sport ] ) + +Creates a TCP connection from the remote host to the given host:port, +returning a new channel. + +The C and C arguments are merely informative and passed +to the remote SSH server as the origin of the connection. They default +to 127.0.0.1:22. + +Note that this method does B open a new port on the local machine +and forwards incoming connections to the remote side. + +=head2 listen ( port [, host [, bound port [, queue size ]]] ) + +Sets up a TCP listening port on the remote host. Host defaults to 0.0.0.0; +if bound port is provided, it should be a scalar reference in which the bound +port is returned. Queue size specifies the maximum number of queued connections +allowed before the server refuses new connections. + +Returns a new Net::SSH2::Listener object. + +=head2 scp_get ( remote_path [, local_path ] ) + +Retrieve a file with SCP. Local path defaults to basename of remote. + +Alternatively, C may be an already open file handle or an +IO::Handle object (e.g. IO::File, IO::Scalar). + +=head2 scp_put ( local_path [, remote_path ] ) + +Send a file with SCP. Remote path defaults to same as local. + +Alternatively, C may be an already open file handle or a +reference to a IO::Handle object (it must have a valid stat method). + +=head2 sftp + +Return SecureFTP interface object (see L). + +Note that SFTP support in libssh2 is pretty rudimentary. You should +consider using L with the L backend +L instead. + +=head2 public_key + +Return public key interface object (see L). + +=head2 known_hosts + +Returns known hosts interface object (see L). + +=head2 poll ( timeout, arrayref of hashes ) + +B: the poll functionality in libssh2 is deprecated and +its usage disregarded. Session methods L and +L can be used instead to integrate Net::SSH2 +inside an external event loop. + +Pass in a timeout in milliseconds and an arrayref of hashes with the +following keys: + +=over 4 + +=item handle + +May be a L or L object, integer file +descriptor, or perl file handle. + +=item events + +Requested events. Combination of LIBSSH2_POLLFD_* constants (with the POLL +prefix stripped if present), or an arrayref of the names ('in', 'hup' etc.). + +=item revents + +Returned events. Returns a hash with the (lowercased) names of the received +events ('in', 'hup', etc.) as keys with true values, and a C key with +the integer value. + +=back + +Returns undef on error, or the number of active objects. + +=head2 block_directions + +Get the blocked direction after some method returns +C. + +Returns C or/and +C. + +=head2 debug ( state ) + +Class method (affects all Net::SSH2 objects). + +Pass 1 to enable, 0 to disable. Debug output is sent to C. + +=head2 blocking ( flag ) + +Enable or disable blocking. + +A good number of the methods in Net::SSH2/libssh2 can not work in +non-blocking mode. Some of them may just forcibly enable blocking +during its execution. A few may even corrupt the SSH session or crash +the program. + +The ones that can be safely called are C and, with some +caveats, C. See L. + +I + +=head1 SEE ALSO + +L, L, +L, L, L. + +LibSSH2 documentation at L. + +IETF Secure Shell (secsh) working group at +L. + +L and L integrate nicely with Net::SSH2. + +Other Perl modules related to SSH you may find interesting: +L, L, L, +L. + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005 - 2010 by David B. Robins (dbrobins@cpan.org). + +Copyright (C) 2010 - 2016 by Rafael Kitover (rkitover@cpan.org). + +Copyright (C) 2011 - 2018 by Salvador FandiEo (salva@cpan.org). + +All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.0 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/lib/lib/Net/SSH2/Channel.pm b/lib/lib/Net/SSH2/Channel.pm new file mode 100644 index 0000000..35ca9ab --- /dev/null +++ b/lib/lib/Net/SSH2/Channel.pm @@ -0,0 +1,563 @@ +package Net::SSH2::Channel; + +use strict; +use warnings; +use Carp; + +# methods + +sub shell { + $_[0]->process('shell') +} + +sub exec { + $_[0]->process(exec => $_[1]) +} + +sub subsystem { + $_[0]->process(subsystem => $_[1]) +} + +sub error { + shift->session->error(@_) +} + +sub blocking { + shift->session->blocking(@_) +} + +sub setenv { + my ($self, %env) = @_; + my $rc = 1; + while (my ($k, $v) = each %env) { + $self->_setenv($k, $v) + or undef $rc; + } + $rc +} + +sub read1 { + my $self = shift; + my $buffer; + my $rc = $self->read($buffer, @_); + return (defined $rc ? $buffer : undef); +} + +sub read2 { + my ($self, $max_size) = @_; + $max_size = 32678 unless defined $max_size; + my $ssh2 = $self->session; + my $old_blocking = $ssh2->blocking; + my $timeout = $ssh2->timeout; + my $delay = (($timeout and $timeout < 2000) ? 0.0005 * $timeout : 1); + my $deadline; + $deadline = time + 1 + 0.001 * $timeout if $timeout; + $ssh2->blocking(0); + while (1) { + my @out; + my $bytes; + my $fail; + my $zero; + for (0, 1) { + my $rc = $self->read($out[$_], $max_size, $_); + if (defined $rc) { + $rc or $zero++; + $bytes += $rc; + $deadline = time + 1 + 0.001 * $timeout if $timeout; + } + else { + $out[$_] = ''; + if ($ssh2->error != Net::SSH2::LIBSSH2_ERROR_EAGAIN()) { + $fail++; + last; + } + } + } + if ($bytes) { + $ssh2->blocking($old_blocking); + return (wantarray ? @out : $out[0]) + } + my $eof = $self->eof; + if ($fail or $eof) { + $ssh2->_set_error if $eof; + $ssh2->blocking($old_blocking); + return; + } + unless ($zero) { + return unless $old_blocking; + if ($deadline and time > $deadline) { + $ssh2->_set_error(Net::SSH2::LIBSSH2_ERROR_TIMEOUT(), "Time out waiting for data"); + return; + } + return if $deadline and time > $deadline; + my $sock = $ssh2->sock; + my $fn = fileno($sock); + my ($rbm, $wbm) = ('', ''); + my $bd = $ssh2->block_directions; + vec($rbm, $fn, 1) = 1 if $bd & Net::SSH2::LIBSSH2_SESSION_BLOCK_INBOUND(); + vec($wbm, $fn, 1) = 1 if $bd & Net::SSH2::LIBSSH2_SESSION_BLOCK_OUTBOUND(); + select $rbm, $wbm, undef, $delay; + } + } +} + +my $readline_non_blocking_warned; +sub readline { + my ($self, $ext, $eol) = @_; + return if $self->eof; + $ext ||= 0; + $eol = $/ unless @_ >= 3; + + $self->blocking or $readline_non_blocking_warned++ or + warnings::warnif('Net::SSH2', + "Calling Net::SSH2::Channel::readline in non-blocking mode is usually a programming error"); + + if (wantarray or not defined $eol) { + my $data = ''; + my $buffer; + while (1) { + my $bytes = $self->read($buffer, 32768, $ext); + last unless defined $bytes; + if (!$bytes and $self->eof) { + $self->session->_set_error(Net::SSH2::LIBSSH2_ERROR_NONE()); + last; + } + $data .= $buffer; + } + defined $eol and return split /(?<=\Q$eol\E)/s, $data; + wantarray and not length $data and return (); + return $data; + } + else { + my $c; + my $data = ''; + while (1) { + $c = $self->getc($ext); + last unless defined $c; + $data .= $c; + if ( (!length($c) and $self->eof) or + $data =~ /\Q$eol\E\z/) { + $self->session->_set_error(Net::SSH2::LIBSSH2_ERROR_NONE()); + last; + } + } + return (length $data ? $data : undef); + } +} + +sub wait_closed { + my $self = shift; + if ($self->wait_eof) { + $self->flush('all'); + return $self->_wait_closed; + } + undef; +} + +sub exit_status { + my $self = shift; + return unless $self->wait_closed; + return $self->_exit_status; +} + +sub exit_signal { + my $self = shift; + return unless $self->wait_closed; + return $self->_exit_signal; +} + +my %signal_number; +sub exit_signal_number { + my $self = shift; + my $signal = $self->exit_signal; + return unless defined $signal; + return 0 unless $signal; + unless (%signal_number) { + require Config; + my @names = split /\s+/, $Config::Config{sig_name}; + @signal_number{@names} = 0..$#names; + } + $signal =~ s/\@\.[^\.]+\.config\.guess$//; + my $number = $signal_number{$signal}; + $number = 255 unless defined $number; + return $number; +} + +my %pty_modes = (TTY_OP_END => 0, VINTR => 1, VQUIT => 2, VERASE => 3, VKILL => 4, VEOF => 5, + VEOL => 6, VEOL2 => 7, VSTART => 8, VSTOP => 9, VSUSP => 10, VDSUSP => 11, + VREPRINT => 12, VWERASE => 13, VLNEXT => 14, VFLUSH => 15, VSWTCH => 16, VSTATUS => 17, + VDISCARD => 18, IGNPAR => 30, PARMRK => 31, INPCK => 32, ISTRIP => 33, INLCR => 34, + IGNCR => 35, ICRNL => 36, IUCLC => 37, IXON => 38, IXANY => 39, IXOFF => 40, + IMAXBEL => 41, ISIG => 50, ICANON => 51, XCASE => 52, ECHO => 53, ECHOE => 54, + ECHOK => 55, ECHONL => 56, NOFLSH => 57, TOSTOP => 58, IEXTEN => 59, ECHOCTL => 60, + ECHOKE => 61, PENDIN => 62, OPOST => 70, OLCUC => 71, ONLCR => 72, OCRNL => 73, + ONOCR => 74, ONLRET => 75, CS7 => 90, CS8 => 91, PARENB => 92, PARODD => 93, + TTY_OP_ISPEED => 128, TTY_OP_OSPEED => 129); + +sub pty { + my $self = shift; + if (defined $_[1] and ref $_[1] eq 'HASH') { + my $term = shift; + my $modes = shift; + my $packed = ''; + while (my ($k, $v) = each %$modes) { + unless ($k =~ /^\d+$/) { + my $k1 = $pty_modes{uc $k}; + defined $k1 or croak "Invalid pty mode key '$k'"; + $k = $k1; + } + next if $k == 0; # ignore the TTY_OP_END marker + $k > 159 and croak "Invalid pty mode key '$k'"; + $packed .= pack CN => $k, $v; + } + $self->_pty($term, "$packed\x00", @_); + } + else { + $self->_pty(@_); + } +} + +# tie interface + +sub PRINT { + my $self = shift; + my $sep = defined($,) ? $, : ''; + $self->write(join $sep, @_) +} + +sub PRINTF { + my $self = shift; + my $template = shift; + $self->write(sprintf $template, @_); +} + +sub WRITE { + my ($self, $buf, $len, $offset) = @_; + $self->write(substr($buf, $offset || 0, $len)) +} + +sub READLINE { shift->readline(0, $/) } + +sub READ { + my ($self, undef, $len, $offset) = @_; + my $bytes = $self->read(my($buffer), $len); + substr($_[1], $offset || 0) = $buffer + if defined $bytes; + return $bytes; +} + +sub BINMODE { 1 } + +sub CLOSE { + my $self = shift; + my $ob = $self->blocking; + $self->blocking(1); + my $rc = undef; + if ($self->close and + $self->wait_closed) { + my $status = $self->exit_status; + my $signal = $self->exit_signal_number; + $self->session->_set_error; + $? = ($status << 8) | $signal; + $rc = 1 if $? == 0; + } + $self->blocking($ob); + $rc; +} + +sub EOF { + my $self = shift; + $self->eof; +} + +*GETC = \&getc; + +1; +__END__ + +=head1 NAME + +Net::SSH2::Channel - SSH2 channel object + +=head1 SYNOPSIS + + my $chan = $ssh2->channel() + or $ssh2->die_with_error; + + $chan->exec("ls -ld /usr/local/libssh2*") + or $ssh2->die_with_error; + + $chan->send_eof; + + while (<$chan>) { + print "line read: $_"; + } + + print "exit status: " . $chan->exit_status . "\n"; + +=head1 DESCRIPTION + +A channel object is created by the L C method. As well +as being an object, it is also a tied filehandle. + +=head2 setenv ( key, value ... ) + +Sets remote environment variables. Note that most servers do not allow +environment variables to be freely set. + +Pass in a list of keys and values with the values to set. + +It returns a true value if all the given environment variables were +correctly set. + +=head2 blocking ( flag ) + +Enable or disable blocking. + +Note that this is currently implemented in libssh2 by setting a +per-session flag. It's equivalent to L. + +=head2 eof + +Returns true if the remote server sent an EOF. + +=head2 send_eof + +Sends an EOF to the remote side. + +After an EOF has been sent, no more data may be +sent to the remote process C channel. + +Note that if a PTY was requested for the channel, the EOF may be +ignored by the remote server. See L. + +=head2 close + +Close the channel (happens automatically on object destruction). + +=head2 wait_closed + +Wait for a remote close event. + +In order to avoid a bug in libssh2 this method discards any unread +data queued in the channel. + +=head2 exit_status + +Returns the channel's program exit status. + +This method blocks until the remote side closes the channel. + +=head2 pty ( terminal [, modes [, width [, height ]]] ) + +Request a terminal on a channel. + +C is the type of emulation (e.g. vt102, ansi, +etc...). + +C are the terminal mode modifiers, for instance: + + $c->pty('vt100', { echo => 0, vintr => ord('k') }); + +The list of acceptable mode modifiers is available from the SSH Connection +Protocol RFC (L). + +If provided, C and C are the width and height in +characters (defaults to 80x24); if negative their absolute values +specify width and height in pixels. + +=head2 pty_size ( width, height ) + +Request a terminal size change on a channel. C and C are the +width and height in characters; if negative their absolute values specify +width and height in pixels. + +=head2 ext_data ( mode ) + +Set extended data handling mode: + +=over 4 + +=item normal (default) + +Keep data in separate channels; C is read separately. + +=item ignore + +Ignore all extended data. + +=item merge + +Merge into the regular channel. + +=back + +=head2 process ( request, message ) + +Start a process on the channel. See also L, L, L. + +Note that only one invocation of C or any of the shortcuts +C, C or C is allowed per channel. In order to +run several commands, shells or/and subsystems, a new C +instance must be used for every one. + +Alternatively, it is also possible to launch a remote shell (using +L) and simulate the user interaction printing commands to its +C stream and reading data back from its C and +C. But this approach should be avoided if possible; talking to +a shell is difficult and, in general, unreliable. + +=head2 shell + +Start a shell on the remote host (calls C). + +=head2 exec ( command ) + +Execute the command on the remote host (calls C). + +Note that the given command is parsed by the remote shell; it should +be properly quoted, specially when passing data from untrusted sources. + +=head2 subsystem ( name ) + +Run subsystem on the remote host (calls C). + +=head2 read ( buffer, max_size [, ext ] ) + +Attempts to read up to C bytes from the channel into C. If +C is true, reads from the extended data channel (C). + +The method returns as soon as some data is available, even if the +given size has not been reached. + +Returns number of bytes read or C on failure. Note that 0 is a +valid return code. + +=head2 read2 ( [max_size] ) + +Attempts to read from both the ordinary (stdout) and the extended +(stderr) channel streams. + +Returns two scalars with the data read both from stdout and stderr. It +returns as soon as some data is available and any of the returned +values may be an empty string. + +When some error happens it returns the empty list. + +Example: + + my ($out, $err) = ('', ''); + while (!$channel->eof) { + if (my ($o, $e) = $channel->read2) { + $out .= $o; + $err .= $e; + } + else { + $ssh2->die_with_error; + } + } + print "STDOUT:\n$out\nSTDERR:\n$err\n"; + +=head2 readline ( [ext [, eol ] ] ) + +Reads the next line from the selected stream (C defaults to 0: +stdout). + +C<$/> is used as the end of line marker when C is C. + +In list context reads and returns all the remaining lines until some +read error happens or the remote side sends an eof. + +Note that this method is only safe when the complementary stream +(e.g. C) is guaranteed to not generate data or when L +has been used to discard or merge it; otherwise it may hang. This is a +limitation of libssh2 that hopefully would be removed in a future +release, in the meantime you are advised to use L instead. + +=head2 getc( [ext] ) + +Reads and returns the next character from the selected stream. + +Returns C on error. + +Note that due to some libssh2 quirks, the return value can be the +empty string which may indicate an EOF condition (but not +always!). See L. + +=head2 write ( buffer ) + +Send the data in C through the channel. Returns number of +bytes written, undef on failure. + +In versions of this module prior to 0.57, when working in non-blocking +mode, the would-block condition was signaled by returning +C (a negative number) while leaving the session +error status unset. From version 0.59, C is returned and the +session error status is set to C as for any +other error. + +In non-blocking mode, if C fails with a C +error, no other operation must be invoked over any object in the same +SSH session besides L and L. + +Once the socket becomes ready again, the exact same former C +call, with exactly the same arguments must be invoked. + +Failing to do that would result in a corrupted SSH session. This is a +limitation in libssh2. + +=head2 flush ( [ ext ] ) + +Flushes the channel; if C is present and set, flushes extended +data channel. Returns number of bytes flushed, C on error. + +=head2 exit_signal + +Returns the name of exit signal from the remote command. + +In list context returns also the error message and a language tag, +though as of libssh2 1.7.0, those values are always undef. + +This method blocks until the remote side closes the channel. + +=head2 exit_signal_number + +Converts the signal name to a signal number using the local mapping +(which may be different to the remote one if the operating systems +differ). + +=head2 window_read + +Returns the number of bytes which the remote end may send without +overflowing the window limit. + +In list context it also returns the number of bytes that are +immediately available for read and the size of the initial window. + +=head2 window_write + +Returns the number of bytes which may be safely written to the channel +without blocking at the SSH level. In list context it also returns the +size of the initial window. + +Note that this method doesn't take into account the TCP connection +being used under the hood. Getting a positive integer back from this +method does not guarantee that such number of bytes could be written +to the channel without blocking the TCP connection. + +=head2 receive_window_adjust (adjustment [, force]) + +Adjust the channel receive window by the given C bytes. + +If the amount to be adjusted is less than C +and force is false the adjustment amount will be queued for a later +packet. + +On success returns the new size of the receive window. On failure it +returns C. + +=head1 SEE ALSO + +L. + +=cut diff --git a/lib/lib/Net/SSH2/Constants.pm b/lib/lib/Net/SSH2/Constants.pm new file mode 100644 index 0000000..fc140f6 --- /dev/null +++ b/lib/lib/Net/SSH2/Constants.pm @@ -0,0 +1,32 @@ +package + Net::SSH2::Constants; + +# This file is generated automatically by util/gen_constants.pl + +sub import { die "Do not use Net::SSH2::Constants!"; } + +package + Net::SSH2; + +use strict; +use warnings; + +use base 'Exporter'; + +our @EXPORT_OK = qw(LIBSSH2_CALLBACK_DEBUG LIBSSH2_CALLBACK_DISCONNECT LIBSSH2_CALLBACK_IGNORE LIBSSH2_CALLBACK_MACERROR LIBSSH2_CALLBACK_X11 LIBSSH2_CHANNEL_EXTENDED_DATA_IGNORE LIBSSH2_CHANNEL_EXTENDED_DATA_MERGE LIBSSH2_CHANNEL_EXTENDED_DATA_NORMAL SSH_EXTENDED_DATA_STDERR LIBSSH2_EXTENDED_DATA_STDERR LIBSSH2_CHANNEL_FLUSH_ALL LIBSSH2_CHANNEL_FLUSH_EXTENDED_DATA LIBSSH2_CHANNEL_FLUSH_STDERR LIBSSH2_CHANNEL_MINADJUST LIBSSH2_CHANNEL_PACKET_DEFAULT LIBSSH2_CHANNEL_WINDOW_DEFAULT LIBSSH2_DH_GEX_MAXGROUP LIBSSH2_DH_GEX_MINGROUP LIBSSH2_DH_GEX_OPTGROUP LIBSSH2_ERROR_ALLOC LIBSSH2_ERROR_BANNER_NONE LIBSSH2_ERROR_NONE LIBSSH2_ERROR_BANNER_SEND LIBSSH2_ERROR_CHANNEL_CLOSED LIBSSH2_ERROR_CHANNEL_EOF_SENT LIBSSH2_ERROR_CHANNEL_FAILURE LIBSSH2_ERROR_CHANNEL_OUTOFORDER LIBSSH2_ERROR_CHANNEL_PACKET_EXCEEDED LIBSSH2_ERROR_CHANNEL_REQUEST_DENIED LIBSSH2_ERROR_CHANNEL_UNKNOWN LIBSSH2_ERROR_CHANNEL_WINDOW_EXCEEDED LIBSSH2_ERROR_DECRYPT LIBSSH2_ERROR_FILE LIBSSH2_ERROR_HOSTKEY_INIT LIBSSH2_ERROR_HOSTKEY_SIGN LIBSSH2_ERROR_INVAL LIBSSH2_ERROR_INVALID_MAC LIBSSH2_ERROR_INVALID_POLL_TYPE LIBSSH2_ERROR_KEX_FAILURE LIBSSH2_ERROR_KEY_EXCHANGE_FAILURE LIBSSH2_ERROR_METHOD_NONE LIBSSH2_ERROR_METHOD_NOT_SUPPORTED LIBSSH2_ERROR_PASSWORD_EXPIRED LIBSSH2_ERROR_PROTO LIBSSH2_ERROR_AUTHENTICATION_FAILED LIBSSH2_ERROR_PUBLICKEY_UNRECOGNIZED LIBSSH2_ERROR_PUBLICKEY_UNVERIFIED LIBSSH2_ERROR_REQUEST_DENIED LIBSSH2_ERROR_SCP_PROTOCOL LIBSSH2_ERROR_PUBLICKEY_PROTOCOL LIBSSH2_ERROR_SFTP_PROTOCOL LIBSSH2_ERROR_SOCKET_DISCONNECT LIBSSH2_ERROR_SOCKET_NONE LIBSSH2_ERROR_SOCKET_SEND LIBSSH2_ERROR_SOCKET_TIMEOUT LIBSSH2_ERROR_TIMEOUT LIBSSH2_ERROR_ZLIB LIBSSH2_ERROR_KNOWN_HOSTS LIBSSH2_FLAG_SIGPIPE LIBSSH2_FLAG_COMPRESS LIBSSH2_FXF_APPEND LIBSSH2_ERROR_EAGAIN LIBSSH2_SESSION_BLOCK_INBOUND LIBSSH2_SESSION_BLOCK_OUTBOUND LIBSSH2_TRACE_TRANS LIBSSH2_TRACE_KEX LIBSSH2_TRACE_AUTH LIBSSH2_TRACE_CONN LIBSSH2_TRACE_SCP LIBSSH2_TRACE_SFTP LIBSSH2_TRACE_ERROR LIBSSH2_TRACE_PUBLICKEY LIBSSH2_TRACE_SOCKET LIBSSH2_FXF_CREAT LIBSSH2_FXF_EXCL LIBSSH2_FXF_READ LIBSSH2_FXF_TRUNC LIBSSH2_FXF_WRITE LIBSSH2_FX_BAD_MESSAGE LIBSSH2_FX_CONNECTION_LOST LIBSSH2_FX_DIR_NOT_EMPTY LIBSSH2_FX_EOF LIBSSH2_FX_FAILURE LIBSSH2_FX_FILE_ALREADY_EXISTS LIBSSH2_FX_INVALID_FILENAME LIBSSH2_FX_INVALID_HANDLE LIBSSH2_FX_LINK_LOOP LIBSSH2_FX_LOCK_CONFlICT LIBSSH2_FX_NOT_A_DIRECTORY LIBSSH2_FX_NO_CONNECTION LIBSSH2_FX_NO_MEDIA LIBSSH2_FX_NO_SPACE_ON_FILESYSTEM LIBSSH2_FX_NO_SUCH_FILE LIBSSH2_FX_NO_SUCH_PATH LIBSSH2_FX_OK LIBSSH2_FX_OP_UNSUPPORTED LIBSSH2_FX_PERMISSION_DENIED LIBSSH2_FX_QUOTA_EXCEEDED LIBSSH2_FX_UNKNOWN_PRINCIPLE LIBSSH2_FX_WRITE_PROTECT LIBSSH2_H LIBSSH2_HOSTKEY_HASH_MD5 LIBSSH2_HOSTKEY_HASH_SHA1 LIBSSH2_METHOD_COMP_CS LIBSSH2_METHOD_COMP_SC LIBSSH2_METHOD_CRYPT_CS LIBSSH2_METHOD_CRYPT_SC LIBSSH2_METHOD_HOSTKEY LIBSSH2_METHOD_KEX LIBSSH2_METHOD_LANG_CS LIBSSH2_METHOD_LANG_SC LIBSSH2_METHOD_MAC_CS LIBSSH2_METHOD_MAC_SC LIBSSH2_PACKET_MAXCOMP LIBSSH2_PACKET_MAXDECOMP LIBSSH2_PACKET_MAXPAYLOAD LIBSSH2_POLLFD_CHANNEL LIBSSH2_POLLFD_CHANNEL_CLOSED LIBSSH2_POLLFD_LISTENER LIBSSH2_POLLFD_LISTENER_CLOSED LIBSSH2_POLLFD_POLLERR LIBSSH2_POLLFD_POLLEX LIBSSH2_POLLFD_POLLEXT LIBSSH2_POLLFD_POLLHUP LIBSSH2_POLLFD_POLLIN LIBSSH2_POLLFD_POLLNVAL LIBSSH2_POLLFD_POLLOUT LIBSSH2_POLLFD_POLLPRI LIBSSH2_POLLFD_SESSION_CLOSED LIBSSH2_POLLFD_SOCKET LIBSSH2_SFTP_ATTR_ACMODTIME LIBSSH2_SFTP_ATTR_EXTENDED LIBSSH2_SFTP_ATTR_PERMISSIONS LIBSSH2_SFTP_ATTR_SIZE LIBSSH2_SFTP_ATTR_UIDGID LIBSSH2_SFTP_LSTAT LIBSSH2_SFTP_OPENDIR LIBSSH2_SFTP_OPENFILE LIBSSH2_SFTP_PACKET_MAXLEN LIBSSH2_SFTP_READLINK LIBSSH2_SFTP_REALPATH LIBSSH2_SFTP_RENAME_ATOMIC LIBSSH2_SFTP_RENAME_NATIVE LIBSSH2_SFTP_RENAME_OVERWRITE LIBSSH2_SFTP_SETSTAT LIBSSH2_SFTP_STAT LIBSSH2_SFTP_SYMLINK LIBSSH2_SFTP_TYPE_BLOCK_DEVICE LIBSSH2_SFTP_TYPE_CHAR_DEVICE LIBSSH2_SFTP_TYPE_DIRECTORY LIBSSH2_SFTP_TYPE_FIFO LIBSSH2_SFTP_TYPE_REGULAR LIBSSH2_SFTP_TYPE_SOCKET LIBSSH2_SFTP_TYPE_SPECIAL LIBSSH2_SFTP_TYPE_SYMLINK LIBSSH2_SFTP_TYPE_UNKNOWN LIBSSH2_SFTP_VERSION LIBSSH2_SOCKET_POLL_MAXLOOPS LIBSSH2_SOCKET_POLL_UDELAY LIBSSH2_TERM_HEIGHT LIBSSH2_TERM_HEIGHT_PX LIBSSH2_TERM_WIDTH LIBSSH2_TERM_WIDTH_PX LIBSSH2_KNOWNHOST_TYPE_MASK LIBSSH2_KNOWNHOST_TYPE_PLAIN LIBSSH2_KNOWNHOST_TYPE_SHA1 LIBSSH2_KNOWNHOST_TYPE_CUSTOM LIBSSH2_KNOWNHOST_KEYENC_MASK LIBSSH2_KNOWNHOST_KEYENC_RAW LIBSSH2_KNOWNHOST_KEYENC_BASE64 LIBSSH2_KNOWNHOST_KEY_MASK LIBSSH2_KNOWNHOST_KEY_SHIFT LIBSSH2_KNOWNHOST_KEY_RSA1 LIBSSH2_KNOWNHOST_KEY_SSHRSA LIBSSH2_KNOWNHOST_KEY_SSHDSS LIBSSH2_KNOWNHOST_CHECK_MATCH LIBSSH2_KNOWNHOST_CHECK_MISMATCH LIBSSH2_KNOWNHOST_CHECK_NOTFOUND LIBSSH2_KNOWNHOST_CHECK_FAILURE LIBSSH2_HOSTKEY_POLICY_STRICT LIBSSH2_HOSTKEY_POLICY_ASK LIBSSH2_HOSTKEY_POLICY_TOFU LIBSSH2_HOSTKEY_POLICY_ADVISORY); +our %EXPORT_TAGS = ( + all => \@EXPORT_OK, + callback => [qw(LIBSSH2_CALLBACK_DEBUG LIBSSH2_CALLBACK_DISCONNECT LIBSSH2_CALLBACK_IGNORE LIBSSH2_CALLBACK_MACERROR LIBSSH2_CALLBACK_X11)], + channel => [qw(LIBSSH2_CHANNEL_EXTENDED_DATA_IGNORE LIBSSH2_CHANNEL_EXTENDED_DATA_MERGE LIBSSH2_CHANNEL_EXTENDED_DATA_NORMAL LIBSSH2_CHANNEL_FLUSH_ALL LIBSSH2_CHANNEL_FLUSH_EXTENDED_DATA LIBSSH2_CHANNEL_FLUSH_STDERR LIBSSH2_CHANNEL_MINADJUST LIBSSH2_CHANNEL_PACKET_DEFAULT LIBSSH2_CHANNEL_WINDOW_DEFAULT)], + error => [qw(LIBSSH2_ERROR_ALLOC LIBSSH2_ERROR_BANNER_NONE LIBSSH2_ERROR_NONE LIBSSH2_ERROR_BANNER_SEND LIBSSH2_ERROR_CHANNEL_CLOSED LIBSSH2_ERROR_CHANNEL_EOF_SENT LIBSSH2_ERROR_CHANNEL_FAILURE LIBSSH2_ERROR_CHANNEL_OUTOFORDER LIBSSH2_ERROR_CHANNEL_PACKET_EXCEEDED LIBSSH2_ERROR_CHANNEL_REQUEST_DENIED LIBSSH2_ERROR_CHANNEL_UNKNOWN LIBSSH2_ERROR_CHANNEL_WINDOW_EXCEEDED LIBSSH2_ERROR_DECRYPT LIBSSH2_ERROR_FILE LIBSSH2_ERROR_HOSTKEY_INIT LIBSSH2_ERROR_HOSTKEY_SIGN LIBSSH2_ERROR_INVAL LIBSSH2_ERROR_INVALID_MAC LIBSSH2_ERROR_INVALID_POLL_TYPE LIBSSH2_ERROR_KEX_FAILURE LIBSSH2_ERROR_KEY_EXCHANGE_FAILURE LIBSSH2_ERROR_METHOD_NONE LIBSSH2_ERROR_METHOD_NOT_SUPPORTED LIBSSH2_ERROR_PASSWORD_EXPIRED LIBSSH2_ERROR_PROTO LIBSSH2_ERROR_AUTHENTICATION_FAILED LIBSSH2_ERROR_PUBLICKEY_UNRECOGNIZED LIBSSH2_ERROR_PUBLICKEY_UNVERIFIED LIBSSH2_ERROR_REQUEST_DENIED LIBSSH2_ERROR_SCP_PROTOCOL LIBSSH2_ERROR_PUBLICKEY_PROTOCOL LIBSSH2_ERROR_SFTP_PROTOCOL LIBSSH2_ERROR_SOCKET_DISCONNECT LIBSSH2_ERROR_SOCKET_NONE LIBSSH2_ERROR_SOCKET_SEND LIBSSH2_ERROR_SOCKET_TIMEOUT LIBSSH2_ERROR_TIMEOUT LIBSSH2_ERROR_ZLIB LIBSSH2_ERROR_KNOWN_HOSTS LIBSSH2_ERROR_EAGAIN)], + fx => [qw(LIBSSH2_FX_BAD_MESSAGE LIBSSH2_FX_CONNECTION_LOST LIBSSH2_FX_DIR_NOT_EMPTY LIBSSH2_FX_EOF LIBSSH2_FX_FAILURE LIBSSH2_FX_FILE_ALREADY_EXISTS LIBSSH2_FX_INVALID_FILENAME LIBSSH2_FX_INVALID_HANDLE LIBSSH2_FX_LINK_LOOP LIBSSH2_FX_LOCK_CONFlICT LIBSSH2_FX_NOT_A_DIRECTORY LIBSSH2_FX_NO_CONNECTION LIBSSH2_FX_NO_MEDIA LIBSSH2_FX_NO_SPACE_ON_FILESYSTEM LIBSSH2_FX_NO_SUCH_FILE LIBSSH2_FX_NO_SUCH_PATH LIBSSH2_FX_OK LIBSSH2_FX_OP_UNSUPPORTED LIBSSH2_FX_PERMISSION_DENIED LIBSSH2_FX_QUOTA_EXCEEDED LIBSSH2_FX_UNKNOWN_PRINCIPLE LIBSSH2_FX_WRITE_PROTECT)], + fxf => [qw(LIBSSH2_FXF_APPEND LIBSSH2_FXF_CREAT LIBSSH2_FXF_EXCL LIBSSH2_FXF_READ LIBSSH2_FXF_TRUNC LIBSSH2_FXF_WRITE)], + hash => [qw(LIBSSH2_HOSTKEY_HASH_MD5 LIBSSH2_HOSTKEY_HASH_SHA1)], + method => [qw(LIBSSH2_METHOD_COMP_CS LIBSSH2_METHOD_COMP_SC LIBSSH2_METHOD_CRYPT_CS LIBSSH2_METHOD_CRYPT_SC LIBSSH2_METHOD_HOSTKEY LIBSSH2_METHOD_KEX LIBSSH2_METHOD_LANG_CS LIBSSH2_METHOD_LANG_SC LIBSSH2_METHOD_MAC_CS LIBSSH2_METHOD_MAC_SC)], + policy => [qw(LIBSSH2_HOSTKEY_POLICY_STRICT LIBSSH2_HOSTKEY_POLICY_ASK LIBSSH2_HOSTKEY_POLICY_TOFU LIBSSH2_HOSTKEY_POLICY_ADVISORY)], + sftp => [qw(LIBSSH2_SFTP_ATTR_ACMODTIME LIBSSH2_SFTP_ATTR_EXTENDED LIBSSH2_SFTP_ATTR_PERMISSIONS LIBSSH2_SFTP_ATTR_SIZE LIBSSH2_SFTP_ATTR_UIDGID LIBSSH2_SFTP_LSTAT LIBSSH2_SFTP_OPENDIR LIBSSH2_SFTP_OPENFILE LIBSSH2_SFTP_PACKET_MAXLEN LIBSSH2_SFTP_READLINK LIBSSH2_SFTP_REALPATH LIBSSH2_SFTP_RENAME_ATOMIC LIBSSH2_SFTP_RENAME_NATIVE LIBSSH2_SFTP_RENAME_OVERWRITE LIBSSH2_SFTP_SETSTAT LIBSSH2_SFTP_STAT LIBSSH2_SFTP_SYMLINK LIBSSH2_SFTP_TYPE_BLOCK_DEVICE LIBSSH2_SFTP_TYPE_CHAR_DEVICE LIBSSH2_SFTP_TYPE_DIRECTORY LIBSSH2_SFTP_TYPE_FIFO LIBSSH2_SFTP_TYPE_REGULAR LIBSSH2_SFTP_TYPE_SOCKET LIBSSH2_SFTP_TYPE_SPECIAL LIBSSH2_SFTP_TYPE_SYMLINK LIBSSH2_SFTP_TYPE_UNKNOWN LIBSSH2_SFTP_VERSION)], + socket => [qw(LIBSSH2_SOCKET_POLL_MAXLOOPS LIBSSH2_SOCKET_POLL_UDELAY)], + trace => [qw(LIBSSH2_TRACE_TRANS LIBSSH2_TRACE_KEX LIBSSH2_TRACE_AUTH LIBSSH2_TRACE_CONN LIBSSH2_TRACE_SCP LIBSSH2_TRACE_SFTP LIBSSH2_TRACE_ERROR LIBSSH2_TRACE_PUBLICKEY LIBSSH2_TRACE_SOCKET)], +); + +1; diff --git a/lib/lib/Net/SSH2/Dir.pm b/lib/lib/Net/SSH2/Dir.pm new file mode 100644 index 0000000..8c46a08 --- /dev/null +++ b/lib/lib/Net/SSH2/Dir.pm @@ -0,0 +1,42 @@ +package Net::SSH2::Dir; + +use strict; +use warnings; +use Carp; + +# methods + + +1; +__END__ + +=head1 NAME + +Net::SSH2::Dir - SSH 2 SFTP directory object + +=head1 DESCRIPTION + +An SFTP file object is created by the L C method. + +=head2 read + +Returns a hash (hashref in scalar context); keys are C and those returned +by Net::SSH2::SFTP::stat; returns empty list or undef if no more files. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +David B. Robins, Edbrobins@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005, 2006 by David B. Robins; all rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.0 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/lib/lib/Net/SSH2/File.pm b/lib/lib/Net/SSH2/File.pm new file mode 100644 index 0000000..f532ec3 --- /dev/null +++ b/lib/lib/Net/SSH2/File.pm @@ -0,0 +1,169 @@ +package Net::SSH2::File; + +use strict; +use warnings; +use Carp; + +# methods +sub readline { + my ($self, $eol) = @_; + $eol = $/ unless @_ >= 2; + if (wantarray or not defined $eol) { + my $data = ''; + my $buffer; + while (1) { + $self->read($buffer, 32768) or last; + $data .= $buffer; + } + defined $eol and return split /(?<=\Q$eol\E)/s, $data; + wantarray and not length $data and return (); + return $data; + } + else { + my $c; + my $data = ''; + while (1) { + $c = $self->getc; + last unless defined $c; + $data .= $c; + last if $data =~ /\Q$eol\E\z/; + } + return (length $data ? $data : undef); + } +} + +# tie interface + +sub PRINT { + my $self = shift; + my $sep = defined($,) ? $, : ''; + $self->write(join $sep, @_) +} + +sub PRINTF { + my $self = shift; + my $template = shift; + $self->write(sprintf $template, @_) +} + +sub WRITE { + my ($self, $buf, $len, $offset) = @_; + $self->write(substr($buf, $offset, $len)) +} + +sub READLINE { shift->readline($/) } + +*GETC = \&getc; + +sub READ { + my ($self, undef, $len, $offset) = @_; + my $bytes = $self->read(my($buffer), $len); + substr($_[1], $offset || 0) = $buffer + if defined $bytes; + return $bytes; +} + +sub CLOSE { +} + +sub BINMODE { 1 } + +sub EOF { 0 } + +1; +__END__ + +=head1 NAME + +Net::SSH2::File - SSH2 SFTP file object + +=head1 DESCRIPTION + +An SFTP file object is created by the L C method. + +=head2 read ( buffer, size ) + +Read size bytes from the file into a given buffer. Returns number of bytes +read, or undef on failure. + +=head2 write ( buffer ) + +Write buffer to the remote file. + +The C function wrapped by this method has a +complex and quite difficult (if not impossible at all) to use API. It +tries to hide the packet pipelining being done under the hood in order +to attain decent throughput. + +Net::SSH2 can not hide that complexity without negatively affecting +the transmission speed so it provides just a thin wrapper for that +library function. + +An excerpt from C manual page follows: + + WRITE AHEAD + + Starting in libssh2 version 1.2.8, the default behavior of libssh2 + is to create several smaller outgoing packets for all data you pass + to this function and it will return a positive number as soon as the + first packet is acknowledged from the server. + + This has the effect that sometimes more data has been sent off but + isn't acked yet when this function returns, and when this function + is subsequently called again to write more data, libssh2 will + immediately figure out that the data is already received remotely. + + In most normal situation this should not cause any problems, but it + should be noted that if you've once called libssh2_sftp_write() with + data and it returns short, you MUST still assume that the rest of + the data might've been cached so you need to make sure you don't + alter that data and think that the version you have in your next + function invoke will be detected or used. + + The reason for this funny behavior is that SFTP can only send 32K + data in each packet and it gets all packets acked individually. This + means we cannot use a simple serial approach if we want to reach + high performance even on high latency connections. And we want that. + + +=head2 stat + +Returns file attributes; see Net::SSH2::SFTP::stat. + +=head2 setstat ( key, value... ) + +Sets file attributes; see Net::SSH2::SFTP::setstat. + +=head2 seek ( offset ) + +Set the file pointer offset. + +=head2 tell + +Returns the current file pointer offset. + +=head1 SEE ALSO + +L. + +Check L for a high level, perlish and easy to use +SFTP client module. It can work on top of Net::SSH2 via the +L backend module. + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005, 2006 by David B. Robins Edbrobins@cpan.orgE; + +Copyright (C) 2015 by Salvador FandiEo Esfandino@yahoo.comE; + +All rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.0 or, +at your option, any later version of Perl 5 you may have available. + +The documentation for this package contains and excerpt from libssh2 +manual pages. You can consult the license of the libssh2 project for +the conditions regulating the copyright of that part. + +=cut diff --git a/lib/lib/Net/SSH2/KnownHosts.pm b/lib/lib/Net/SSH2/KnownHosts.pm new file mode 100644 index 0000000..ae5018e --- /dev/null +++ b/lib/lib/Net/SSH2/KnownHosts.pm @@ -0,0 +1,195 @@ +package Net::SSH2::KnownHosts; + +use strict; +use warnings; + +1; + +__END__ + +=head1 NAME + +Net::SSH2::KnownHosts - SSH 2 knownhosts object + +=head1 SYNOPSIS + + ##################################################################### + # # + # WARNING: The API provided by Net::SSH2::KnownHosts is # + # experimental and could change in future versions of the module!!! # + # # + ##################################################################### + + my $kh = $ssh2->known_hosts; + + my $n_ent = $kh->readfile($known_hosts_path); + + # a non-existent known_hosts file usually is not an error... + unless (defined $n_ent) { + if ($ssh2->error != LIBSSH2_ERROR_FILE or -f $known_hosts_path) { + die; # propagate error; + } + } + + my ($key, $type) = $ssh2->remote_hostkey; + + my $flags = ( LIBSSH2_KNOWNHOST_TYPE_PLAIN | + LIBSSH2_KNOWNHOST_KEYENC_RAW | + (($type + 1) << LIBSSH2_KNOWNHOST_KEY_SHIFT) ); + + my $check = $kh->check($hostname, $port, $key, $flags); + + if ($check == LIBSSH2_KNOWNHOST_CHECK_MATCH) { + # ok! + } + elsif ($check == LIBSSH2_KNOWNHOST_CHECK_MISMATCH) { + die "host verification failed, the key has changed!"; + } + elsif ($check == LIBSSH2_KNOWNHOST_CHECK_NOTFOUND) { + die "host verification failed, key not found in known_hosts file" + if $strict_host_key_checking; + + # else, save new key to file: + unless ( $kh->add($hostname, '', $key, "Perl added me", $flags) and + $kh->writefile($known_hosts_path) ) { + warn "unable to save known_hosts file: " . ($ssh2->error)[1]; + } + } + else { + die "host key verification failed, unknown reason"; + } + +=head1 DESCRIPTION + + ##################################################################### + # # + # WARNING: The API provided by Net::SSH2::KnownHosts is # + # experimental and could change in future versions of the module!!! # + # # + ##################################################################### + +The C object allows one to manipulate the entries in the +C file usually located at C<~/.ssh/known_hosts> and which +contains the public keys of the already known hosts. + +The methods currently supported are as follows: + +=head2 readfile (filename) + +Populates the object with the entries in the given file. + +It returns the number or entries read or undef on failure. + +=head2 writefile (filename) + +Saves the known host entries to the given file. + +=head2 add (hostname, salt, key, comment, key_type|host_format|key_format) + +Add a host and its associated key to the collection of known hosts. + +The C argument specifies the format of the given host: + + LIBSSH2_KNOWNHOST_TYPE_PLAIN - ascii "hostname.domain.tld" + LIBSSH2_KNOWNHOST_TYPE_SHA1 - SHA1(salt, host) base64-encoded! + LIBSSH2_KNOWNHOST_TYPE_CUSTOM - another hash + +If C is selected as host format, the salt must be provided to +the salt argument in base64 format. + +The SHA-1 hash is what OpenSSH can be told to use in known_hosts +files. If a custom type is used, salt is ignored and you must provide +the host pre-hashed when checking for it in the C method. + +The available key formats are as follow: + + LIBSSH2_KNOWNHOST_KEYENC_RAW + LIBSSH2_KNOWNHOST_KEYENC_BASE64 + +Finally, the available key types are as follow: + + LIBSSH2_KNOWNHOST_KEY_RSA1 + LIBSSH2_KNOWNHOST_KEY_SSHRSA + LIBSSH2_KNOWNHOST_KEY_SSHDSS + +The comment argument may be undef. + +=head2 check (hostname, port, key, key_type|host_format|key_format) + +Checks a host and its associated key against the collection of known hosts. + +The C argument has the same meaning +as in the L method. + +C may be passed as the port argument. + +Returns: + + LIBSSH2_KNOWNHOST_CHECK_MATCH (0) + LIBSSH2_KNOWNHOST_CHECK_MISMATCH (1) + LIBSSH2_KNOWNHOST_CHECK_NOTFOUND (2) + LIBSSH2_KNOWNHOST_CHECK_FAILURE (3) + +=head2 readline (string) + +Read a known_hosts entry from the given string. + +For instance, the following piece of code is more or less equivalent +to the L method: + + my $kh = $ssh2->known_hosts; + if (open my $fh, '<', $known_hosts_path) { + while (<>) { + eval { $kh->readline($_) } + or warn "unable to parse known_hosts entry $_"; + } + } + +=head2 writeline (hostname, port, key, key_type|host_format|key_format) + +Searches the entry matching the given parameters (as described in the +L method) and formats it into a line in the known_hosts +format. + +This method returns undef when some error happens. + +This method should be considered experimental, the interface may +change. + +=head1 SEE ALSO + +L, L. + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2013-2015 Salvador FandiEo; all rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.0 or, +at your option, any later version of Perl 5 you may have available. + +The documentation on this file is based on the comments inside +C file from the libssh2 distribution which has the +following copyright and license: + +Copyright (c) 2004-2009, Sara Golemon +Copyright (c) 2009-2012 Daniel Stenberg +Copyright (c) 2010 Simon Josefsson +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +Neither the name of the copyright holder nor the names of any other +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +=cut diff --git a/lib/lib/Net/SSH2/Listener.pm b/lib/lib/Net/SSH2/Listener.pm new file mode 100644 index 0000000..e2b6170 --- /dev/null +++ b/lib/lib/Net/SSH2/Listener.pm @@ -0,0 +1,42 @@ +package Net::SSH2::Listener; + +use strict; +use warnings; +use Carp; + +# methods + + +1; +__END__ + +=head1 NAME + +Net::SSH2::Listener - SSH 2 listener object + +=head1 DESCRIPTION + +A listener object is created by the L C method. The +L C method can be used to check for connections. + +=head2 accept + +Accept a connection. Returns a channel object on success, undef on failure. + +=head1 SEE ALSO + +L. + +=head1 AUTHOR + +David B. Robins, Edbrobins@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005, 2006 by David B. Robins; all rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.0 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/lib/lib/Net/SSH2/PublicKey.pm b/lib/lib/Net/SSH2/PublicKey.pm new file mode 100644 index 0000000..df32c27 --- /dev/null +++ b/lib/lib/Net/SSH2/PublicKey.pm @@ -0,0 +1,46 @@ +package Net::SSH2::PublicKey; + +use strict; +use warnings; +use Carp; + +# methods + + +1; +__END__ + +=head1 NAME + +Net::SSH2::PublicKey - SSH 2 public key object + +=head1 DESCRIPTION + + *** WARNING: public key functionality in libssh2 is experimental + *** and mostly abandoned. Don't expect anything on this module to + *** work correctly. + +A public key object is created by the L C method. + +=head1 METHODS + +=head2 add ( name, blob, overwrite flag, attributes... ) + +Adds a new public key; attributes is a list of hashes with C, C, +and C keys; mandatory defaults to false and value to empty. + +=head2 remove ( name, blob ) + +Remove the given public key. + +=head2 fetch + +Returns a list of public keys in array context (count in scalar context); +each item is a hash with keys C, C, and C, with the latter +being a hash with C, C, and C keys. + +=head1 SEE ALSO + +L. + +=cut diff --git a/lib/lib/Net/SSH2/SFTP.pm b/lib/lib/Net/SSH2/SFTP.pm new file mode 100644 index 0000000..9788501 --- /dev/null +++ b/lib/lib/Net/SSH2/SFTP.pm @@ -0,0 +1,126 @@ +package Net::SSH2::SFTP; + +use strict; +use warnings; +use Carp; + +sub die_with_error { + my $self = shift; + if (my ($code, $name) = $self->error) { + croak join(": ", @_, "SFTP error $code $name"); + } + else { + croak join(": ", @_, "no SFTP error registered"); + } +} + + +1; +__END__ + +=head1 NAME + +Net::SSH2::SFTP - SSH 2 Secure FTP object + +=head1 DESCRIPTION + +An SFTP object is created by the L C method. + +=head2 error + +Returns the last SFTP error (one of the LIBSSH2_FX_* constants). Use this +when Net::SSH2::error returns LIBSSH2_ERROR_SFTP_PROTOCOL. In list context, +returns (code, error name). + +=head2 die_with_error( [message] ) + +Calls C with the given message and the error information from the +object appended. + +=head2 open ( file [, flags [, mode ]]] ) + +Open or create a file on the remote host. The flags are the standard O_RDONLY, +O_WRONLY, O_RDWR, O_APPEND, O_CREAT, O_TRUNC, and O_EXCL, which may be +combined as usual. Flags default to O_RDONLY and mode to 0666 (create only). +Returns a L object on success. + +=head2 opendir ( dir ) + +Open a directory on the remote host; returns a Net::SSH2::Dir object on success. + +=head2 unlink ( file ) + +Delete the remote file. + +=head2 rename ( old, new [, flags ] ) + +Rename old to new. Flags are taken from LIBSSH2_SFTP_RENAME_*, and may be +combined; the default is to use all (overwrite, atomic, native). + +=head2 mkdir ( path [, mode ] ) + +Create directory; mode defaults to 0777. + +=head2 rmdir ( path ) + +Remove directory. + +=head2 stat ( path [, follow ] ) + +Get file attributes for the given path. If follow is set (default), will +follow symbolic links. On success, returns a hash containing the following: + +=over 4 + +=item mode + +=item size + +=item uid + +=item gid + +=item atime + +=item mtime + +=back + +=head2 setstat ( path, key, value... ) + +Set file attributes for given path; keys are the same as those returned by stat; +note that it's not necessary to pass them all. + +=head2 symlink ( path, target [, type ] ) + +Create a symbolic link to a given target. + +=head2 readlink ( path ) + +Return the target of the given link, undef on failure. + +=head2 realpath ( path ) + +Resolve a filename's path; returns the resolved path, or undef on error. + +=head1 SEE ALSO + +L. + +Check L for a high level, perlish and easy to use +SFTP client module. It can work on top of Net::SSH2 via the +L backend module. + +=head1 AUTHOR + +David B. Robins, Edbrobins@cpan.orgE + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2005, 2006 by David B. Robins; all rights reserved. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.8.0 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/lib/lib/Net/SSL.pm b/lib/lib/Net/SSL.pm new file mode 100644 index 0000000..e518009 --- /dev/null +++ b/lib/lib/Net/SSL.pm @@ -0,0 +1,666 @@ +package Net::SSL; + +use strict; +use MIME::Base64; +use Socket; +use Carp; + +use vars qw(@ISA $VERSION $NEW_ARGS); +$VERSION = '2.86'; +$VERSION = eval $VERSION; + +require IO::Socket; +@ISA=qw(IO::Socket::INET); + +my %REAL; # private to this package only +my $DEFAULT_VERSION = '23'; +my $CRLF = "\015\012"; +my $SEND_USERAGENT_TO_PROXY = 0; + +require Crypt::SSLeay; + +sub _default_context { + require Crypt::SSLeay::MainContext; + Crypt::SSLeay::MainContext::main_ctx(@_); +} + +sub _alarm_set { + return if $^O eq 'MSWin32' or $^O eq 'NetWare'; + alarm(shift); +} + +sub new { + my($class, %arg) = @_; + local $NEW_ARGS = \%arg; + $class->SUPER::new(%arg); +} + +sub DESTROY { + my $self = shift; + delete $REAL{$self}; + local $@; + eval { $self->SUPER::DESTROY; }; +} + +sub configure { + my($self, $arg) = @_; + my $ssl_version = delete $arg->{SSL_Version} || + $ENV{HTTPS_VERSION} || $DEFAULT_VERSION; + my $ssl_debug = delete $arg->{SSL_Debug} || $ENV{HTTPS_DEBUG} || 0; + + my $ctx = delete $arg->{SSL_Context} || _default_context($ssl_version); + + *$self->{ssl_ctx} = $ctx; + *$self->{ssl_version} = $ssl_version; + *$self->{ssl_debug} = $ssl_debug; + *$self->{ssl_arg} = $arg; + *$self->{ssl_peer_addr} = $arg->{PeerAddr}; + *$self->{ssl_peer_port} = $arg->{PeerPort}; + *$self->{ssl_new_arg} = $NEW_ARGS; + *$self->{ssl_peer_verify} = 0; + + ## Crypt::SSLeay must also aware the SSL Proxy before calling + ## $socket->configure($args). Because the $sock->configure() will + ## die when failed to resolve the destination server IP address, + ## whether the SSL proxy is used or not! + ## - dqbai, 2003-05-10 + if (my $proxy = $self->proxy) { + ($arg->{PeerAddr}, $arg->{PeerPort}) = split(':',$proxy); + $arg->{PeerPort} || croak("no port given for proxy server $proxy"); + } + + $self->SUPER::configure($arg); +} + +# override to make sure there is really a timeout +sub timeout { + shift->SUPER::timeout || 60; +} + +sub blocking { + my $self = shift; + $self->SUPER::blocking(@_); +} + +sub connect { + my $self = shift; + + # configure certs on connect() time, so we can throw an undef + # and have LWP understand the error + eval { $self->configure_certs() }; + if($@) { + $@ = "configure certs failed: $@; $!"; + $self->die_with_error($@); + } + + # finished, update set_verify status + if(my $rv = *$self->{ssl_ctx}->set_verify()) { + *$self->{ssl_peer_verify} = $rv; + } + + if ($self->proxy) { + # don't die() in connect, just return undef and set $@ + my $proxy_connect = eval { $self->proxy_connect_helper(@_) }; + if(! $proxy_connect || $@) { + $@ = "proxy connect failed: $@; $!"; + croak($@); + } + } + else { + *$self->{io_socket_peername}=@_ == 1 ? $_[0] : IO::Socket::sockaddr_in(@_); + if(!$self->SUPER::connect(@_)) { + # better to die than return here + $@ = "Connect failed: $@; $!"; + croak($@); + } + } + + my $debug = *$self->{ssl_debug} || 0; + my $ssl = Crypt::SSLeay::Conn->new(*$self->{ssl_ctx}, $debug, $self); + my $arg = *$self->{ssl_arg}; + my $new_arg = *$self->{ssl_new_arg}; + $arg->{SSL_Debug} = $debug; + + # setup SNI if available + $ssl->can("set_tlsext_host_name") and + $ssl->set_tlsext_host_name(*$self->{ssl_peer_addr}); + + eval { + local $SIG{ALRM} = sub { $self->die_with_error("SSL connect timeout") }; + # timeout / 2 because we have 3 possible connects here + _alarm_set($self->timeout / 2); + + my $rv; + { + local $SIG{PIPE} = \¨ + $rv = eval { $ssl->connect; }; + } + if (not defined $rv or $rv <= 0) { + _alarm_set(0); + $ssl = undef; + # See RT #59312 + my %args = (%$arg, %$new_arg); + if(*$self->{ssl_version} == 23) { + $args{SSL_Version} = 3; + # the new connect might itself be overridden with a REAL SSL + my $new_ssl = Net::SSL->new(%args); + $REAL{$self} = $REAL{$new_ssl} || $new_ssl; + return $REAL{$self}; + } + elsif(*$self->{ssl_version} == 3) { + # $self->die_with_error("SSL negotiation failed"); + $args{SSL_Version} = 2; + my $new_ssl = Net::SSL->new(%args); + $REAL{$self} = $new_ssl; + return $new_ssl; + } + else { + # don't die, but do set $@, and return undef + eval { $self->die_with_error("SSL negotiation failed") }; + croak($@); + } + } + _alarm_set(0); + }; + + # odd error in eval {} block, maybe alarm outside the evals + if($@) { + $@ = "$@; $!"; + croak($@); + } + + # successful SSL connection gets stored + *$self->{ssl_ssl} = $ssl; + $self; +} + +# Delegate these calls to the Crypt::SSLeay::Conn object +sub get_peer_certificate { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ssl}->get_peer_certificate(@_); +} + +sub get_peer_verify { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_peer_verify}; +} + +sub get_shared_ciphers { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ssl}->get_shared_ciphers(@_); +} + +sub get_cipher { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ssl}->get_cipher(@_); +} + +sub pending { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ssl}->pending(@_); +} + +sub ssl_context { + my $self = shift; + $self = $REAL{$self} || $self; + *$self->{ssl_ctx}; +} + +sub die_with_error { + my $self=shift; + my $reason=shift; + + my @err; + while(my $err=Crypt::SSLeay::Err::get_error_string()) { + push @err, $err; + } + croak("$reason: " . join( ' | ', @err )); +} + +sub read { + my $self = shift; + $self = $REAL{$self} || $self; + + local $SIG{__DIE__} = \&Carp::confess; + local $SIG{ALRM} = sub { $self->die_with_error("SSL read timeout") }; + + _alarm_set($self->timeout); + my $n = *$self->{ssl_ssl}->read(@_); + _alarm_set(0); + $self->die_with_error("read failed") if !defined $n; + + $n; +} + +sub write { + my $self = shift; + $self = $REAL{$self} || $self; + my $n = *$self->{ssl_ssl}->write(@_); + $self->die_with_error("write failed") if !defined $n; + $n; +} + +*sysread = \&read; +*syswrite = \&write; + +sub print { + my $self = shift; + $self = $REAL{$self} || $self; + # should we care about $, and $\?? + # I think it is too expensive... + $self->write(join("", @_)); +} + +sub printf { + my $self = shift; + $self = $REAL{$self} || $self; + my $fmt = shift; + $self->write(sprintf($fmt, @_)); +} + +sub getchunk { + my $self = shift; + $self = $REAL{$self} || $self; + my $buf = ''; # warnings + my $n = $self->read($buf, 32768); + return unless defined $n; + $buf; +} + +# This is really inefficient, but we only use it for reading the proxy response +# so that does not really matter. +sub getline { + my $self = shift; + $self = $REAL{$self} || $self; + my $val=""; + my $buf; + do { + $self->SUPER::recv($buf, 1); + $val .= $buf; + } until ($buf eq "\n"); + + $val; +} + +# XXX: no way to disable <$sock>?? (tied handle perhaps?) + +sub get_lwp_object { + my $self = shift; + + my $lwp_object; + my $i = 0; + while(1) { + package DB; + my @stack = caller($i++); + last unless @stack; + my @stack_args = @DB::args; + my $stack_object = $stack_args[0] || next; + return $stack_object + if ref($stack_object) + and $stack_object->isa('LWP::UserAgent'); + } + return undef; +} + +sub send_useragent_to_proxy { + if (my $val = shift) { + $SEND_USERAGENT_TO_PROXY = $val; + } + return $SEND_USERAGENT_TO_PROXY; +} + +sub proxy_connect_helper { + my $self = shift; + + my $proxy = $self->proxy; + my ($proxy_host, $proxy_port) = split(':',$proxy); + $proxy_port || croak("no port given for proxy server $proxy"); + + my $proxy_addr = gethostbyname($proxy_host); + $proxy_addr || croak("can't resolve proxy server name: $proxy_host, $!"); + + my($peer_port, $peer_addr) = (*$self->{ssl_peer_port}, *$self->{ssl_peer_addr}); + $peer_addr || croak("no peer addr given"); + $peer_port || croak("no peer port given"); + + # see if the proxy should be bypassed + my @no_proxy = split( /\s*,\s*/, $ENV{NO_PROXY} || $ENV{no_proxy} || ''); + my $is_proxied = 1; + my $domain; + for $domain (@no_proxy) { + if ($peer_addr =~ /\Q$domain\E$/) { + $is_proxied = 0; + last; + } + } + + if ($is_proxied) { + $self->SUPER::connect($proxy_port, $proxy_addr) + || croak("proxy connect to $proxy_host:$proxy_port failed: $!"); + } + else { + # see RT #57836 + my $peer_addr_packed = gethostbyname($peer_addr); + $self->SUPER::connect($peer_port, $peer_addr_packed) + || croak("proxy bypass to $peer_addr:$peer_addr failed: $!"); + } + + my $connect_string; + if ($ENV{"HTTPS_PROXY_USERNAME"} || $ENV{"HTTPS_PROXY_PASSWORD"}) { + my $user = $ENV{"HTTPS_PROXY_USERNAME"}; + my $pass = $ENV{"HTTPS_PROXY_PASSWORD"}; + + my $credentials = encode_base64("$user:$pass", ""); + $connect_string = join($CRLF, + "CONNECT $peer_addr:$peer_port HTTP/1.0", + "Proxy-authorization: Basic $credentials" + ); + } + else { + $connect_string = "CONNECT $peer_addr:$peer_port HTTP/1.0"; + } + $connect_string .= $CRLF; + + if (send_useragent_to_proxy()) { + my $lwp_object = $self->get_lwp_object; + if($lwp_object && $lwp_object->agent) { + $connect_string .= "User-Agent: ".$lwp_object->agent.$CRLF; + } + } + + $connect_string .= $CRLF; + $self->SUPER::send($connect_string); + + my $timeout; + my $header = ''; + + # See RT #33954 + # See also RT #64054 + # Handling incomplete reads and writes better (for some values of + # better) may actually make this problem go away, but either way, + # there is no good reason to use \d when checking for 0-9 + + while ($header !~ m{HTTP/[0-9][.][0-9]\s+200\s+.*$CRLF$CRLF}s) { + $timeout = $self->timeout(5) unless length $header; + my $n = $self->SUPER::sysread($header, 8192, length $header); + last if $n <= 0; + } + + $self->timeout($timeout) if defined $timeout; + my $conn_ok = ($header =~ m{HTTP/[0-9]+[.][0-9]+\s+200\s+}is) ? 1 : 0; + + if (not $conn_ok) { + croak("PROXY ERROR HEADER, could be non-SSL URL:\n$header"); + } + + $conn_ok; +} + +# code adapted from LWP::UserAgent, with $ua->env_proxy API +# see also RT #57836 +sub proxy { + my $self = shift; + my $proxy_server = $ENV{HTTPS_PROXY} || $ENV{https_proxy}; + return unless $proxy_server; + + my($peer_port, $peer_addr) = ( + *$self->{ssl_peer_port}, + *$self->{ssl_peer_addr} + ); + $peer_addr || croak("no peer addr given"); + $peer_port || croak("no peer port given"); + + # see if the proxy should be bypassed + my @no_proxy = split( /\s*,\s*/, + $ENV{NO_PROXY} || $ENV{no_proxy} || '' + ); + my $is_proxied = 1; + for my $domain (@no_proxy) { + if ($peer_addr =~ /\Q$domain\E\z/) { + return; + } + } + + $proxy_server =~ s|\Ahttps?://||i; + # sanitize the end of the string too + # see also http://www.nntp.perl.org/group/perl.libwww/2012/10/msg7629.html + # and https://github.com/nanis/Crypt-SSLeay/pull/1 + # Thank you Mark Allen and YigangX Wen + $proxy_server =~ s|(:[1-9][0-9]{0,4})/\z|$1|; + $proxy_server; +} + +sub configure_certs { + my $self = shift; + my $ctx = *$self->{ssl_ctx}; + + my $count = 0; + for (qw(HTTPS_PKCS12_FILE HTTPS_CERT_FILE HTTPS_KEY_FILE)) { + my $file = $ENV{$_}; + if ($file) { + (-e $file) or croak("$file file does not exist: $!"); + (-r $file) or croak("$file file is not readable"); + $count++; + if (/PKCS12/) { + $count++; + $ctx->use_pkcs12_file($file ,$ENV{'HTTPS_PKCS12_PASSWORD'}) || croak("failed to load $file: $!"); + last; + } + elsif (/CERT/) { + $ctx->use_certificate_file($file ,1) || croak("failed to load $file: $!"); + } + elsif (/KEY/) { + $ctx->use_PrivateKey_file($file, 1) || croak("failed to load $file: $!"); + } + else { + croak("setting $_ not supported"); + } + } + } + + # if both configs are set, then verify them + if ($count == 2) { + if (! $ctx->check_private_key) { + croak("Private key and certificate do not match"); + } + } + + $count; # number of successful cert loads/checks +} + +sub accept { shift->_unimpl("accept") } +sub getc { shift->_unimpl("getc") } +sub ungetc { shift->_unimpl("ungetc") } +sub getlines { shift->_unimpl("getlines"); } + +sub _unimpl { + my($self, $meth) = @_; + croak("$meth not implemented for Net::SSL sockets"); +} + +1; + +__END__ + +=head1 NAME + +Net::SSL - support for Secure Sockets Layer + +=head1 METHODS + +=over 4 + +=item new + +Creates a new C object. + +=item configure + +Configures a C socket for operation. + +=item configure_certs + +Sets up a certificate file to use for communicating with on +the socket. + +=item connect + +=item die_with_error + +=item get_cipher + +=item get_lwp_object + +Walks up the caller stack and looks for something blessed into +the C namespace and returns it. Vaguely deprecated. + +=item get_peer_certificate + +Gets the peer certificate from the underlying C +object. + +=item get_peer_verify + +=item get_shared_ciphers + +=item getchunk + +Attempts to read up to 32KiB of data from the socket. Returns +C if nothing was read, otherwise returns the data as +a scalar. + +=item pending + +Provides access to OpenSSL's C attribute on the SSL connection +object. + +=item getline + +Reads one character at a time until a newline is encountered, +and returns the line, including the newline. Grossly +inefficient. + +=item print + +Concatenates the input parameters and writes them to the socket. +Does not honour C<$,> nor C<$/>. Returns the number of bytes written. + +=item printf + +Performs a C of the input parameters (thus, the first +parameter must be the format), and writes the result to the socket. +Returns the number of bytes written. + +=item proxy + +Returns the hostname of an https proxy server, as specified by the +C environment variable. + +=item proxy_connect_helper + +Helps set up a connection through a proxy. + +=item read + +Performs a read on the socket and returns the result. + +=item ssl_context + +=item sysread + +Is an alias of C. + +=item timeout + +Returns the timeout value of the socket as defined by the implementing +class or 60 seconds by default. + +=item blocking + +Returns a boolean indicating whether the underlying socket is in +blocking mode. By default, Net::SSL sockets are in blocking mode. + + $sock->blocking(0); # set to non-blocking mode + +This method simply calls the underlying C method of the +IO::Socket object. + +=item write + +Writes the parameters passed in (thus, a list) to the socket. Returns +the number of bytes written. + +=item syswrite + +Is an alias of C. + +=item accept + +Not yet implemented. Will die if called. + +=item getc + +Not yet implemented. Will die if called. + +=item getlines + +Not yet implemented. Will die if called. + +=item ungetc + +Not yet implemented. Will die if called. + +=item send_useragent_to_proxy + +By default (as of version 2.80 of C in the 0.54 distribution +of Crypt::SSLeay), the user agent string is no longer sent to the +proxy (but will continue to be sent to the remote host). + +The previous behaviour was of marginal benefit, and could cause +fatal errors in certain scenarios (see CPAN bug #4759) and so no +longer happens by default. + +To reinstate the old behaviour, call C +with a true value (usually 1). + +=back + +=head1 DIAGNOSTICS + + "no port given for proxy server " + +A proxy was specified for configuring a socket, but no port number +was given. Ensure that the proxy is specified as a host:port pair, +such as C. + + "configure certs failed: ; " + + "proxy connect failed: ; " + + "Connect failed: ; " + +During connect(). + +=head2 SEE ALSO + +=over 4 + +=item IO::Socket::INET + +C is implemented by subclassing C, hence +methods not specifically overridden are defined by that package. + +=item Net::SSLeay + +A package that provides a Perl-level interface to the C +secure sockets layer library. + +=back + +=cut + diff --git a/lib/lib/Net/SSLeay.pm b/lib/lib/Net/SSLeay.pm new file mode 100644 index 0000000..3adf12c --- /dev/null +++ b/lib/lib/Net/SSLeay.pm @@ -0,0 +1,1464 @@ +# Net::SSLeay.pm - Perl module for using Eric Young's implementation of SSL +# +# Copyright (c) 1996-2003 Sampo Kellomaki , All Rights Reserved. +# Copyright (C) 2005 Florian Ragwitz , All Rights Reserved. +# Copyright (C) 2005 Mike McCauley , All Rights Reserved. +# +# $Id: SSLeay.pm 516 2018-01-17 03:10:55Z mikem-guest $ +# +# Change data removed from here. See Changes +# The distribution and use of this module are subject to the conditions +# listed in LICENSE file at the root of the Net-SSLeay +# distribution (i.e. same license as Perl itself). + +package Net::SSLeay; + +use strict; +use Carp; +use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD $CRLF); +use Socket; +use Errno; +require 5.005_000; + +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 +# 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.85'; # Dont forget to set version in META.yml too +@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_ms_sgc R_SSL_SESSION_ID_IS_DIFFERENT + ASN1_STRFLGS_ESC_MSB NID_name R_UNABLE_TO_EXTRACT_PUBLIC_KEY + ASN1_STRFLGS_ESC_QUOTE NID_netscape R_UNKNOWN_REMOTE_ERROR_TYPE + ASN1_STRFLGS_RFC2253 NID_netscape_base_url R_UNKNOWN_STATE + CB_ACCEPT_EXIT NID_netscape_ca_policy_url R_X509_LIB + CB_ACCEPT_LOOP NID_netscape_ca_revocation_url SENT_SHUTDOWN + CB_ALERT NID_netscape_cert_extension SESSION_ASN1_VERSION + CB_CONNECT_EXIT NID_netscape_cert_sequence SESS_CACHE_BOTH + CB_CONNECT_LOOP NID_netscape_cert_type SESS_CACHE_CLIENT + CB_EXIT NID_netscape_comment SESS_CACHE_NO_AUTO_CLEAR + CB_HANDSHAKE_DONE NID_netscape_data_type SESS_CACHE_NO_INTERNAL + CB_HANDSHAKE_START NID_netscape_renewal_url SESS_CACHE_NO_INTERNAL_LOOKUP + CB_LOOP NID_netscape_revocation_url SESS_CACHE_NO_INTERNAL_STORE + CB_READ NID_netscape_ssl_server_name SESS_CACHE_OFF + CB_READ_ALERT NID_ns_sgc SESS_CACHE_SERVER + CB_WRITE NID_organizationName SSL3_VERSION + CB_WRITE_ALERT NID_organizationalUnitName SSLEAY_BUILT_ON + ERROR_NONE NID_pbeWithMD2AndDES_CBC SSLEAY_CFLAGS + ERROR_SSL NID_pbeWithMD2AndRC2_CBC SSLEAY_DIR + ERROR_SYSCALL NID_pbeWithMD5AndCast5_CBC SSLEAY_PLATFORM + ERROR_WANT_ACCEPT NID_pbeWithMD5AndDES_CBC SSLEAY_VERSION + ERROR_WANT_CONNECT NID_pbeWithMD5AndRC2_CBC ST_ACCEPT + ERROR_WANT_READ NID_pbeWithSHA1AndDES_CBC ST_BEFORE + ERROR_WANT_WRITE NID_pbeWithSHA1AndRC2_CBC ST_CONNECT + ERROR_WANT_X509_LOOKUP NID_pbe_WithSHA1And128BitRC2_CBC ST_INIT + ERROR_ZERO_RETURN NID_pbe_WithSHA1And128BitRC4 ST_OK + EVP_PKS_DSA NID_pbe_WithSHA1And2_Key_TripleDES_CBC ST_READ_BODY + EVP_PKS_EC NID_pbe_WithSHA1And3_Key_TripleDES_CBC ST_READ_HEADER + EVP_PKS_RSA NID_pbe_WithSHA1And40BitRC2_CBC TLS1_1_VERSION + EVP_PKT_ENC NID_pbe_WithSHA1And40BitRC4 TLS1_2_VERSION + EVP_PKT_EXCH NID_pbes2 TLS1_3_VERSION + EVP_PKT_EXP NID_pbmac1 TLS1_VERSION + EVP_PKT_SIGN NID_pkcs TLSEXT_STATUSTYPE_ocsp + EVP_PK_DH NID_pkcs3 VERIFY_CLIENT_ONCE + EVP_PK_DSA NID_pkcs7 VERIFY_FAIL_IF_NO_PEER_CERT + EVP_PK_EC NID_pkcs7_data VERIFY_NONE + EVP_PK_RSA NID_pkcs7_digest VERIFY_PEER + FILETYPE_ASN1 NID_pkcs7_encrypted V_OCSP_CERTSTATUS_GOOD + FILETYPE_PEM NID_pkcs7_enveloped V_OCSP_CERTSTATUS_REVOKED + F_CLIENT_CERTIFICATE NID_pkcs7_signed V_OCSP_CERTSTATUS_UNKNOWN + F_CLIENT_HELLO NID_pkcs7_signedAndEnveloped WRITING + F_CLIENT_MASTER_KEY NID_pkcs8ShroudedKeyBag X509_CHECK_FLAG_ALWAYS_CHECK_SUBJECT + F_D2I_SSL_SESSION NID_pkcs9 X509_CHECK_FLAG_MULTI_LABEL_WILDCARDS + F_GET_CLIENT_FINISHED NID_pkcs9_challengePassword X509_CHECK_FLAG_NEVER_CHECK_SUBJECT + F_GET_CLIENT_HELLO NID_pkcs9_contentType X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS + F_GET_CLIENT_MASTER_KEY NID_pkcs9_countersignature X509_CHECK_FLAG_NO_WILDCARDS + F_GET_SERVER_FINISHED NID_pkcs9_emailAddress X509_CHECK_FLAG_SINGLE_LABEL_SUBDOMAINS + F_GET_SERVER_HELLO NID_pkcs9_extCertAttributes X509_LOOKUP + F_GET_SERVER_VERIFY NID_pkcs9_messageDigest X509_PURPOSE_ANY + F_I2D_SSL_SESSION NID_pkcs9_signingTime X509_PURPOSE_CRL_SIGN + F_READ_N NID_pkcs9_unstructuredAddress X509_PURPOSE_NS_SSL_SERVER + F_REQUEST_CERTIFICATE NID_pkcs9_unstructuredName X509_PURPOSE_OCSP_HELPER + F_SERVER_HELLO NID_private_key_usage_period X509_PURPOSE_SMIME_ENCRYPT + F_SSL_CERT_NEW NID_rc2_40_cbc X509_PURPOSE_SMIME_SIGN + F_SSL_GET_NEW_SESSION NID_rc2_64_cbc X509_PURPOSE_SSL_CLIENT + F_SSL_NEW NID_rc2_cbc X509_PURPOSE_SSL_SERVER + F_SSL_READ NID_rc2_cfb64 X509_PURPOSE_TIMESTAMP_SIGN + F_SSL_RSA_PRIVATE_DECRYPT NID_rc2_ecb X509_TRUST_COMPAT + F_SSL_RSA_PUBLIC_ENCRYPT NID_rc2_ofb64 X509_TRUST_EMAIL + F_SSL_SESSION_NEW NID_rc4 X509_TRUST_OBJECT_SIGN + F_SSL_SESSION_PRINT_FP NID_rc4_40 X509_TRUST_OCSP_REQUEST + F_SSL_SET_FD NID_rc5_cbc X509_TRUST_OCSP_SIGN + F_SSL_SET_RFD NID_rc5_cfb64 X509_TRUST_SSL_CLIENT + F_SSL_SET_WFD NID_rc5_ecb X509_TRUST_SSL_SERVER + F_SSL_USE_CERTIFICATE NID_rc5_ofb64 X509_TRUST_TSA + F_SSL_USE_CERTIFICATE_ASN1 NID_ripemd160 X509_V_ERR_AKID_ISSUER_SERIAL_MISMATCH + F_SSL_USE_CERTIFICATE_FILE NID_ripemd160WithRSA X509_V_ERR_AKID_SKID_MISMATCH + F_SSL_USE_PRIVATEKEY NID_rle_compression X509_V_ERR_APPLICATION_VERIFICATION + F_SSL_USE_PRIVATEKEY_ASN1 NID_rsa X509_V_ERR_CA_KEY_TOO_SMALL + F_SSL_USE_PRIVATEKEY_FILE NID_rsaEncryption X509_V_ERR_CA_MD_TOO_WEAK + F_SSL_USE_RSAPRIVATEKEY NID_rsadsi X509_V_ERR_CERT_CHAIN_TOO_LONG + F_SSL_USE_RSAPRIVATEKEY_ASN1 NID_safeContentsBag X509_V_ERR_CERT_HAS_EXPIRED + F_SSL_USE_RSAPRIVATEKEY_FILE NID_sdsiCertificate X509_V_ERR_CERT_NOT_YET_VALID + F_WRITE_PENDING NID_secretBag X509_V_ERR_CERT_REJECTED + GEN_DIRNAME NID_serialNumber X509_V_ERR_CERT_REVOKED + GEN_DNS NID_server_auth X509_V_ERR_CERT_SIGNATURE_FAILURE + GEN_EDIPARTY NID_sha X509_V_ERR_CERT_UNTRUSTED + GEN_EMAIL NID_sha1 X509_V_ERR_CRL_HAS_EXPIRED + GEN_IPADD NID_sha1WithRSA X509_V_ERR_CRL_NOT_YET_VALID + GEN_OTHERNAME NID_sha1WithRSAEncryption X509_V_ERR_CRL_PATH_VALIDATION_ERROR + GEN_RID NID_shaWithRSAEncryption X509_V_ERR_CRL_SIGNATURE_FAILURE + GEN_URI NID_stateOrProvinceName X509_V_ERR_DANE_NO_MATCH + GEN_X400 NID_subject_alt_name X509_V_ERR_DEPTH_ZERO_SELF_SIGNED_CERT + LIBRESSL_VERSION_NUMBER NID_subject_key_identifier X509_V_ERR_DIFFERENT_CRL_SCOPE + MBSTRING_ASC NID_surname X509_V_ERR_EE_KEY_TOO_SMALL + MBSTRING_BMP NID_sxnet X509_V_ERR_EMAIL_MISMATCH + MBSTRING_FLAG NID_time_stamp X509_V_ERR_ERROR_IN_CERT_NOT_AFTER_FIELD + MBSTRING_UNIV NID_title X509_V_ERR_ERROR_IN_CERT_NOT_BEFORE_FIELD + MBSTRING_UTF8 NID_undef X509_V_ERR_ERROR_IN_CRL_LAST_UPDATE_FIELD + MIN_RSA_MODULUS_LENGTH_IN_BYTES NID_uniqueIdentifier X509_V_ERR_ERROR_IN_CRL_NEXT_UPDATE_FIELD + MODE_ACCEPT_MOVING_WRITE_BUFFER NID_x509Certificate X509_V_ERR_EXCLUDED_VIOLATION + MODE_AUTO_RETRY NID_x509Crl X509_V_ERR_HOSTNAME_MISMATCH + MODE_ENABLE_PARTIAL_WRITE NID_zlib_compression X509_V_ERR_INVALID_CA + MODE_RELEASE_BUFFERS NOTHING X509_V_ERR_INVALID_CALL + NID_OCSP_sign OCSP_RESPONSE_STATUS_INTERNALERROR X509_V_ERR_INVALID_EXTENSION + NID_SMIMECapabilities OCSP_RESPONSE_STATUS_MALFORMEDREQUEST X509_V_ERR_INVALID_NON_CA + NID_X500 OCSP_RESPONSE_STATUS_SIGREQUIRED X509_V_ERR_INVALID_POLICY_EXTENSION + NID_X509 OCSP_RESPONSE_STATUS_SUCCESSFUL X509_V_ERR_INVALID_PURPOSE + NID_ad_OCSP OCSP_RESPONSE_STATUS_TRYLATER X509_V_ERR_IP_ADDRESS_MISMATCH + NID_ad_ca_issuers OCSP_RESPONSE_STATUS_UNAUTHORIZED X509_V_ERR_KEYUSAGE_NO_CERTSIGN + NID_algorithm OPENSSL_BUILT_ON X509_V_ERR_KEYUSAGE_NO_CRL_SIGN + NID_authority_key_identifier OPENSSL_CFLAGS X509_V_ERR_KEYUSAGE_NO_DIGITAL_SIGNATURE + NID_basic_constraints OPENSSL_DIR X509_V_ERR_NO_EXPLICIT_POLICY + NID_bf_cbc OPENSSL_ENGINES_DIR X509_V_ERR_NO_VALID_SCTS + NID_bf_cfb64 OPENSSL_PLATFORM X509_V_ERR_OCSP_CERT_UNKNOWN + NID_bf_ecb OPENSSL_VERSION X509_V_ERR_OCSP_VERIFY_FAILED + NID_bf_ofb64 OPENSSL_VERSION_NUMBER X509_V_ERR_OCSP_VERIFY_NEEDED + NID_cast5_cbc OP_ALL X509_V_ERR_OUT_OF_MEM + NID_cast5_cfb64 OP_ALLOW_NO_DHE_KEX X509_V_ERR_PATH_LENGTH_EXCEEDED + NID_cast5_ecb OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION X509_V_ERR_PATH_LOOP + NID_cast5_ofb64 OP_CIPHER_SERVER_PREFERENCE X509_V_ERR_PERMITTED_VIOLATION + NID_certBag OP_CISCO_ANYCONNECT X509_V_ERR_PROXY_CERTIFICATES_NOT_ALLOWED + NID_certificate_policies OP_COOKIE_EXCHANGE X509_V_ERR_PROXY_PATH_LENGTH_EXCEEDED + NID_client_auth OP_CRYPTOPRO_TLSEXT_BUG X509_V_ERR_PROXY_SUBJECT_NAME_VIOLATION + NID_code_sign OP_DONT_INSERT_EMPTY_FRAGMENTS X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN + NID_commonName OP_EPHEMERAL_RSA X509_V_ERR_STORE_LOOKUP + NID_countryName OP_LEGACY_SERVER_CONNECT X509_V_ERR_SUBJECT_ISSUER_MISMATCH + NID_crlBag OP_MICROSOFT_BIG_SSLV3_BUFFER X509_V_ERR_SUBTREE_MINMAX + NID_crl_distribution_points OP_MICROSOFT_SESS_ID_BUG X509_V_ERR_SUITE_B_CANNOT_SIGN_P_384_WITH_P_256 + NID_crl_number OP_MSIE_SSLV2_RSA_PADDING X509_V_ERR_SUITE_B_INVALID_ALGORITHM + NID_crl_reason OP_NETSCAPE_CA_DN_BUG X509_V_ERR_SUITE_B_INVALID_CURVE + NID_delta_crl OP_NETSCAPE_CHALLENGE_BUG X509_V_ERR_SUITE_B_INVALID_SIGNATURE_ALGORITHM + NID_des_cbc OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG X509_V_ERR_SUITE_B_INVALID_VERSION + NID_des_cfb64 OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG X509_V_ERR_SUITE_B_LOS_NOT_ALLOWED + NID_des_ecb OP_NON_EXPORT_FIRST X509_V_ERR_UNABLE_TO_DECODE_ISSUER_PUBLIC_KEY + NID_des_ede OP_NO_CLIENT_RENEGOTIATION X509_V_ERR_UNABLE_TO_DECRYPT_CERT_SIGNATURE + NID_des_ede3 OP_NO_COMPRESSION X509_V_ERR_UNABLE_TO_DECRYPT_CRL_SIGNATURE + NID_des_ede3_cbc OP_NO_ENCRYPT_THEN_MAC X509_V_ERR_UNABLE_TO_GET_CRL + NID_des_ede3_cfb64 OP_NO_QUERY_MTU X509_V_ERR_UNABLE_TO_GET_CRL_ISSUER + NID_des_ede3_ofb64 OP_NO_RENEGOTIATION X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT + NID_des_ede_cbc OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION X509_V_ERR_UNABLE_TO_GET_ISSUER_CERT_LOCALLY + NID_des_ede_cfb64 OP_NO_SSL_MASK X509_V_ERR_UNABLE_TO_VERIFY_LEAF_SIGNATURE + NID_des_ede_ofb64 OP_NO_SSLv2 X509_V_ERR_UNHANDLED_CRITICAL_CRL_EXTENSION + NID_des_ofb64 OP_NO_SSLv3 X509_V_ERR_UNHANDLED_CRITICAL_EXTENSION + NID_description OP_NO_TICKET X509_V_ERR_UNNESTED_RESOURCE + NID_desx_cbc OP_NO_TLSv1 X509_V_ERR_UNSPECIFIED + NID_dhKeyAgreement OP_NO_TLSv1_1 X509_V_ERR_UNSUPPORTED_CONSTRAINT_SYNTAX + NID_dnQualifier OP_NO_TLSv1_2 X509_V_ERR_UNSUPPORTED_CONSTRAINT_TYPE + NID_dsa OP_NO_TLSv1_3 X509_V_ERR_UNSUPPORTED_EXTENSION_FEATURE + NID_dsaWithSHA OP_PKCS1_CHECK_1 X509_V_ERR_UNSUPPORTED_NAME_SYNTAX + NID_dsaWithSHA1 OP_PKCS1_CHECK_2 X509_V_FLAG_ALLOW_PROXY_CERTS + NID_dsaWithSHA1_2 OP_PRIORITIZE_CHACHA X509_V_FLAG_CB_ISSUER_CHECK + NID_dsa_2 OP_SAFARI_ECDHE_ECDSA_BUG X509_V_FLAG_CHECK_SS_SIGNATURE + NID_email_protect OP_SINGLE_DH_USE X509_V_FLAG_CRL_CHECK + NID_ext_key_usage OP_SINGLE_ECDH_USE X509_V_FLAG_CRL_CHECK_ALL + NID_ext_req OP_SSLEAY_080_CLIENT_DH_BUG X509_V_FLAG_EXPLICIT_POLICY + NID_friendlyName OP_SSLREF2_REUSE_CERT_TYPE_BUG X509_V_FLAG_EXTENDED_CRL_SUPPORT + NID_givenName OP_TLSEXT_PADDING X509_V_FLAG_IGNORE_CRITICAL + NID_hmacWithSHA1 OP_TLS_BLOCK_PADDING_BUG X509_V_FLAG_INHIBIT_ANY + NID_id_ad OP_TLS_D5_BUG X509_V_FLAG_INHIBIT_MAP + NID_id_ce OP_TLS_ROLLBACK_BUG X509_V_FLAG_NOTIFY_POLICY + NID_id_kp READING X509_V_FLAG_NO_ALT_CHAINS + NID_id_pbkdf2 RECEIVED_SHUTDOWN X509_V_FLAG_NO_CHECK_TIME + NID_id_pe RSA_3 X509_V_FLAG_PARTIAL_CHAIN + NID_id_pkix RSA_F4 X509_V_FLAG_POLICY_CHECK + NID_id_qt_cps R_BAD_AUTHENTICATION_TYPE X509_V_FLAG_POLICY_MASK + NID_id_qt_unotice R_BAD_CHECKSUM X509_V_FLAG_SUITEB_128_LOS + NID_idea_cbc R_BAD_MAC_DECODE X509_V_FLAG_SUITEB_128_LOS_ONLY + NID_idea_cfb64 R_BAD_RESPONSE_ARGUMENT X509_V_FLAG_SUITEB_192_LOS + NID_idea_ecb R_BAD_SSL_FILETYPE X509_V_FLAG_TRUSTED_FIRST + NID_idea_ofb64 R_BAD_SSL_SESSION_ID_LENGTH X509_V_FLAG_USE_CHECK_TIME + NID_info_access R_BAD_STATE X509_V_FLAG_USE_DELTAS + NID_initials R_BAD_WRITE_RETRY X509_V_FLAG_X509_STRICT + NID_invalidity_date R_CHALLENGE_IS_DIFFERENT X509_V_OK + NID_issuer_alt_name R_CIPHER_TABLE_SRC_ERROR XN_FLAG_COMPAT + NID_keyBag R_INVALID_CHALLENGE_LENGTH XN_FLAG_DN_REV + NID_key_usage R_NO_CERTIFICATE_SET XN_FLAG_DUMP_UNKNOWN_FIELDS + NID_localKeyID R_NO_CERTIFICATE_SPECIFIED XN_FLAG_FN_ALIGN + NID_localityName R_NO_CIPHER_LIST XN_FLAG_FN_LN + NID_md2 R_NO_CIPHER_MATCH XN_FLAG_FN_MASK + NID_md2WithRSAEncryption R_NO_PRIVATEKEY XN_FLAG_FN_NONE + NID_md5 R_NO_PUBLICKEY XN_FLAG_FN_OID + NID_md5WithRSA R_NULL_SSL_CTX XN_FLAG_FN_SN + NID_md5WithRSAEncryption R_PEER_DID_NOT_RETURN_A_CERTIFICATE XN_FLAG_MULTILINE + NID_md5_sha1 R_PEER_ERROR XN_FLAG_ONELINE + NID_mdc2 R_PEER_ERROR_CERTIFICATE XN_FLAG_RFC2253 + NID_mdc2WithRSA R_PEER_ERROR_NO_CIPHER XN_FLAG_SEP_COMMA_PLUS + NID_ms_code_com R_PEER_ERROR_UNSUPPORTED_CERTIFICATE_TYPE XN_FLAG_SEP_CPLUS_SPC + NID_ms_code_ind R_PUBLIC_KEY_ENCRYPT_ERROR XN_FLAG_SEP_MASK + NID_ms_ctl_sign R_PUBLIC_KEY_IS_NOT_RSA XN_FLAG_SEP_MULTILINE + NID_ms_efs R_READ_WRONG_PACKET_TYPE XN_FLAG_SEP_SPLUS_SPC + NID_ms_ext_req R_SHORT_READ 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, $errs); + my $reply = ''; + + while ($how_much > 0) { + $got = Net::SSLeay::read($ssl, + ($how_much > 32768) ? 32768 : $how_much + ); + last if $errs = print_errs('SSL_read'); + $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::read($ssl, $found+$len_delim); + #read up to the end of the delimiter + $got = Net::SSLeay::read($ssl, + $found + $len_delim + - ((blength($match)) - (blength($got)))); + $done = 1; + } else { + $got = Net::SSLeay::read($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::read($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; + } + 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); + $errs .= print_errs("private key `$key_path' ($!)"); + CTX_use_certificate_file ($ctx, $cert_path, &FILETYPE_PEM); + $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__ + diff --git a/lib/lib/Net/SSLeay.pod b/lib/lib/Net/SSLeay.pod new file mode 100644 index 0000000..2e1aae3 --- /dev/null +++ b/lib/lib/Net/SSLeay.pod @@ -0,0 +1,9180 @@ +=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 + +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 + +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 + +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. + + 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_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 + +Transforms the external ASN1 representation of an SSL/TLS session, stored as binary data +at location pp with length of $length, into an SSL_SESSION object. + +??? (does this function really work?) + + my $rv = Net::SSLeay::d2i_SSL_SESSION($a, $pp, $length); + # $a - value corresponding to openssl's SSL_SESSION structure + # $pp - pointer/buffer ??? + # $length - ??? + # + # returns: ??? + +Check openssl doc L + +=item * i2d_SSL_SESSION + +Transforms the SSL_SESSION object in into the ASN1 representation and stores it +into the memory location pointed to by pp. The length of the resulting ASN1 +representation is returned. + +??? (does this function really work?) + + my $rv = Net::SSLeay::i2d_SSL_SESSION($in, $pp); + # $in - value corresponding to openssl's SSL_SESSION structure + # $pp - pointer/data ??? + # + # returns: 1 on success, 0 + +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_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) + + #to decode the return value (bitmask) use: + 0x00 corresponds to SSL_VERIFY_NONE + 0x01 corresponds to SSL_VERIFY_PEER + 0x02 corresponds to SSL_VERIFY_FAIL_IF_NO_PEER_CERT + 0x04 corresponds to SSL_VERIFY_CLIENT_ONCE + (note: some of the bits might not be supported by older openssl versions) + +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) + # $callback - [optional] reference to perl callback function + # + # returns: no return value + +For bitmask details see L (above). + +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_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_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 + +=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_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 a buffer of $req_len bytes of keying material based on the constant string $label using the +masterkey and client and server random strings as described in +draft-ietf-pppext-eap-ttls-01.txt and See rfc2716 +If p is present, it will be concatenated before generating the keying material +Returns undef on error + + my $out = Net::SSLeay::export_keying_material($ssl, $req_len, $label, $p); + + + +=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 * get_state + +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 * 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_read(). + +=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 * 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 * 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_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 * version + +Returns SSL/TLS protocol version + + my $rv = Net::SSLeay::version($ssl); + # $ssl - value corresponding to openssl's SSL structure + # + # returns: (integer) protocol version + # 0x0002 - SSL2_VERSION (SSLv2) + # 0x0300 - SSL3_VERSION (SSLv3) + # 0x0301 - TLS1_VERSION (TLSv1) + # 0xFEFF - DTLS1_VERSION (DTLSv1) + +=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_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. + + 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, 0 otherwise + +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 + +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_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" + +=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_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. + +=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_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_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_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, "t/data/cert.pem", "t/data/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, "t/data/cert.pem", "t/data/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. + +=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_id_qt_cps OP_NO_QUERY_MTU + ASN1_STRFLGS_ESC_MSB NID_id_qt_unotice OP_NO_RENEGOTIATION + ASN1_STRFLGS_ESC_QUOTE NID_idea_cbc OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION + ASN1_STRFLGS_RFC2253 NID_idea_cfb64 OP_NO_SSL_MASK + CB_ACCEPT_EXIT NID_idea_ecb OP_NO_SSLv2 + CB_ACCEPT_LOOP NID_idea_ofb64 OP_NO_SSLv3 + CB_ALERT NID_info_access OP_NO_TICKET + CB_CONNECT_EXIT NID_initials OP_NO_TLSv1 + CB_CONNECT_LOOP NID_invalidity_date OP_NO_TLSv1_1 + CB_EXIT NID_issuer_alt_name OP_NO_TLSv1_2 + CB_HANDSHAKE_DONE NID_keyBag OP_NO_TLSv1_3 + CB_HANDSHAKE_START NID_key_usage OP_PKCS1_CHECK_1 + CB_LOOP NID_localKeyID OP_PKCS1_CHECK_2 + CB_READ NID_localityName OP_PRIORITIZE_CHACHA + CB_READ_ALERT NID_md2 OP_SAFARI_ECDHE_ECDSA_BUG + CB_WRITE NID_md2WithRSAEncryption OP_SINGLE_DH_USE + CB_WRITE_ALERT NID_md5 OP_SINGLE_ECDH_USE + ERROR_NONE NID_md5WithRSA OP_SSLEAY_080_CLIENT_DH_BUG + ERROR_SSL NID_md5WithRSAEncryption OP_SSLREF2_REUSE_CERT_TYPE_BUG + ERROR_SYSCALL NID_md5_sha1 OP_TLSEXT_PADDING + ERROR_WANT_ACCEPT NID_mdc2 OP_TLS_BLOCK_PADDING_BUG + ERROR_WANT_CONNECT NID_mdc2WithRSA OP_TLS_D5_BUG + ERROR_WANT_READ NID_ms_code_com OP_TLS_ROLLBACK_BUG + ERROR_WANT_WRITE NID_ms_code_ind READING + ERROR_WANT_X509_LOOKUP NID_ms_ctl_sign RECEIVED_SHUTDOWN + ERROR_ZERO_RETURN NID_ms_efs RSA_3 + EVP_PKS_DSA NID_ms_ext_req RSA_F4 + EVP_PKS_EC NID_ms_sgc R_BAD_AUTHENTICATION_TYPE + EVP_PKS_RSA NID_name R_BAD_CHECKSUM + EVP_PKT_ENC NID_netscape R_BAD_MAC_DECODE + EVP_PKT_EXCH NID_netscape_base_url R_BAD_RESPONSE_ARGUMENT + EVP_PKT_EXP NID_netscape_ca_policy_url R_BAD_SSL_FILETYPE + EVP_PKT_SIGN NID_netscape_ca_revocation_url R_BAD_SSL_SESSION_ID_LENGTH + EVP_PK_DH NID_netscape_cert_extension R_BAD_STATE + EVP_PK_DSA NID_netscape_cert_sequence R_BAD_WRITE_RETRY + EVP_PK_EC NID_netscape_cert_type R_CHALLENGE_IS_DIFFERENT + EVP_PK_RSA NID_netscape_comment R_CIPHER_TABLE_SRC_ERROR + FILETYPE_ASN1 NID_netscape_data_type R_INVALID_CHALLENGE_LENGTH + FILETYPE_PEM NID_netscape_renewal_url R_NO_CERTIFICATE_SET + F_CLIENT_CERTIFICATE NID_netscape_revocation_url R_NO_CERTIFICATE_SPECIFIED + F_CLIENT_HELLO NID_netscape_ssl_server_name R_NO_CIPHER_LIST + F_CLIENT_MASTER_KEY NID_ns_sgc R_NO_CIPHER_MATCH + F_D2I_SSL_SESSION NID_organizationName R_NO_PRIVATEKEY + F_GET_CLIENT_FINISHED NID_organizationalUnitName R_NO_PUBLICKEY + F_GET_CLIENT_HELLO NID_pbeWithMD2AndDES_CBC R_NULL_SSL_CTX + F_GET_CLIENT_MASTER_KEY NID_pbeWithMD2AndRC2_CBC R_PEER_DID_NOT_RETURN_A_CERTIFICATE + F_GET_SERVER_FINISHED NID_pbeWithMD5AndCast5_CBC R_PEER_ERROR + F_GET_SERVER_HELLO NID_pbeWithMD5AndDES_CBC R_PEER_ERROR_CERTIFICATE + F_GET_SERVER_VERIFY NID_pbeWithMD5AndRC2_CBC R_PEER_ERROR_NO_CIPHER + F_I2D_SSL_SESSION NID_pbeWithSHA1AndDES_CBC R_PEER_ERROR_UNSUPPORTED_CERTIFICATE_TYPE + F_READ_N NID_pbeWithSHA1AndRC2_CBC R_PUBLIC_KEY_ENCRYPT_ERROR + F_REQUEST_CERTIFICATE NID_pbe_WithSHA1And128BitRC2_CBC R_PUBLIC_KEY_IS_NOT_RSA + F_SERVER_HELLO NID_pbe_WithSHA1And128BitRC4 R_READ_WRONG_PACKET_TYPE + F_SSL_CERT_NEW NID_pbe_WithSHA1And2_Key_TripleDES_CBC R_SHORT_READ + F_SSL_GET_NEW_SESSION NID_pbe_WithSHA1And3_Key_TripleDES_CBC R_SSL_SESSION_ID_IS_DIFFERENT + F_SSL_NEW NID_pbe_WithSHA1And40BitRC2_CBC R_UNABLE_TO_EXTRACT_PUBLIC_KEY + F_SSL_READ NID_pbe_WithSHA1And40BitRC4 R_UNKNOWN_REMOTE_ERROR_TYPE + F_SSL_RSA_PRIVATE_DECRYPT NID_pbes2 R_UNKNOWN_STATE + F_SSL_RSA_PUBLIC_ENCRYPT NID_pbmac1 R_X509_LIB + F_SSL_SESSION_NEW NID_pkcs SENT_SHUTDOWN + F_SSL_SESSION_PRINT_FP NID_pkcs3 SESSION_ASN1_VERSION + F_SSL_SET_FD NID_pkcs7 SESS_CACHE_BOTH + F_SSL_SET_RFD NID_pkcs7_data SESS_CACHE_CLIENT + F_SSL_SET_WFD NID_pkcs7_digest SESS_CACHE_NO_AUTO_CLEAR + F_SSL_USE_CERTIFICATE NID_pkcs7_encrypted SESS_CACHE_NO_INTERNAL + F_SSL_USE_CERTIFICATE_ASN1 NID_pkcs7_enveloped SESS_CACHE_NO_INTERNAL_LOOKUP + F_SSL_USE_CERTIFICATE_FILE NID_pkcs7_signed SESS_CACHE_NO_INTERNAL_STORE + F_SSL_USE_PRIVATEKEY NID_pkcs7_signedAndEnveloped SESS_CACHE_OFF + F_SSL_USE_PRIVATEKEY_ASN1 NID_pkcs8ShroudedKeyBag SESS_CACHE_SERVER + F_SSL_USE_PRIVATEKEY_FILE NID_pkcs9 SSL3_VERSION + F_SSL_USE_RSAPRIVATEKEY NID_pkcs9_challengePassword SSLEAY_BUILT_ON + F_SSL_USE_RSAPRIVATEKEY_ASN1 NID_pkcs9_contentType SSLEAY_CFLAGS + F_SSL_USE_RSAPRIVATEKEY_FILE NID_pkcs9_countersignature SSLEAY_DIR + F_WRITE_PENDING NID_pkcs9_emailAddress SSLEAY_PLATFORM + GEN_DIRNAME NID_pkcs9_extCertAttributes SSLEAY_VERSION + GEN_DNS NID_pkcs9_messageDigest ST_ACCEPT + GEN_EDIPARTY NID_pkcs9_signingTime ST_BEFORE + GEN_EMAIL NID_pkcs9_unstructuredAddress ST_CONNECT + GEN_IPADD NID_pkcs9_unstructuredName ST_INIT + GEN_OTHERNAME NID_private_key_usage_period ST_OK + GEN_RID NID_rc2_40_cbc ST_READ_BODY + GEN_URI NID_rc2_64_cbc ST_READ_HEADER + GEN_X400 NID_rc2_cbc TLS1_1_VERSION + LIBRESSL_VERSION_NUMBER NID_rc2_cfb64 TLS1_2_VERSION + MBSTRING_ASC NID_rc2_ecb TLS1_3_VERSION + MBSTRING_BMP NID_rc2_ofb64 TLS1_VERSION + MBSTRING_FLAG NID_rc4 TLSEXT_STATUSTYPE_ocsp + MBSTRING_UNIV NID_rc4_40 VERIFY_CLIENT_ONCE + MBSTRING_UTF8 NID_rc5_cbc VERIFY_FAIL_IF_NO_PEER_CERT + MIN_RSA_MODULUS_LENGTH_IN_BYTES NID_rc5_cfb64 VERIFY_NONE + MODE_ACCEPT_MOVING_WRITE_BUFFER NID_rc5_ecb VERIFY_PEER + MODE_AUTO_RETRY NID_rc5_ofb64 V_OCSP_CERTSTATUS_GOOD + MODE_ENABLE_PARTIAL_WRITE NID_ripemd160 V_OCSP_CERTSTATUS_REVOKED + MODE_RELEASE_BUFFERS NID_ripemd160WithRSA V_OCSP_CERTSTATUS_UNKNOWN + NID_OCSP_sign NID_rle_compression WRITING + NID_SMIMECapabilities NID_rsa X509_CHECK_FLAG_ALWAYS_CHECK_SUBJECT + NID_X500 NID_rsaEncryption X509_CHECK_FLAG_MULTI_LABEL_WILDCARDS + NID_X509 NID_rsadsi X509_CHECK_FLAG_NO_PARTIAL_WILDCARDS + NID_ad_OCSP NID_safeContentsBag X509_CHECK_FLAG_NO_WILDCARDS + NID_ad_ca_issuers NID_sdsiCertificate X509_CHECK_FLAG_SINGLE_LABEL_SUBDOMAINS + NID_algorithm NID_secretBag X509_LOOKUP + NID_authority_key_identifier NID_serialNumber X509_PURPOSE_ANY + NID_basic_constraints NID_server_auth X509_PURPOSE_CRL_SIGN + NID_bf_cbc NID_sha X509_PURPOSE_NS_SSL_SERVER + NID_bf_cfb64 NID_sha1 X509_PURPOSE_OCSP_HELPER + NID_bf_ecb NID_sha1WithRSA X509_PURPOSE_SMIME_ENCRYPT + NID_bf_ofb64 NID_sha1WithRSAEncryption X509_PURPOSE_SMIME_SIGN + NID_cast5_cbc NID_shaWithRSAEncryption X509_PURPOSE_SSL_CLIENT + NID_cast5_cfb64 NID_stateOrProvinceName X509_PURPOSE_SSL_SERVER + NID_cast5_ecb NID_subject_alt_name X509_PURPOSE_TIMESTAMP_SIGN + NID_cast5_ofb64 NID_subject_key_identifier X509_TRUST_COMPAT + NID_certBag NID_surname X509_TRUST_EMAIL + NID_certificate_policies NID_sxnet X509_TRUST_OBJECT_SIGN + NID_client_auth NID_time_stamp X509_TRUST_OCSP_REQUEST + NID_code_sign NID_title X509_TRUST_OCSP_SIGN + NID_commonName NID_undef X509_TRUST_SSL_CLIENT + NID_countryName NID_uniqueIdentifier X509_TRUST_SSL_SERVER + NID_crlBag NID_x509Certificate X509_TRUST_TSA + NID_crl_distribution_points NID_x509Crl X509_V_FLAG_ALLOW_PROXY_CERTS + NID_crl_number NID_zlib_compression X509_V_FLAG_CB_ISSUER_CHECK + NID_crl_reason NOTHING X509_V_FLAG_CHECK_SS_SIGNATURE + NID_delta_crl OCSP_RESPONSE_STATUS_INTERNALERROR X509_V_FLAG_CRL_CHECK + NID_des_cbc OCSP_RESPONSE_STATUS_MALFORMEDREQUEST X509_V_FLAG_CRL_CHECK_ALL + NID_des_cfb64 OCSP_RESPONSE_STATUS_SIGREQUIRED X509_V_FLAG_EXPLICIT_POLICY + NID_des_ecb OCSP_RESPONSE_STATUS_SUCCESSFUL X509_V_FLAG_EXTENDED_CRL_SUPPORT + NID_des_ede OCSP_RESPONSE_STATUS_TRYLATER X509_V_FLAG_IGNORE_CRITICAL + NID_des_ede3 OCSP_RESPONSE_STATUS_UNAUTHORIZED X509_V_FLAG_INHIBIT_ANY + NID_des_ede3_cbc OPENSSL_BUILT_ON X509_V_FLAG_INHIBIT_MAP + NID_des_ede3_cfb64 OPENSSL_CFLAGS X509_V_FLAG_NOTIFY_POLICY + NID_des_ede3_ofb64 OPENSSL_DIR X509_V_FLAG_POLICY_CHECK + NID_des_ede_cbc OPENSSL_ENGINES_DIR X509_V_FLAG_POLICY_MASK + NID_des_ede_cfb64 OPENSSL_PLATFORM X509_V_FLAG_TRUSTED_FIRST + NID_des_ede_ofb64 OPENSSL_VERSION X509_V_FLAG_USE_CHECK_TIME + NID_des_ofb64 OPENSSL_VERSION_NUMBER X509_V_FLAG_USE_DELTAS + NID_description OP_ALL X509_V_FLAG_X509_STRICT + NID_desx_cbc OP_ALLOW_NO_DHE_KEX X509_V_OK + NID_dhKeyAgreement OP_ALLOW_UNSAFE_LEGACY_RENEGOTIATION XN_FLAG_COMPAT + NID_dnQualifier OP_CIPHER_SERVER_PREFERENCE XN_FLAG_DN_REV + NID_dsa OP_CISCO_ANYCONNECT XN_FLAG_DUMP_UNKNOWN_FIELDS + NID_dsaWithSHA OP_COOKIE_EXCHANGE XN_FLAG_FN_ALIGN + NID_dsaWithSHA1 OP_CRYPTOPRO_TLSEXT_BUG XN_FLAG_FN_LN + NID_dsaWithSHA1_2 OP_DONT_INSERT_EMPTY_FRAGMENTS XN_FLAG_FN_MASK + NID_dsa_2 OP_EPHEMERAL_RSA XN_FLAG_FN_NONE + NID_email_protect OP_LEGACY_SERVER_CONNECT XN_FLAG_FN_OID + NID_ext_key_usage OP_MICROSOFT_BIG_SSLV3_BUFFER XN_FLAG_FN_SN + NID_ext_req OP_MICROSOFT_SESS_ID_BUG XN_FLAG_MULTILINE + NID_friendlyName OP_MSIE_SSLV2_RSA_PADDING XN_FLAG_ONELINE + NID_givenName OP_NETSCAPE_CA_DN_BUG XN_FLAG_RFC2253 + NID_hmacWithSHA1 OP_NETSCAPE_CHALLENGE_BUG XN_FLAG_SEP_COMMA_PLUS + NID_id_ad OP_NETSCAPE_DEMO_CIPHER_CHANGE_BUG XN_FLAG_SEP_CPLUS_SPC + NID_id_ce OP_NETSCAPE_REUSE_CIPHER_CHANGE_BUG XN_FLAG_SEP_MASK + NID_id_kp OP_NON_EXPORT_FIRST XN_FLAG_SEP_MULTILINE + NID_id_pbkdf2 OP_NO_CLIENT_RENEGOTIATION XN_FLAG_SEP_SPLUS_SPC + NID_id_pe OP_NO_COMPRESSION XN_FLAG_SPC_EQ + NID_id_pkix OP_NO_ENCRYPT_THEN_MAC + +=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 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 + +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 (as of version +5.6.1). 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 AND SUPPORT + +Please report any bugs or feature requests to +C, or through the web interface at +L. +I will be notified, and then you'll automatically be notified of progress on +your bug as I make changes. + +Subversion access to the latest source code etc can be obtained at +L + +The developer mailing list (for people interested in contributing +to the source code) can be found at +L + +You can find documentation for this module with the C command. + + perldoc Net::SSLeay + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * Search CPAN + +L + +=back + +Commercial support for Net::SSLeay may be obtained from + + Symlabs (netssleay@symlabs.com) + Tel: +351-214.222.630 + Fax: +351-214.222.637 + +=head1 AUTHOR + +Maintained by Mike McCauley and Florian Ragwitz since November 2005 + +Originally written by Sampo Kellomäki + +=head1 COPYRIGHT + +Copyright (c) 1996-2003 Sampo Kellomäki + +Copyright (C) 2005-2006 Florian Ragwitz + +Copyright (C) 2005 Mike McCauley + +All Rights Reserved. + +Distribution and use of this module is under the same terms as the +OpenSSL package itself (i.e. free, but mandatory attribution; NO +WARRANTY). Please consult LICENSE file in the root of the Net-SSLeay +distribution, and also included in this distribution. + +The Authors credit Eric Young and the OpenSSL team with the development of the +excellent OpenSSL library, which this Perl package uses. + +And remember, you, and nobody else but you, are responsible for +auditing this module and OpenSSL library for security problems, +backdoors, and general suitability for your application. + +=head1 LICENSE + +From version +1.66 onwards, this Net-SSLeay library is issued under the "Perl Artistic +License 2.0", the same license as Perl itself. + +(ignore this line: this is to keep kwalitee happy by saying: Not GPL) + +=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 diff --git a/lib/lib/Net/SSLeay/Handle.pm b/lib/lib/Net/SSLeay/Handle.pm new file mode 100644 index 0000000..0172537 --- /dev/null +++ b/lib/lib/Net/SSLeay/Handle.pm @@ -0,0 +1,394 @@ +package Net::SSLeay::Handle; + +require 5.005_03; +use strict; + +use Socket; +use Net::SSLeay; + +require Exporter; + +=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 = '0.61'; + +my $Initialized; #-- only _initialize() once +my $Debug = 0; #-- pretty hokey +my %Glob_Ref; #-- used to make unique \*S names for versions < 5.6 + +#== 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); + my $socket = $^V ? undef : $class->_glob_ref("$host:$port"); + + socket($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 + +#--- _glob_ref($strings) ------------------------------------------------------ +# +# Create a unique namespace name and return a glob ref to it. Would be great +# to use the fileno but need this before we get back the fileno. +# NEED TO LOCK THIS ROUTINE IF USING THREADS. (but it is only used for +# versions < 5.6 :) +#------------------------------------------------------------------------------ + +sub _glob_ref { + my $class = shift; + my $preamb = join("", @_) || "_glob_ref"; + my $num = ++$Glob_Ref{$preamb}; + my $name = "$preamb:$num"; + no strict 'refs'; + my $glob_ref = \*$name; + use strict 'refs'; + + $Debug and do { + print "GLOB_REF $preamb\n"; + while (my ($k, $v) = each %Glob_Ref) {print "$k = $v\n"} + print "\n"; + }; + + return $glob_ref; +} + +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. + +Support for old perls may not be 100%. If in trouble try 5.6.0 or +newer. + +=head1 CHANGES + +Please see Net-SSLeay-Handle-0.50/Changes file. + +=head1 KNOWN BUGS + +If you let this module construct sockets for you with Perl versions +below v.5.6 then there is a slight memory leak. Other upgrade your +Perl, or create the sockets yourself. The leak was created to let +these older versions of Perl access more than one Handle at a time. + +=head1 AUTHOR + +Jim Bowlin jbowlin@linklint.org + +=head1 SEE ALSO + +Net::SSLeay, perl(1), http://openssl.org/ + +=cut diff --git a/lib/lib/Net/Telnet.pm b/lib/lib/Net/Telnet.pm new file mode 100644 index 0000000..f0f20fb --- /dev/null +++ b/lib/lib/Net/Telnet.pm @@ -0,0 +1,6168 @@ +package Net::Telnet; + +## Copyright 1997, 2000, 2002, 2013 Jay Rogers. All rights reserved. +## This program is free software; you can redistribute it and/or +## modify it under the same terms as Perl itself. + +## See user documentation at the end of this file. Search for =head + +use strict; +require 5.002; + +## Module export. +use vars qw(@EXPORT_OK); +@EXPORT_OK = qw(TELNET_IAC TELNET_DONT TELNET_DO TELNET_WONT TELNET_WILL + TELNET_SB TELNET_GA TELNET_EL TELNET_EC TELNET_AYT TELNET_AO + TELNET_IP TELNET_BREAK TELNET_DM TELNET_NOP TELNET_SE + TELNET_EOR TELNET_ABORT TELNET_SUSP TELNET_EOF TELNET_SYNCH + TELOPT_BINARY TELOPT_ECHO TELOPT_RCP TELOPT_SGA TELOPT_NAMS + TELOPT_STATUS TELOPT_TM TELOPT_RCTE TELOPT_NAOL TELOPT_NAOP + TELOPT_NAOCRD TELOPT_NAOHTS TELOPT_NAOHTD TELOPT_NAOFFD + TELOPT_NAOVTS TELOPT_NAOVTD TELOPT_NAOLFD TELOPT_XASCII + TELOPT_LOGOUT TELOPT_BM TELOPT_DET TELOPT_SUPDUP + TELOPT_SUPDUPOUTPUT TELOPT_SNDLOC TELOPT_TTYPE TELOPT_EOR + TELOPT_TUID TELOPT_OUTMRK TELOPT_TTYLOC TELOPT_3270REGIME + TELOPT_X3PAD TELOPT_NAWS TELOPT_TSPEED TELOPT_LFLOW + TELOPT_LINEMODE TELOPT_XDISPLOC TELOPT_OLD_ENVIRON + TELOPT_AUTHENTICATION TELOPT_ENCRYPT TELOPT_NEW_ENVIRON + TELOPT_TN3270E TELOPT_CHARSET TELOPT_COMPORT TELOPT_KERMIT + TELOPT_EXOPL); + +## Module import. +use Exporter (); +use Socket qw(AF_INET SOCK_STREAM inet_aton sockaddr_in); +use Symbol qw(qualify); + +## Base classes. +use vars qw(@ISA); +@ISA = qw(Exporter); +if (&_io_socket_include) { # successfully required module IO::Socket + push @ISA, "IO::Socket::INET"; +} +else { # perl version < 5.004 + require FileHandle; + push @ISA, "FileHandle"; +} +my $AF_INET6 = &_import_af_inet6(); +my $AF_UNSPEC = &_import_af_unspec() || 0; +my $AI_ADDRCONFIG = &_import_ai_addrconfig() || 0; +my $EAI_BADFLAGS = &_import_eai_badflags() || -1; +my $EINTR = &_import_eintr(); + +## Global variables. +use vars qw($VERSION @Telopts); +$VERSION = "3.04"; +@Telopts = ("BINARY", "ECHO", "RCP", "SUPPRESS GO AHEAD", "NAMS", "STATUS", + "TIMING MARK", "RCTE", "NAOL", "NAOP", "NAOCRD", "NAOHTS", + "NAOHTD", "NAOFFD", "NAOVTS", "NAOVTD", "NAOLFD", "EXTEND ASCII", + "LOGOUT", "BYTE MACRO", "DATA ENTRY TERMINAL", "SUPDUP", + "SUPDUP OUTPUT", "SEND LOCATION", "TERMINAL TYPE", "END OF RECORD", + "TACACS UID", "OUTPUT MARKING", "TTYLOC", "3270 REGIME", "X.3 PAD", + "NAWS", "TSPEED", "LFLOW", "LINEMODE", "XDISPLOC", "OLD-ENVIRON", + "AUTHENTICATION", "ENCRYPT", "NEW-ENVIRON", "TN3270E", "XAUTH", + "CHARSET", "RSP", "COMPORT", "SUPPRESS LOCAL ECHO", "START TLS", + "KERMIT"); + + +########################### Public Methods ########################### + + +sub new { + my ($class) = @_; + my ( + $dump_log, + $errmode, + $family, + $fh_open, + $host, + $input_log, + $localfamily, + $option_log, + $output_log, + $port, + $prompt, + $self, + %args, + ); + local $_; + + ## Create a new object with defaults. + $self = $class->SUPER::new; + *$self->{net_telnet} = { + bin_mode => 0, + blksize => &_optimal_blksize(), + buf => "", + cmd_prompt => '/[\$%#>] $/', + cmd_rm_mode => "auto", + dumplog => '', + eofile => 1, + errormode => "die", + errormsg => "", + fdmask => '', + host => "localhost", + inputlog => '', + last_line => "", + last_prompt => "", + local_family => "ipv4", + local_host => "", + maxbufsize => 1_048_576, + num_wrote => 0, + ofs => "", + opened => '', + opt_cback => '', + opt_log => '', + opts => {}, + ors => "\n", + outputlog => '', + peer_family => "ipv4", + pending_errormsg => "", + port => 23, + pushback_buf => "", + rs => "\n", + select_supported => 1, + sock_family => 0, + subopt_cback => '', + telnet_mode => 1, + time_out => 10, + timedout => '', + unsent_opts => "", + }; + + ## Indicate that we'll accept an offer from remote side for it to echo + ## and suppress go aheads. + &_opt_accept($self, + { option => &TELOPT_ECHO, + is_remote => 1, + is_enable => 1 }, + { option => &TELOPT_SGA, + is_remote => 1, + is_enable => 1 }, + ); + + ## Parse the args. + if (@_ == 2) { # one positional arg given + $host = $_[1]; + } + elsif (@_ > 2) { # named args given + ## Get the named args. + (undef, %args) = @_; + + ## Parse all other named args. + foreach (keys %args) { + if (/^-?binmode$/i) { + $self->binmode($args{$_}); + } + elsif (/^-?cmd_remove_mode$/i) { + $self->cmd_remove_mode($args{$_}); + } + elsif (/^-?dump_log$/i) { + $dump_log = $args{$_}; + } + elsif (/^-?errmode$/i) { + $errmode = $args{$_}; + } + elsif (/^-?family$/i) { + $family = $args{$_}; + } + elsif (/^-?fhopen$/i) { + $fh_open = $args{$_}; + } + elsif (/^-?host$/i) { + $host = $args{$_}; + } + elsif (/^-?input_log$/i) { + $input_log = $args{$_}; + } + elsif (/^-?input_record_separator$/i or /^-?rs$/i) { + $self->input_record_separator($args{$_}); + } + elsif (/^-?localfamily$/i) { + $localfamily = $args{$_}; + } + elsif (/^-?localhost$/i) { + $self->localhost($args{$_}); + } + elsif (/^-?max_buffer_length$/i) { + $self->max_buffer_length($args{$_}); + } + elsif (/^-?option_log$/i) { + $option_log = $args{$_}; + } + elsif (/^-?output_field_separator$/i or /^-?ofs$/i) { + $self->output_field_separator($args{$_}); + } + elsif (/^-?output_log$/i) { + $output_log = $args{$_}; + } + elsif (/^-?output_record_separator$/i or /^-?ors$/i) { + $self->output_record_separator($args{$_}); + } + elsif (/^-?port$/i) { + $port = $args{$_}; + } + elsif (/^-?prompt$/i) { + $prompt = $args{$_}; + } + elsif (/^-?telnetmode$/i) { + $self->telnetmode($args{$_}); + } + elsif (/^-?timeout$/i) { + $self->timeout($args{$_}); + } + else { + &_croak($self, "bad named parameter \"$_\" given " . + "to " . ref($self) . "::new()"); + } + } + } + + if (defined $errmode) { # user wants to set errmode + $self->errmode($errmode); + } + + if (defined $host) { # user wants to set host + $self->host($host); + } + + if (defined $port) { # user wants to set port + $self->port($port) + or return; + } + + if (defined $family) { # user wants to set family + $self->family($family) + or return; + } + + if (defined $localfamily) { # user wants to set localfamily + $self->localfamily($localfamily) + or return; + } + + if (defined $prompt) { # user wants to set prompt + $self->prompt($prompt) + or return; + } + + if (defined $dump_log) { # user wants to set dump_log + $self->dump_log($dump_log) + or return; + } + + if (defined $input_log) { # user wants to set input_log + $self->input_log($input_log) + or return; + } + + if (defined $option_log) { # user wants to set option_log + $self->option_log($option_log) + or return; + } + + if (defined $output_log) { # user wants to set output_log + $self->output_log($output_log) + or return; + } + + if (defined $fh_open) { # user wants us to attach to existing filehandle + $self->fhopen($fh_open) + or return; + } + elsif (defined $host) { # user wants us to open a connection to host + $self->open + or return; + } + + $self; +} # end sub new + + +sub DESTROY { +} # end sub DESTROY + + +sub binmode { + my ($self, $mode) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{bin_mode}; + + if (@_ >= 2) { + unless (defined $mode) { + $mode = 0; + } + + $s->{bin_mode} = $mode; + } + + $prev; +} # end sub binmode + + +sub break { + my ($self) = @_; + my $s = *$self->{net_telnet}; + my $break_cmd = "\xff\xf3"; + + $s->{timedout} = ''; + + &_put($self, \$break_cmd, "break"); +} # end sub break + + +sub buffer { + my ($self) = @_; + my $s = *$self->{net_telnet}; + + \$s->{buf}; +} # end sub buffer + + +sub buffer_empty { + my ($self) = @_; + my ( + $buffer, + ); + + $buffer = $self->buffer; + $$buffer = ""; +} # end sub buffer_empty + + +sub close { + my ($self) = @_; + my $s = *$self->{net_telnet}; + + $s->{eofile} = 1; + $s->{opened} = ''; + $s->{sock_family} = 0; + close $self + if defined fileno($self); + + 1; +} # end sub close + + +sub cmd { + my ($self, @args) = @_; + my ( + $arg_errmode, + $cmd_remove_mode, + $firstpos, + $last_prompt, + $lastpos, + $lines, + $ors, + $output, + $output_ref, + $prompt, + $remove_echo, + $rs, + $rs_len, + $s, + $telopt_echo, + $timeout, + %args, + ); + my $cmd = ""; + local $_; + + ## Init. + $self->timed_out(''); + $self->last_prompt(""); + $s = *$self->{net_telnet}; + $output = []; + $cmd_remove_mode = $self->cmd_remove_mode; + $ors = $self->output_record_separator; + $prompt = $self->prompt; + $rs = $self->input_record_separator; + $timeout = $self->timeout; + + ## Override errmode first, if specified. + $arg_errmode = &_extract_arg_errmode($self, \@args); + local $s->{errormode} = $arg_errmode + if $arg_errmode; + + ## Parse args. + if (@args == 1) { # one positional arg given + $cmd = $args[0]; + } + elsif (@args >= 2) { # named args given + ## Get the named args. + %args = @args; + + ## Parse the named args. + foreach (keys %args) { + if (/^-?cmd_remove/i) { + $cmd_remove_mode = &_parse_cmd_remove_mode($self, $args{$_}); + } + elsif (/^-?input_record_separator$/i or /^-?rs$/i) { + $rs = &_parse_input_record_separator($self, $args{$_}); + } + elsif (/^-?output$/i) { + $output_ref = $args{$_}; + if (defined($output_ref) and ref($output_ref) eq "ARRAY") { + $output = $output_ref; + } + } + elsif (/^-?output_record_separator$/i or /^-?ors$/i) { + $ors = $args{$_}; + } + elsif (/^-?prompt$/i) { + $prompt = &_parse_prompt($self, $args{$_}) + or return; + } + elsif (/^-?string$/i) { + $cmd = $args{$_}; + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $args{$_}); + } + else { + &_croak($self, "bad named parameter \"$_\" given " . + "to " . ref($self) . "::cmd()"); + } + } + } + + ## Override some user settings. + local $s->{time_out} = &_endtime($timeout); + $self->errmsg(""); + + ## Send command and wait for the prompt. + { + local $s->{errormode} = "return"; + + $self->put($cmd . $ors) + and ($lines, $last_prompt) = $self->waitfor($prompt); + } + + ## Check for failure. + return $self->error("command timed-out") if $self->timed_out; + return $self->error($self->errmsg) if $self->errmsg ne ""; + + ## Save the most recently matched prompt. + $self->last_prompt($last_prompt); + + ## Split lines into an array, keeping record separator at end of line. + $firstpos = 0; + $rs_len = length $rs; + while (($lastpos = index($lines, $rs, $firstpos)) > -1) { + push(@$output, + substr($lines, $firstpos, $lastpos - $firstpos + $rs_len)); + $firstpos = $lastpos + $rs_len; + } + + if ($firstpos < length $lines) { + push @$output, substr($lines, $firstpos); + } + + ## Determine if we should remove the first line of output based + ## on the assumption that it's an echoed back command. + if ($cmd_remove_mode eq "auto") { + ## See if remote side told us they'd echo. + $telopt_echo = $self->option_state(&TELOPT_ECHO); + $remove_echo = $telopt_echo->{remote_enabled}; + } + else { # user explicitly told us how many lines to remove. + $remove_echo = $cmd_remove_mode; + } + + ## Get rid of possible echo back command. + while ($remove_echo--) { + shift @$output; + } + + ## Ensure at least a null string when there's no command output - so + ## "true" is returned in a list context. + unless (@$output) { + @$output = (""); + } + + ## Return command output via named arg, if requested. + if (defined $output_ref) { + if (ref($output_ref) eq "SCALAR") { + $$output_ref = join "", @$output; + } + elsif (ref($output_ref) eq "HASH") { + %$output_ref = @$output; + } + } + + wantarray ? @$output : 1; +} # end sub cmd + + +sub cmd_remove_mode { + my ($self, $mode) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{cmd_rm_mode}; + + if (@_ >= 2) { + $s->{cmd_rm_mode} = &_parse_cmd_remove_mode($self, $mode); + } + + $prev; +} # end sub cmd_remove_mode + + +sub dump_log { + my ($self, $name) = @_; + my ( + $fh, + $s, + ); + + $s = *$self->{net_telnet}; + $fh = $s->{dumplog}; + + if (@_ >= 2) { + if (!defined($name) or $name eq "") { # input arg is "" + ## Turn off logging. + $fh = ""; + } + elsif (&_is_open_fh($name)) { # input arg is an open fh + ## Use the open fh for logging. + $fh = $name; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + elsif (!ref $name) { # input arg is filename + ## Open the file for logging. + $fh = &_fname_to_handle($self, $name) + or return; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + else { + return $self->error("bad Dump_log argument ", + "\"$name\": not filename or open fh"); + } + + $s->{dumplog} = $fh; + } + + $fh; +} # end sub dump_log + + +sub eof { + my ($self) = @_; + + *$self->{net_telnet}{eofile}; +} # end sub eof + + +sub errmode { + my ($self, $mode) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{errormode}; + + if (@_ >= 2) { + $s->{errormode} = &_parse_errmode($self, $mode); + } + + $prev; +} # end sub errmode + + +sub errmsg { + my ($self, @errmsgs) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{errormsg}; + + if (@_ >= 2) { + $s->{errormsg} = join "", @errmsgs; + } + + $prev; +} # end sub errmsg + + +sub error { + my ($self, @errmsg) = @_; + my ( + $errmsg, + $func, + $mode, + $s, + @args, + ); + local $_; + + $s = *$self->{net_telnet}; + + if (@_ >= 2) { + ## Put error message in the object. + $errmsg = join "", @errmsg; + $s->{errormsg} = $errmsg; + + ## Do the error action as described by error mode. + $mode = $s->{errormode}; + if (ref($mode) eq "CODE") { + &$mode($errmsg); + return; + } + elsif (ref($mode) eq "ARRAY") { + ($func, @args) = @$mode; + &$func(@args); + return; + } + elsif ($mode =~ /^return$/i) { + return; + } + else { # die + if ($errmsg =~ /\n$/) { + die $errmsg; + } + else { + ## Die and append caller's line number to message. + &_croak($self, $errmsg); + } + } + } + else { + return $s->{errormsg} ne ""; + } +} # end sub error + + +sub family { + my ($self, $family) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{peer_family}; + + if (@_ >= 2) { + $family = &_parse_family($self, $family) + or return; + + $s->{peer_family} = $family; + } + + $prev; +} # end sub family + + +sub fhopen { + my ($self, $fh) = @_; + my ( + $globref, + $s, + ); + + ## Convert given filehandle to a typeglob reference, if necessary. + $globref = &_qualify_fh($self, $fh); + + ## Ensure filehandle is already open. + return $self->error("fhopen filehandle isn't already open") + unless defined($globref) and defined(fileno $globref); + + ## Ensure we're closed. + $self->close; + + ## Save our private data. + $s = *$self->{net_telnet}; + + ## Switch ourself with the given filehandle. + *$self = *$globref; + + ## Restore our private data. + *$self->{net_telnet} = $s; + + ## Re-initialize ourself. + select((select($self), $|=1)[$[]); # don't buffer writes + $s = *$self->{net_telnet}; + $s->{blksize} = &_optimal_blksize((stat $self)[11]); + $s->{buf} = ""; + $s->{eofile} = ''; + $s->{errormsg} = ""; + vec($s->{fdmask}='', fileno($self), 1) = 1; + $s->{host} = ""; + $s->{last_line} = ""; + $s->{last_prompt} = ""; + $s->{num_wrote} = 0; + $s->{opened} = 1; + $s->{pending_errormsg} = ""; + $s->{port} = ''; + $s->{pushback_buf} = ""; + $s->{select_supported} = $^O ne "MSWin32" || -S $self; + $s->{timedout} = ''; + $s->{unsent_opts} = ""; + &_reset_options($s->{opts}); + + 1; +} # end sub fhopen + + +sub get { + my ($self, %args) = @_; + my ( + $binmode, + $endtime, + $errmode, + $line, + $s, + $telnetmode, + $timeout, + ); + local $_; + + ## Init. + $s = *$self->{net_telnet}; + $timeout = $s->{time_out}; + $s->{timedout} = ''; + return if $s->{eofile}; + + ## Parse the named args. + foreach (keys %args) { + if (/^-?binmode$/i) { + $binmode = $args{$_}; + unless (defined $binmode) { + $binmode = 0; + } + } + elsif (/^-?errmode$/i) { + $errmode = &_parse_errmode($self, $args{$_}); + } + elsif (/^-?telnetmode$/i) { + $telnetmode = $args{$_}; + unless (defined $telnetmode) { + $telnetmode = 0; + } + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $args{$_}); + } + else { + &_croak($self, "bad named parameter \"$_\" given " . + "to " . ref($self) . "::get()"); + } + } + + ## If any args given, override corresponding instance data. + local $s->{errormode} = $errmode + if defined $errmode; + local $s->{bin_mode} = $binmode + if defined $binmode; + local $s->{telnet_mode} = $telnetmode + if defined $telnetmode; + + ## Set wall time when we time out. + $endtime = &_endtime($timeout); + + ## Try to send any waiting option negotiation. + if (length $s->{unsent_opts}) { + &_flush_opts($self); + } + + ## Try to read just the waiting data using return error mode. + { + local $s->{errormode} = "return"; + $s->{errormsg} = ""; + &_fillbuf($self, $s, 0); + } + + ## We're done if we timed-out and timeout value is set to "poll". + return $self->error($s->{errormsg}) + if ($s->{timedout} and defined($timeout) and $timeout == 0 + and !length $s->{buf}); + + ## We're done if we hit an error other than timing out. + if ($s->{errormsg} and !$s->{timedout}) { + if (!length $s->{buf}) { + return $self->error($s->{errormsg}); + } + else { # error encountered but there's some data in buffer + $s->{pending_errormsg} = $s->{errormsg}; + } + } + + ## Clear time-out error from first read. + $s->{timedout} = ''; + $s->{errormsg} = ""; + + ## If buffer is still empty, try to read according to user's timeout. + if (!length $s->{buf}) { + &_fillbuf($self, $s, $endtime) + or do { + return if $s->{timedout}; + + ## We've reached end-of-file. + $self->close; + return; + }; + } + + ## Extract chars from buffer. + $line = $s->{buf}; + $s->{buf} = ""; + + $line; +} # end sub get + + +sub getline { + my ($self, %args) = @_; + my ( + $binmode, + $endtime, + $errmode, + $len, + $line, + $offset, + $pos, + $rs, + $s, + $telnetmode, + $timeout, + ); + local $_; + + ## Init. + $s = *$self->{net_telnet}; + $s->{timedout} = ''; + return if $s->{eofile}; + $rs = $s->{"rs"}; + $timeout = $s->{time_out}; + + ## Parse the named args. + foreach (keys %args) { + if (/^-?binmode$/i) { + $binmode = $args{$_}; + unless (defined $binmode) { + $binmode = 0; + } + } + elsif (/^-?errmode$/i) { + $errmode = &_parse_errmode($self, $args{$_}); + } + elsif (/^-?input_record_separator$/i or /^-?rs$/i) { + $rs = &_parse_input_record_separator($self, $args{$_}); + } + elsif (/^-?telnetmode$/i) { + $telnetmode = $args{$_}; + unless (defined $telnetmode) { + $telnetmode = 0; + } + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $args{$_}); + } + else { + &_croak($self, "bad named parameter \"$_\" given " . + "to " . ref($self) . "::getline()"); + } + } + + ## If any args given, override corresponding instance data. + local $s->{bin_mode} = $binmode + if defined $binmode; + local $s->{errormode} = $errmode + if defined $errmode; + local $s->{telnet_mode} = $telnetmode + if defined $telnetmode; + + ## Set wall time when we time out. + $endtime = &_endtime($timeout); + + ## Try to send any waiting option negotiation. + if (length $s->{unsent_opts}) { + &_flush_opts($self); + } + + ## Keep reading into buffer until end-of-line is read. + $offset = 0; + while (($pos = index($s->{buf}, $rs, $offset)) == -1) { + $offset = length $s->{buf}; + &_fillbuf($self, $s, $endtime) + or do { + return if $s->{timedout}; + + ## We've reached end-of-file. + $self->close; + if (length $s->{buf}) { + return $s->{buf}; + } + else { + return; + } + }; + } + + ## Extract line from buffer. + $len = $pos + length $rs; + $line = substr($s->{buf}, 0, $len); + substr($s->{buf}, 0, $len) = ""; + + $line; +} # end sub getline + + +sub getlines { + my ($self, %args) = @_; + my ( + $binmode, + $errmode, + $line, + $rs, + $s, + $telnetmode, + $timeout, + ); + my $all = 1; + my @lines = (); + local $_; + + ## Init. + $s = *$self->{net_telnet}; + $s->{timedout} = ''; + return if $s->{eofile}; + $timeout = $s->{time_out}; + + ## Parse the named args. + foreach (keys %args) { + if (/^-?all$/i) { + $all = $args{$_}; + unless (defined $all) { + $all = ''; + } + } + elsif (/^-?binmode$/i) { + $binmode = $args{$_}; + unless (defined $binmode) { + $binmode = 0; + } + } + elsif (/^-?errmode$/i) { + $errmode = &_parse_errmode($self, $args{$_}); + } + elsif (/^-?input_record_separator$/i or /^-?rs$/i) { + $rs = &_parse_input_record_separator($self, $args{$_}); + } + elsif (/^-?telnetmode$/i) { + $telnetmode = $args{$_}; + unless (defined $telnetmode) { + $telnetmode = 0; + } + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $args{$_}); + } + else { + &_croak($self, "bad named parameter \"$_\" given " . + "to " . ref($self) . "::getlines()"); + } + } + + ## If any args given, override corresponding instance data. + local $s->{bin_mode} = $binmode + if defined $binmode; + local $s->{errormode} = $errmode + if defined $errmode; + local $s->{"rs"} = $rs + if defined $rs; + local $s->{telnet_mode} = $telnetmode + if defined $telnetmode; + local $s->{time_out} = &_endtime($timeout); + + ## User requested only the currently available lines. + if (! $all) { + return &_next_getlines($self, $s); + } + + ## Read lines until eof or error. + while (1) { + $line = $self->getline + or last; + push @lines, $line; + } + + ## Check for error. + return if ! $self->eof; + + @lines; +} # end sub getlines + + +sub host { + my ($self, $host) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{host}; + + if (@_ >= 2) { + unless (defined $host) { + $host = ""; + } + + $s->{host} = $host; + } + + $prev; +} # end sub host + + +sub input_log { + my ($self, $name) = @_; + my ( + $fh, + $s, + ); + + $s = *$self->{net_telnet}; + $fh = $s->{inputlog}; + + if (@_ >= 2) { + if (!defined($name) or $name eq "") { # input arg is "" + ## Turn off logging. + $fh = ""; + } + elsif (&_is_open_fh($name)) { # input arg is an open fh + ## Use the open fh for logging. + $fh = $name; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + elsif (!ref $name) { # input arg is filename + ## Open the file for logging. + $fh = &_fname_to_handle($self, $name) + or return; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + else { + return $self->error("bad Input_log argument ", + "\"$name\": not filename or open fh"); + } + + $s->{inputlog} = $fh; + } + + $fh; +} # end sub input_log + + +sub input_record_separator { + my ($self, $rs) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{"rs"}; + + if (@_ >= 2) { + $s->{"rs"} = &_parse_input_record_separator($self, $rs); + } + + $prev; +} # end sub input_record_separator + + +sub last_prompt { + my ($self, $string) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{last_prompt}; + + if (@_ >= 2) { + unless (defined $string) { + $string = ""; + } + + $s->{last_prompt} = $string; + } + + $prev; +} # end sub last_prompt + + +sub lastline { + my ($self, $line) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{last_line}; + + if (@_ >= 2) { + unless (defined $line) { + $line = ""; + } + + $s->{last_line} = $line; + } + + $prev; +} # end sub lastline + + +sub localfamily { + my ($self, $family) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{local_family}; + + if (@_ >= 2) { + unless (defined $family) { + $family = ""; + } + + if ($family =~ /^\s*ipv4\s*$/i) { # family arg is "ipv4" + $s->{local_family} = "ipv4"; + } + elsif ($family =~ /^\s*any\s*$/i) { # family arg is "any" + if ($Socket::VERSION >= 1.94 and defined $AF_INET6) { # has IPv6 + $s->{local_family} = "any"; + } + else { # IPv6 not supported on this machine + $s->{local_family} = "ipv4"; + } + } + elsif ($family =~ /^\s*ipv6\s*$/i) { # family arg is "ipv6" + return $self->error("Localfamily arg ipv6 not supported when " . + "Socket.pm version < 1.94") + unless $Socket::VERSION >= 1.94; + return $self->error("Localfamily arg ipv6 not supported by " . + "this OS: AF_INET6 not in Socket.pm") + unless defined $AF_INET6; + + $s->{local_family} = "ipv6"; + } + else { + return $self->error("bad Localfamily argument \"$family\": " . + "must be \"ipv4\", \"ipv6\", or \"any\""); + } + } + + $prev; +} # end sub localfamily + + +sub localhost { + my ($self, $localhost) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{local_host}; + + if (@_ >= 2) { + unless (defined $localhost) { + $localhost = ""; + } + + $s->{local_host} = $localhost; + } + + $prev; +} # end sub localhost + + +sub login { + my ($self, @args) = @_; + my ( + $arg_errmode, + $error, + $is_passwd_arg, + $is_username_arg, + $lastline, + $match, + $ors, + $passwd, + $prematch, + $prompt, + $s, + $timeout, + $username, + %args, + ); + local $_; + + ## Init. + $self->timed_out(''); + $self->last_prompt(""); + $s = *$self->{net_telnet}; + $timeout = $self->timeout; + $ors = $self->output_record_separator; + $prompt = $self->prompt; + + ## Parse positional args. + if (@args == 2) { # just username and passwd given + $username = $args[0]; + $passwd = $args[1]; + + $is_username_arg = 1; + $is_passwd_arg = 1; + } + + ## Override errmode first, if specified. + $arg_errmode = &_extract_arg_errmode($self, \@args); + local $s->{errormode} = $arg_errmode + if $arg_errmode; + + ## Parse named args. + if (@args > 2) { + ## Get the named args. + %args = @args; + + ## Parse the named args. + foreach (keys %args) { + if (/^-?name$/i) { + $username = $args{$_}; + unless (defined $username) { + $username = ""; + } + + $is_username_arg = 1; + } + elsif (/^-?pass/i) { + $passwd = $args{$_}; + unless (defined $passwd) { + $passwd = ""; + } + + $is_passwd_arg = 1; + } + elsif (/^-?prompt$/i) { + $prompt = &_parse_prompt($self, $args{$_}) + or return; + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $args{$_}); + } + else { + &_croak($self, "bad named parameter \"$_\" given ", + "to " . ref($self) . "::login()"); + } + } + } + + ## Ensure both username and password argument given. + &_croak($self,"Name argument not given to " . ref($self) . "::login()") + unless $is_username_arg; + &_croak($self,"Password argument not given to " . ref($self) . "::login()") + unless $is_passwd_arg; + + ## Set timeout for this invocation. + local $s->{time_out} = &_endtime($timeout); + + ## Create a subroutine to generate an error. + $error + = sub { + my ($errmsg) = @_; + + if ($self->timed_out) { + return $self->error($errmsg); + } + elsif ($self->eof) { + ($lastline = $self->lastline) =~ s/\n+//; + return $self->error($errmsg, ": ", $lastline); + } + else { + return $self->error($self->errmsg); + } + }; + + + return $self->error("login failed: filehandle isn't open") + if $self->eof; + + ## Wait for login prompt. + $self->waitfor(Match => '/login[: ]*$/i', + Match => '/username[: ]*$/i', + Errmode => "return") + or do { + return &$error("eof read waiting for login prompt") + if $self->eof; + return &$error("timed-out waiting for login prompt"); + }; + + ## Delay sending response because of bug in Linux login program. + &_sleep(0.01); + + ## Send login name. + $self->put(String => $username . $ors, + Errmode => "return") + or return &$error("login disconnected"); + + ## Wait for password prompt. + $self->waitfor(Match => '/password[: ]*$/i', + Errmode => "return") + or do { + return &$error("eof read waiting for password prompt") + if $self->eof; + return &$error("timed-out waiting for password prompt"); + }; + + ## Delay sending response because of bug in Linux login program. + &_sleep(0.01); + + ## Send password. + $self->put(String => $passwd . $ors, + Errmode => "return") + or return &$error("login disconnected"); + + ## Wait for command prompt or another login prompt. + ($prematch, $match) = $self->waitfor(Match => '/login[: ]*$/i', + Match => '/username[: ]*$/i', + Match => $prompt, + Errmode => "return") + or do { + return &$error("eof read waiting for command prompt") + if $self->eof; + return &$error("timed-out waiting for command prompt"); + }; + + ## It's a bad login if we got another login prompt. + return $self->error("login failed: bad name or password") + if $match =~ /login[: ]*$/i or $match =~ /username[: ]*$/i; + + ## Save the most recently matched command prompt. + $self->last_prompt($match); + + 1; +} # end sub login + + +sub max_buffer_length { + my ($self, $maxbufsize) = @_; + my ( + $prev, + $s, + ); + my $minbufsize = 512; + + $s = *$self->{net_telnet}; + $prev = $s->{maxbufsize}; + + if (@_ >= 2) { + ## Ensure a positive integer value. + unless (defined $maxbufsize + and $maxbufsize =~ /^\d+$/ + and $maxbufsize) + { + &_carp($self, "ignoring bad Max_buffer_length " . + "argument \"$maxbufsize\": it's not a positive integer"); + $maxbufsize = $prev; + } + + ## Adjust up values that are too small. + if ($maxbufsize < $minbufsize) { + $maxbufsize = $minbufsize; + } + + $s->{maxbufsize} = $maxbufsize; + } + + $prev; +} # end sub max_buffer_length + + +## Make ofs() synonymous with output_field_separator(). +sub ofs { &output_field_separator; } + + +sub open { + my ($self, @args) = @_; + my ( + $af, + $arg_errmode, + $err, + $errno, + $family, + $flags_hint, + $host, + $ip_addr, + $lfamily, + $localhost, + $port, + $s, + $timeout, + %args, + @ai, + ); + local $@; + local $_; + my $local_addr = ''; + my $remote_addr = ''; + my %af = ( + ipv4 => AF_INET, + ipv6 => defined($AF_INET6) ? $AF_INET6 : undef, + any => $AF_UNSPEC, + ); + + ## Init. + $s = *$self->{net_telnet}; + $s->{timedout} = ''; + $s->{sock_family} = 0; + $port = $self->port; + $family = $self->family; + $localhost = $self->localhost; + $lfamily = $self->localfamily; + $timeout = $self->timeout; + + ## Override errmode first, if specified. + $arg_errmode = &_extract_arg_errmode($self, \@args); + local $s->{errormode} = $arg_errmode + if $arg_errmode; + + if (@args == 1) { # one positional arg given + $self->host($args[0]); + } + elsif (@args >= 2) { # named args given + ## Get the named args. + %args = @args; + + ## Parse the named args. + foreach (keys %args) { + if (/^-?family$/i) { + $family = &_parse_family($self, $args{$_}); + } + elsif (/^-?host$/i) { + $self->host($args{$_}); + } + elsif (/^-?localfamily$/i) { + $lfamily = &_parse_localfamily($self, $args{$_}); + } + elsif (/^-?localhost$/i) { + $args{$_} = "" unless defined $args{$_}; + $localhost = $args{$_}; + } + elsif (/^-?port$/i) { + $port = &_parse_port($self, $args{$_}); + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $args{$_}); + } + else { + &_croak($self, "bad named parameter \"$_\" given ", + "to " . ref($self) . "::open()"); + } + } + } + + ## Get hostname/ip address. + $host = $self->host; + + ## Ensure we're already closed. + $self->close; + + ## Connect with or without a timeout. + if (defined($timeout) and &_have_alarm) { # use a timeout + ## Convert possible absolute timeout to relative timeout. + if ($timeout >= $^T) { # it's an absolute time + $timeout = $timeout - time; + } + + ## Ensure a valid timeout value for alarm. + if ($timeout < 1) { + $timeout = 1; + } + $timeout = int($timeout + 0.5); + + ## Connect to server, timing out if it takes too long. + eval { + ## Turn on timer. + local $SIG{"__DIE__"} = "DEFAULT"; + local $SIG{ALRM} = sub { die "timed-out\n" }; + alarm $timeout; + + if ($family eq "ipv4") { + ## Lookup server's IP address. + $ip_addr = inet_aton $host + or die "unknown remote host: $host\n"; + $af = AF_INET; + $remote_addr = sockaddr_in($port, $ip_addr); + } + else { # family is "ipv6" or "any" + ## Lookup server's IP address. + $flags_hint = $family eq "any" ? $AI_ADDRCONFIG : 0; + ($err, @ai) = Socket::getaddrinfo($host, $port, + { socktype => SOCK_STREAM, + "family" => $af{$family}, + "flags" => $flags_hint }); + if ($err == $EAI_BADFLAGS) { + ## Try again with no flags. + ($err, @ai) = Socket::getaddrinfo($host, $port, + {socktype => SOCK_STREAM, + "family"=> $af{$family}, + "flags" => 0 }); + } + die "unknown remote host: $host: $err\n" + if $err or !@ai; + $af = $ai[0]{"family"}; + $remote_addr = $ai[0]{addr}; + } + + ## Create a socket and attach the filehandle to it. + socket $self, $af, SOCK_STREAM, 0 + or die "problem creating socket: $!\n"; + + ## Bind to a local network interface. + if (length $localhost) { + if ($lfamily eq "ipv4") { + ## Lookup server's IP address. + $ip_addr = inet_aton $localhost + or die "unknown local host: $localhost\n"; + $local_addr = sockaddr_in(0, $ip_addr); + } + else { # local family is "ipv6" or "any" + ## Lookup local IP address. + ($err, @ai) = Socket::getaddrinfo($localhost, 0, + {socktype => SOCK_STREAM, + "family"=>$af{$lfamily}, + "flags" => 0 }); + die "unknown local host: $localhost: $err\n" + if $err or !@ai; + $local_addr = $ai[0]{addr}; + } + + bind $self, $local_addr + or die "problem binding to \"$localhost\": $!\n"; + } + + ## Open connection to server. + connect $self, $remote_addr + or die "problem connecting to \"$host\", port $port: $!\n"; + }; + alarm 0; + + ## Check for error. + if ($@ =~ /^timed-out$/) { # time out failure + $s->{timedout} = 1; + $self->close; + if (!$remote_addr) { + return $self->error("unknown remote host: $host: ", + "name lookup timed-out"); + } + elsif (length($localhost) and !$local_addr) { + return $self->error("unknown local host: $localhost: ", + "name lookup timed-out"); + } + else { + return $self->error("problem connecting to \"$host\", ", + "port $port: connect timed-out"); + } + } + elsif ($@) { # hostname lookup or connect failure + $self->close; + chomp $@; + return $self->error($@); + } + } + else { # don't use a timeout + $timeout = undef; + + if ($family eq "ipv4") { + ## Lookup server's IP address. + $ip_addr = inet_aton $host + or return $self->error("unknown remote host: $host"); + $af = AF_INET; + $remote_addr = sockaddr_in($port, $ip_addr); + } + else { # family is "ipv6" or "any" + ## Lookup server's IP address. + $flags_hint = $family eq "any" ? $AI_ADDRCONFIG : 0; + ($err, @ai) = Socket::getaddrinfo($host, $port, + { socktype => SOCK_STREAM, + "family" => $af{$family}, + "flags" => $flags_hint }); + if ($err == $EAI_BADFLAGS) { + ## Try again with no flags. + ($err, @ai) = Socket::getaddrinfo($host, $port, + { socktype => SOCK_STREAM, + "family"=> $af{$family}, + "flags" => 0 }); + } + return $self->error("unknown remote host: $host") + if $err or !@ai; + $af = $ai[0]{"family"}; + $remote_addr = $ai[0]{addr}; + } + + ## Create a socket and attach the filehandle to it. + socket $self, $af, SOCK_STREAM, 0 + or return $self->error("problem creating socket: $!"); + + ## Bind to a local network interface. + if (length $localhost) { + if ($lfamily eq "ipv4") { + ## Lookup server's IP address. + $ip_addr = inet_aton $localhost + or return $self->error("unknown local host: $localhost"); + $local_addr = sockaddr_in(0, $ip_addr); + } + else { # local family is "ipv6" or "any" + ## Lookup local IP address. + ($err, @ai) = Socket::getaddrinfo($localhost, 0, + { socktype => SOCK_STREAM, + "family"=>$af{$lfamily}, + "flags" => 0 }); + return $self->error("unknown local host: $localhost: $err") + if $err or !@ai; + $local_addr = $ai[0]{addr}; + } + + bind $self, $local_addr + or return $self->error("problem binding ", + "to \"$localhost\": $!"); + } + + ## Open connection to server. + connect $self, $remote_addr + or do { + $errno = "$!"; + $self->close; + return $self->error("problem connecting to \"$host\", ", + "port $port: $errno"); + }; + } + + select((select($self), $|=1)[$[]); # don't buffer writes + $s->{blksize} = &_optimal_blksize((stat $self)[11]); + $s->{buf} = ""; + $s->{eofile} = ''; + $s->{errormsg} = ""; + vec($s->{fdmask}='', fileno($self), 1) = 1; + $s->{last_line} = ""; + $s->{sock_family} = $af; + $s->{num_wrote} = 0; + $s->{opened} = 1; + $s->{pending_errormsg} = ""; + $s->{pushback_buf} = ""; + $s->{select_supported} = 1; + $s->{timedout} = ''; + $s->{unsent_opts} = ""; + &_reset_options($s->{opts}); + + 1; +} # end sub open + + +sub option_accept { + my ($self, @args) = @_; + my ( + $arg, + $option, + $s, + @opt_args, + ); + local $_; + + ## Init. + $s = *$self->{net_telnet}; + + ## Parse the named args. + while (($_, $arg) = splice @args, 0, 2) { + ## Verify and save arguments. + if (/^-?do$/i) { + ## Make sure a callback is defined. + return $self->error("usage: an option callback must already ", + "be defined when enabling with $_") + unless $s->{opt_cback}; + + $option = &_verify_telopt_arg($self, $arg, $_); + return unless defined $option; + push @opt_args, { option => $option, + is_remote => '', + is_enable => 1, + }; + } + elsif (/^-?dont$/i) { + $option = &_verify_telopt_arg($self, $arg, $_); + return unless defined $option; + push @opt_args, { option => $option, + is_remote => '', + is_enable => '', + }; + } + elsif (/^-?will$/i) { + ## Make sure a callback is defined. + return $self->error("usage: an option callback must already ", + "be defined when enabling with $_") + unless $s->{opt_cback}; + + $option = &_verify_telopt_arg($self, $arg, $_); + return unless defined $option; + push @opt_args, { option => $option, + is_remote => 1, + is_enable => 1, + }; + } + elsif (/^-?wont$/i) { + $option = &_verify_telopt_arg($self, $arg, $_); + return unless defined $option; + push @opt_args, { option => $option, + is_remote => 1, + is_enable => '', + }; + } + else { + return $self->error('usage: $obj->option_accept(' . + '[Do => $telopt,] ', + '[Dont => $telopt,] ', + '[Will => $telopt,] ', + '[Wont => $telopt,]'); + } + } + + ## Set "receive ok" for options specified. + &_opt_accept($self, @opt_args); +} # end sub option_accept + + +sub option_callback { + my ($self, $callback) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{opt_cback}; + + if (@_ >= 2) { + unless (defined $callback and ref($callback) eq "CODE") { + &_carp($self, "ignoring Option_callback argument because it's " . + "not a code ref"); + $callback = $prev; + } + + $s->{opt_cback} = $callback; + } + + $prev; +} # end sub option_callback + + +sub option_log { + my ($self, $name) = @_; + my ( + $fh, + $s, + ); + + $s = *$self->{net_telnet}; + $fh = $s->{opt_log}; + + if (@_ >= 2) { + if (!defined($name) or $name eq "") { # input arg is "" + ## Turn off logging. + $fh = ""; + } + elsif (&_is_open_fh($name)) { # input arg is an open fh + ## Use the open fh for logging. + $fh = $name; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + elsif (!ref $name) { # input arg is filename + ## Open the file for logging. + $fh = &_fname_to_handle($self, $name) + or return; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + else { + return $self->error("bad Option_log argument ", + "\"$name\": not filename or open fh"); + } + + $s->{opt_log} = $fh; + } + + $fh; +} # end sub option_log + + +sub option_state { + my ($self, $option) = @_; + my ( + $opt_state, + $s, + %opt_state, + ); + + ## Ensure telnet option is non-negative integer. + $option = &_verify_telopt_arg($self, $option); + return unless defined $option; + + ## Init. + $s = *$self->{net_telnet}; + unless (defined $s->{opts}{$option}) { + &_set_default_option($s, $option); + } + + ## Return hashref to a copy of the values. + $opt_state = $s->{opts}{$option}; + %opt_state = %$opt_state; + \%opt_state; +} # end sub option_state + + +## Make ors() synonymous with output_record_separator(). +sub ors { &output_record_separator; } + + +sub output_field_separator { + my ($self, $ofs) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{"ofs"}; + + if (@_ >= 2) { + unless (defined $ofs) { + $ofs = ""; + } + + $s->{"ofs"} = $ofs; + } + + $prev; +} # end sub output_field_separator + + +sub output_log { + my ($self, $name) = @_; + my ( + $fh, + $s, + ); + + $s = *$self->{net_telnet}; + $fh = $s->{outputlog}; + + if (@_ >= 2) { + if (!defined($name) or $name eq "") { # input arg is "" + ## Turn off logging. + $fh = ""; + } + elsif (&_is_open_fh($name)) { # input arg is an open fh + ## Use the open fh for logging. + $fh = $name; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + elsif (!ref $name) { # input arg is filename + ## Open the file for logging. + $fh = &_fname_to_handle($self, $name) + or return; + select((select($fh), $|=1)[$[]); # don't buffer writes + } + else { + return $self->error("bad Output_log argument ", + "\"$name\": not filename or open fh"); + } + + $s->{outputlog} = $fh; + } + + $fh; +} # end sub output_log + + +sub output_record_separator { + my ($self, $ors) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{"ors"}; + + if (@_ >= 2) { + unless (defined $ors) { + $ors = ""; + } + + $s->{"ors"} = $ors; + } + + $prev; +} # end sub output_record_separator + + +sub peerhost { + my ($self) = @_; + my ( + $host, + $sockaddr, + ); + local $^W = ''; # avoid closed socket warning from getpeername() + + ## Get packed sockaddr struct of remote side and then unpack it. + $sockaddr = getpeername $self + or return ""; + (undef, $host) = $self->_unpack_sockaddr($sockaddr); + + $host; +} # end sub peerhost + + +sub peerport { + my ($self) = @_; + my ( + $port, + $sockaddr, + ); + local $^W = ''; # avoid closed socket warning from getpeername() + + ## Get packed sockaddr struct of remote side and then unpack it. + $sockaddr = getpeername $self + or return ""; + ($port) = $self->_unpack_sockaddr($sockaddr); + + $port; +} # end sub peerport + + +sub port { + my ($self, $port) = @_; + my ( + $prev, + $s, + $service, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{port}; + + if (@_ >= 2) { + $port = &_parse_port($self, $port) + or return; + + $s->{port} = $port; + } + + $prev; +} # end sub port + + +sub print { + my ($self) = shift; + my ( + $buf, + $fh, + $s, + ); + + $s = *$self->{net_telnet}; + $s->{timedout} = ''; + return $self->error("write error: filehandle isn't open") + unless $s->{opened}; + + ## Add field and record separators. + $buf = join($s->{"ofs"}, @_) . $s->{"ors"}; + + ## Log the output if requested. + if ($s->{outputlog}) { + &_log_print($s->{outputlog}, $buf); + } + + ## Convert native newlines to CR LF. + if (!$s->{bin_mode}) { + $buf =~ s(\n)(\015\012)g; + } + + ## Escape TELNET IAC and also CR not followed by LF. + if ($s->{telnet_mode}) { + $buf =~ s(\377)(\377\377)g; + &_escape_cr(\$buf); + } + + &_put($self, \$buf, "print"); +} # end sub print + + +sub print_length { + my ($self) = @_; + + *$self->{net_telnet}{num_wrote}; +} # end sub print_length + + +sub prompt { + my ($self, $prompt) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{cmd_prompt}; + + ## Parse args. + if (@_ == 2) { + $prompt = &_parse_prompt($self, $prompt) + or return; + + $s->{cmd_prompt} = $prompt; + } + + $prev; +} # end sub prompt + + +sub put { + my ($self) = @_; + my ( + $binmode, + $buf, + $errmode, + $is_timeout_arg, + $s, + $telnetmode, + $timeout, + %args, + ); + local $_; + + ## Init. + $s = *$self->{net_telnet}; + $s->{timedout} = ''; + + ## Parse args. + if (@_ == 2) { # one positional arg given + $buf = $_[1]; + } + elsif (@_ > 2) { # named args given + ## Get the named args. + (undef, %args) = @_; + + ## Parse the named args. + foreach (keys %args) { + if (/^-?binmode$/i) { + $binmode = $args{$_}; + unless (defined $binmode) { + $binmode = 0; + } + } + elsif (/^-?errmode$/i) { + $errmode = &_parse_errmode($self, $args{$_}); + } + elsif (/^-?string$/i) { + $buf = $args{$_}; + } + elsif (/^-?telnetmode$/i) { + $telnetmode = $args{$_}; + unless (defined $telnetmode) { + $telnetmode = 0; + } + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $args{$_}); + $is_timeout_arg = 1; + } + else { + &_croak($self, "bad named parameter \"$_\" given ", + "to " . ref($self) . "::put()"); + } + } + } + + ## If any args given, override corresponding instance data. + local $s->{bin_mode} = $binmode + if defined $binmode; + local $s->{errormode} = $errmode + if defined $errmode; + local $s->{telnet_mode} = $telnetmode + if defined $telnetmode; + local $s->{time_out} = $timeout + if defined $is_timeout_arg; + + ## Check for errors. + return $self->error("write error: filehandle isn't open") + unless $s->{opened}; + + ## Log the output if requested. + if ($s->{outputlog}) { + &_log_print($s->{outputlog}, $buf); + } + + ## Convert native newlines to CR LF. + if (!$s->{bin_mode}) { + $buf =~ s(\n)(\015\012)g; + } + + ## Escape TELNET IAC and also CR not followed by LF. + if ($s->{telnet_mode}) { + $buf =~ s(\377)(\377\377)g; + &_escape_cr(\$buf); + } + + &_put($self, \$buf, "put"); +} # end sub put + + +## Make rs() synonymous input_record_separator(). +sub rs { &input_record_separator; } + + +sub sockfamily { + my ($self) = @_; + my $s = *$self->{net_telnet}; + my $sockfamily = ""; + + if ($s->{sock_family} == AF_INET) { + $sockfamily = "ipv4"; + } + elsif (defined($AF_INET6) and $s->{sock_family} == $AF_INET6) { + $sockfamily = "ipv6"; + } + + $sockfamily; +} # end sub sockfamily + + +sub sockhost { + my ($self) = @_; + my ( + $host, + $sockaddr, + ); + local $^W = ''; # avoid closed socket warning from getsockname() + + ## Get packed sockaddr struct of local side and then unpack it. + $sockaddr = getsockname $self + or return ""; + (undef, $host) = $self->_unpack_sockaddr($sockaddr); + + $host; +} # end sub sockhost + + +sub sockport { + my ($self) = @_; + my ( + $port, + $sockaddr, + ); + local $^W = ''; # avoid closed socket warning from getsockname() + + ## Get packed sockaddr struct of local side and then unpack it. + $sockaddr = getsockname $self + or return ""; + ($port) = $self->_unpack_sockaddr($sockaddr); + + $port; +} # end sub sockport + + +sub suboption_callback { + my ($self, $callback) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{subopt_cback}; + + if (@_ >= 2) { + unless (defined $callback and ref($callback) eq "CODE") { + &_carp($self,"ignoring Suboption_callback argument because it's " . + "not a code ref"); + $callback = $prev; + } + + $s->{subopt_cback} = $callback; + } + + $prev; +} # end sub suboption_callback + + +sub telnetmode { + my ($self, $mode) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{telnet_mode}; + + if (@_ >= 2) { + unless (defined $mode) { + $mode = 0; + } + + $s->{telnet_mode} = $mode; + } + + $prev; +} # end sub telnetmode + + +sub timed_out { + my ($self, $value) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{timedout}; + + if (@_ >= 2) { + unless (defined $value) { + $value = ""; + } + + $s->{timedout} = $value; + } + + $prev; +} # end sub timed_out + + +sub timeout { + my ($self, $timeout) = @_; + my ( + $prev, + $s, + ); + + $s = *$self->{net_telnet}; + $prev = $s->{time_out}; + + if (@_ >= 2) { + $s->{time_out} = &_parse_timeout($self, $timeout); + } + + $prev; +} # end sub timeout + + +sub waitfor { + my ($self, @args) = @_; + my ( + $arg, + $binmode, + $endtime, + $errmode, + $len, + $match, + $match_op, + $pos, + $prematch, + $s, + $search, + $search_cond, + $telnetmode, + $timeout, + @match_cond, + @match_ops, + @search_cond, + @string_cond, + @warns, + ); + local $@; + local $_; + + ## Init. + $s = *$self->{net_telnet}; + $s->{timedout} = ''; + return if $s->{eofile}; + return unless @args; + $timeout = $s->{time_out}; + + ## Code template used to build string match conditional. + ## Values between array elements must be supplied later. + @string_cond = + ('if (($pos = index $s->{buf}, ', ') > -1) { + $len = ', '; + $prematch = substr $s->{buf}, 0, $pos; + $match = substr $s->{buf}, $pos, $len; + substr($s->{buf}, 0, $pos + $len) = ""; + last; + }'); + + ## Code template used to build pattern match conditional. + ## Values between array elements must be supplied later. + @match_cond = + ('if ($s->{buf} =~ ', ') { + $prematch = $`; + $match = $&; + substr($s->{buf}, 0, length($`) + length($&)) = ""; + last; + }'); + + ## Parse args. + if (@_ == 2) { # one positional arg given + $arg = $_[1]; + + ## Fill in the blanks in the code template. + push @match_ops, $arg; + push @search_cond, join("", $match_cond[0], $arg, $match_cond[1]); + } + elsif (@_ > 2) { # named args given + ## Parse the named args. + while (($_, $arg) = splice @args, 0, 2) { + if (/^-?binmode$/i) { + $binmode = $arg; + unless (defined $binmode) { + $binmode = 0; + } + } + elsif (/^-?errmode$/i) { + $errmode = &_parse_errmode($self, $arg); + } + elsif (/^-?match$/i) { + ## Fill in the blanks in the code template. + push @match_ops, $arg; + push @search_cond, join("", + $match_cond[0], $arg, $match_cond[1]); + } + elsif (/^-?string$/i) { + ## Fill in the blanks in the code template. + $arg =~ s/'/\\'/g; # quote ticks + push @search_cond, join("", + $string_cond[0], "'$arg'", + $string_cond[1], length($arg), + $string_cond[2]); + } + elsif (/^-?telnetmode$/i) { + $telnetmode = $arg; + unless (defined $telnetmode) { + $telnetmode = 0; + } + } + elsif (/^-?timeout$/i) { + $timeout = &_parse_timeout($self, $arg); + } + else { + &_croak($self, "bad named parameter \"$_\" given " . + "to " . ref($self) . "::waitfor()"); + } + } + } + + ## If any args given, override corresponding instance data. + local $s->{errormode} = $errmode + if defined $errmode; + local $s->{bin_mode} = $binmode + if defined $binmode; + local $s->{telnet_mode} = $telnetmode + if defined $telnetmode; + + ## Check for bad match operator argument. + foreach $match_op (@match_ops) { + return $self->error("missing opening delimiter of match operator ", + "in argument \"$match_op\" given to ", + ref($self) . "::waitfor()") + unless $match_op =~ m(^\s*/) or $match_op =~ m(^\s*m\s*\W); + } + + ## Construct conditional to check for requested string and pattern matches. + ## Turn subsequent "if"s into "elsif". + $search_cond = join "\n\tels", @search_cond; + + ## Construct loop to fill buffer until string/pattern, timeout, or eof. + $search = join "", " + while (1) {\n\t", + $search_cond, ' + &_fillbuf($self, $s, $endtime) + or do { + last if $s->{timedout}; + $self->close; + last; + }; + }'; + + ## Set wall time when we timeout. + $endtime = &_endtime($timeout); + + ## Run the loop. + { + local $^W = 1; + local $SIG{"__WARN__"} = sub { push @warns, @_ }; + local $s->{errormode} = "return"; + $s->{errormsg} = ""; + eval $search; + } + + ## Check for failure. + return $self->error("pattern match timed-out") if $s->{timedout}; + return $self->error($s->{errormsg}) if $s->{errormsg} ne ""; + return $self->error("pattern match read eof") if $s->{eofile}; + + ## Check for Perl syntax errors or warnings. + if ($@ or @warns) { + foreach $match_op (@match_ops) { + &_match_check($self, $match_op) + or return; + } + return $self->error($@) if $@; + return $self->error(@warns) if @warns; + } + + wantarray ? ($prematch, $match) : 1; +} # end sub waitfor + + +######################## Private Subroutines ######################### + + +sub _append_lineno { + my ($obj, @msgs) = @_; + my ( + $file, + $line, + $pkg, + ); + + ## Find the caller that's not in object's class or one of its base classes. + ($pkg, $file , $line) = &_user_caller($obj); + join("", @msgs, " at ", $file, " line ", $line, "\n"); +} # end sub _append_lineno + + +sub _carp { + my ($self) = @_; + my $s = *$self->{net_telnet}; + + $s->{errormsg} = &_append_lineno(@_); + warn $s->{errormsg}, "\n"; +} # end sub _carp + + +sub _croak { + my ($self) = @_; + my $s = *$self->{net_telnet}; + + $s->{errormsg} = &_append_lineno(@_); + die $s->{errormsg}, "\n"; +} # end sub _croak + + +sub _endtime { + my ($interval) = @_; + + ## Compute wall time when timeout occurs. + if (defined $interval) { + if ($interval >= $^T) { # it's already an absolute time + return $interval; + } + elsif ($interval > 0) { # it's relative to the current time + return int($interval + time + 0.5); + } + else { # it's a one time poll + return 0; + } + } + else { # there's no timeout + return undef; + } +} # end sub _endtime + + +sub _errno_include { + local $@; + local $SIG{"__DIE__"} = "DEFAULT"; + + eval "require Errno"; +} # end sub errno_include + + +sub _escape_cr { + my ($string) = @_; + my ( + $nextchar, + ); + my $pos = 0; + + ## Convert all CR (not followed by LF) to CR NULL. + while (($pos = index($$string, "\015", $pos)) > -1) { + $nextchar = substr $$string, $pos + 1, 1; + + substr($$string, $pos, 1) = "\015\000" + unless $nextchar eq "\012"; + + $pos++; + } + + 1; +} # end sub _escape_cr + + +sub _extract_arg_errmode { + my ($self, $args) = @_; + my ( + %args, + ); + local $_; + my $errmode = ''; + + ## Check for named parameters. + return '' unless @$args >= 2; + + ## Rebuild args without errmode parameter. + %args = @$args; + @$args = (); + + ## Extract errmode arg. + foreach (keys %args) { + if (/^-?errmode$/i) { + $errmode = &_parse_errmode($self, $args{$_}); + } + else { + push @$args, $_, $args{$_}; + } + } + + $errmode; +} # end sub _extract_arg_errmode + + +sub _fillbuf { + my ($self, $s, $endtime) = @_; + my ( + $msg, + $nfound, + $nread, + $pushback_len, + $read_pos, + $ready, + $timed_out, + $timeout, + $unparsed_pos, + ); + + ## If error from last read not yet reported then do it now. + if ($s->{pending_errormsg}) { + $msg = $s->{pending_errormsg}; + $s->{pending_errormsg} = ""; + return $self->error($msg); + } + + return unless $s->{opened}; + + while (1) { + ## Maximum buffer size exceeded? + return $self->error("maximum input buffer length exceeded: ", + $s->{maxbufsize}, " bytes") + unless length($s->{buf}) <= $s->{maxbufsize}; + + ## Determine how long to wait for input ready. + ($timed_out, $timeout) = &_timeout_interval($endtime); + if ($timed_out) { + $s->{timedout} = 1; + return $self->error("read timed-out"); + } + + ## Wait for input ready. + $nfound = select $ready=$s->{fdmask}, "", "", $timeout; + + ## Handle any errors while waiting. + if ((!defined $nfound or $nfound <= 0) and $s->{select_supported}) { + if (defined $nfound and $nfound == 0) { # timed-out + $s->{timedout} = 1; + return $self->error("read timed-out"); + } + else { # error waiting for input ready + if (defined $EINTR) { + next if $! == $EINTR; # restart select() + } + else { + next if $! =~ /^interrupted/i; # restart select() + } + + $s->{opened} = ''; + return $self->error("read error: $!"); + } + } + + ## Append to buffer any partially processed telnet or CR sequence. + $pushback_len = length $s->{pushback_buf}; + if ($pushback_len) { + $s->{buf} .= $s->{pushback_buf}; + $s->{pushback_buf} = ""; + } + + ## Read the waiting data. + $read_pos = length $s->{buf}; + $unparsed_pos = $read_pos - $pushback_len; + $nread = sysread $self, $s->{buf}, $s->{blksize}, $read_pos; + + ## Handle any read errors. + if (!defined $nread) { # read failed + if (defined $EINTR) { + next if $! == $EINTR; # restart sysread() + } + else { + next if $! =~ /^interrupted/i; # restart sysread() + } + + $s->{opened} = ''; + return $self->error("read error: $!"); + } + + ## Handle eof. + if ($nread == 0) { # eof read + $s->{opened} = ''; + return; + } + + ## Display network traffic if requested. + if ($s->{dumplog}) { + &_log_dump('<', $s->{dumplog}, \$s->{buf}, $read_pos); + } + + ## Process any telnet commands in the data stream. + if ($s->{telnet_mode} and index($s->{buf},"\377",$unparsed_pos) > -1) { + &_interpret_tcmd($self, $s, $unparsed_pos); + } + + ## Process any carriage-return sequences in the data stream. + &_interpret_cr($s, $unparsed_pos); + + ## Read again if all chars read were consumed as telnet cmds. + next if $unparsed_pos >= length $s->{buf}; + + ## Log the input if requested. + if ($s->{inputlog}) { + &_log_print($s->{inputlog}, substr($s->{buf}, $unparsed_pos)); + } + + ## Save the last line read. + &_save_lastline($s); + + ## We've successfully read some data into the buffer. + last; + } # end while(1) + + 1; +} # end sub _fillbuf + + +sub _flush_opts { + my ($self) = @_; + my ( + $option_chars, + ); + my $s = *$self->{net_telnet}; + + ## Get option and clear the output buf. + $option_chars = $s->{unsent_opts}; + $s->{unsent_opts} = ""; + + ## Try to send options without waiting. + { + local $s->{errormode} = "return"; + local $s->{time_out} = 0; + &_put($self, \$option_chars, "telnet option negotiation") + or do { + ## Save chars not printed for later. + substr($option_chars, 0, $self->print_length) = ""; + $s->{unsent_opts} .= $option_chars; + }; + } + + 1; +} # end sub _flush_opts + + +sub _fname_to_handle { + my ($self, $filename) = @_; + my ( + $fh, + ); + no strict "refs"; + + $fh = &_new_handle(); + CORE::open $fh, "> $filename" + or return $self->error("problem creating $filename: $!"); + + $fh; +} # end sub _fname_to_handle + + +sub _have_alarm { + local $@; + + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + local $SIG{ALRM} = sub { die }; + alarm 0; + }; + + ! $@; +} # end sub _have_alarm + + +sub _import_af_inet6 { + local $@; + + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + + Socket::AF_INET6(); + }; +} # end sub _import_af_inet6 + + +sub _import_af_unspec { + local $@; + + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + + Socket::AF_UNSPEC(); + }; +} # end sub _import_af_unspec + + +sub _import_ai_addrconfig { + local $@; + + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + + Socket::AI_ADDRCONFIG(); + }; +} # end sub _import_ai_addrconfig + + +sub _import_eai_badflags { + local $@; + + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + + Socket::EAI_BADFLAGS(); + }; +} # end sub _import_eai_badflags + + +sub _import_eintr { + local $@; + local $SIG{"__DIE__"} = "DEFAULT"; + + eval "require Errno; Errno::EINTR();"; +} # end sub _import_eintr + + +sub _interpret_cr { + my ($s, $pos) = @_; + my ( + $nextchar, + ); + + while (($pos = index($s->{buf}, "\015", $pos)) > -1) { + $nextchar = substr($s->{buf}, $pos + 1, 1); + if ($nextchar eq "\0") { + ## Convert CR NULL to CR when in telnet mode. + if ($s->{telnet_mode}) { + substr($s->{buf}, $pos + 1, 1) = ""; + } + } + elsif ($nextchar eq "\012") { + ## Convert CR LF to newline when not in binary mode. + if (!$s->{bin_mode}) { + substr($s->{buf}, $pos, 2) = "\n"; + } + } + elsif (!length($nextchar) and ($s->{telnet_mode} or !$s->{bin_mode})) { + ## Save CR in alt buffer for possible CR LF or CR NULL conversion. + $s->{pushback_buf} .= "\015"; + chop $s->{buf}; + } + + $pos++; + } + + 1; +} # end sub _interpret_cr + + +sub _interpret_tcmd { + my ($self, $s, $offset) = @_; + my ( + $callback, + $endpos, + $nextchar, + $option, + $parameters, + $pos, + $subcmd, + ); + local $_; + + ## Parse telnet commands in the data stream. + $pos = $offset; + while (($pos = index $s->{buf}, "\377", $pos) > -1) { # unprocessed IAC + $nextchar = substr $s->{buf}, $pos + 1, 1; + + ## Save command if it's only partially read. + if (!length $nextchar) { + $s->{pushback_buf} .= "\377"; + chop $s->{buf}; + last; + } + + if ($nextchar eq "\377") { # IAC is escaping "\377" char + ## Remove escape char from data stream. + substr($s->{buf}, $pos, 1) = ""; + $pos++; + } + elsif ($nextchar eq "\375" or $nextchar eq "\373" or + $nextchar eq "\374" or $nextchar eq "\376") { # opt negotiation + $option = substr $s->{buf}, $pos + 2, 1; + + ## Save command if it's only partially read. + if (!length $option) { + $s->{pushback_buf} .= "\377" . $nextchar; + chop $s->{buf}; + chop $s->{buf}; + last; + } + + ## Remove command from data stream. + substr($s->{buf}, $pos, 3) = ""; + + ## Handle option negotiation. + &_negotiate_recv($self, $s, $nextchar, ord($option), $pos); + } + elsif ($nextchar eq "\372") { # start of subnegotiation parameters + ## Save command if it's only partially read. + $endpos = index $s->{buf}, "\360", $pos; + if ($endpos == -1) { + $s->{pushback_buf} .= substr $s->{buf}, $pos; + substr($s->{buf}, $pos) = ""; + last; + } + + ## Remove subnegotiation cmd from buffer. + $subcmd = substr($s->{buf}, $pos, $endpos - $pos + 1); + substr($s->{buf}, $pos, $endpos - $pos + 1) = ""; + + ## Invoke subnegotiation callback. + if ($s->{subopt_cback} and length($subcmd) >= 5) { + $option = unpack "C", substr($subcmd, 2, 1); + if (length($subcmd) >= 6) { + $parameters = substr $subcmd, 3, length($subcmd) - 5; + } + else { + $parameters = ""; + } + + $callback = $s->{subopt_cback}; + &$callback($self, $option, $parameters); + } + } + else { # various two char telnet commands + ## Ignore and remove command from data stream. + substr($s->{buf}, $pos, 2) = ""; + } + } + + ## Try to send any waiting option negotiation. + if (length $s->{unsent_opts}) { + &_flush_opts($self); + } + + 1; +} # end sub _interpret_tcmd + + +sub _io_socket_include { + local $@; + local $SIG{"__DIE__"} = "DEFAULT"; + + eval "require IO::Socket"; +} # end sub io_socket_include + + +sub _is_open_fh { + my ($fh) = @_; + my $is_open = ''; + local $@; + + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + $is_open = defined(fileno $fh); + }; + + $is_open; +} # end sub _is_open_fh + + +sub _log_dump { + my ($direction, $fh, $data, $offset, $len) = @_; + my ( + $addr, + $hexvals, + $line, + ); + + $addr = 0; + $len = length($$data) - $offset + if !defined $len; + return 1 if $len <= 0; + + ## Print data in dump format. + while ($len > 0) { + ## Convert up to the next 16 chars to hex, padding w/ spaces. + if ($len >= 16) { + $line = substr $$data, $offset, 16; + } + else { + $line = substr $$data, $offset, $len; + } + $hexvals = unpack("H*", $line); + $hexvals .= ' ' x (32 - length $hexvals); + + ## Place in 16 columns, each containing two hex digits. + $hexvals = sprintf("%s %s %s %s " x 4, + unpack("a2" x 16, $hexvals)); + + ## For the ASCII column, change unprintable chars to a period. + $line =~ s/[\000-\037,\177-\237]/./g; + + ## Print the line in dump format. + &_log_print($fh, sprintf("%s 0x%5.5lx: %s%s\n", + $direction, $addr, $hexvals, $line)); + + $addr += 16; + $offset += 16; + $len -= 16; + } + + &_log_print($fh, "\n"); + + 1; +} # end sub _log_dump + + +sub _log_option { + my ($fh, $direction, $request, $option) = @_; + my ( + $name, + ); + + if ($option >= 0 and $option <= $#Telopts) { + $name = $Telopts[$option]; + } + else { + $name = $option; + } + + &_log_print($fh, "$direction $request $name\n"); +} # end sub _log_option + + +sub _log_print { + my ($fh, $buf) = @_; + local $\ = ''; + + if (ref($fh) eq "GLOB") { # fh is GLOB ref + print $fh $buf; + } + else { # fh isn't GLOB ref + $fh->print($buf); + } +} # end sub _log_print + + +sub _match_check { + my ($self, $code) = @_; + my $error; + my @warns = (); + local $@; + + ## Use eval to check for syntax errors or warnings. + { + local $SIG{"__DIE__"} = "DEFAULT"; + local $SIG{"__WARN__"} = sub { push @warns, @_ }; + local $^W = 1; + local $_ = ''; + eval "\$_ =~ $code;"; + } + if ($@) { + ## Remove useless lines numbers from message. + ($error = $@) =~ s/ at \(eval \d+\) line \d+.?//; + chomp $error; + return $self->error("bad match operator: $error"); + } + elsif (@warns) { + ## Remove useless lines numbers from message. + ($error = shift @warns) =~ s/ at \(eval \d+\) line \d+.?//; + $error =~ s/ while "strict subs" in use//; + chomp $error; + return $self->error("bad match operator: $error"); + } + + 1; +} # end sub _match_check + + +sub _negotiate_callback { + my ($self, $opt, $is_remote, $is_enabled, $was_enabled, $opt_bufpos) = @_; + my ( + $callback, + $s, + ); + local $_; + + ## Keep track of remote echo. + if ($is_remote and $opt == &TELOPT_ECHO) { # received WILL or WONT ECHO + $s = *$self->{net_telnet}; + + if ($is_enabled and !$was_enabled) { # received WILL ECHO + $s->{remote_echo} = 1; + } + elsif (!$is_enabled and $was_enabled) { # received WONT ECHO + $s->{remote_echo} = ''; + } + } + + ## Invoke callback, if there is one. + $callback = $self->option_callback; + if ($callback) { + &$callback($self, $opt, $is_remote, + $is_enabled, $was_enabled, $opt_bufpos); + } + + 1; +} # end sub _negotiate_callback + + +sub _negotiate_recv { + my ($self, $s, $opt_request, $opt, $opt_bufpos) = @_; + + ## Ensure data structure exists for this option. + unless (defined $s->{opts}{$opt}) { + &_set_default_option($s, $opt); + } + + ## Process the option. + if ($opt_request eq "\376") { # DONT + &_negotiate_recv_disable($self, $s, $opt, "dont", $opt_bufpos, + $s->{opts}{$opt}{local_enable_ok}, + \$s->{opts}{$opt}{local_enabled}, + \$s->{opts}{$opt}{local_state}); + } + elsif ($opt_request eq "\375") { # DO + &_negotiate_recv_enable($self, $s, $opt, "do", $opt_bufpos, + $s->{opts}{$opt}{local_enable_ok}, + \$s->{opts}{$opt}{local_enabled}, + \$s->{opts}{$opt}{local_state}); + } + elsif ($opt_request eq "\374") { # WONT + &_negotiate_recv_disable($self, $s, $opt, "wont", $opt_bufpos, + $s->{opts}{$opt}{remote_enable_ok}, + \$s->{opts}{$opt}{remote_enabled}, + \$s->{opts}{$opt}{remote_state}); + } + elsif ($opt_request eq "\373") { # WILL + &_negotiate_recv_enable($self, $s, $opt, "will", $opt_bufpos, + $s->{opts}{$opt}{remote_enable_ok}, + \$s->{opts}{$opt}{remote_enabled}, + \$s->{opts}{$opt}{remote_state}); + } + else { # internal error + die; + } + + 1; +} # end sub _negotiate_recv + + +sub _negotiate_recv_disable { + my ($self, $s, $opt, $opt_request, + $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; + my ( + $ack, + $disable_cmd, + $enable_cmd, + $is_remote, + $nak, + $was_enabled, + ); + + ## What do we use to request enable/disable or respond with ack/nak. + if ($opt_request eq "wont") { + $enable_cmd = "\377\375" . pack("C", $opt); # do command + $disable_cmd = "\377\376" . pack("C", $opt); # dont command + $is_remote = 1; + $ack = "DO"; + $nak = "DONT"; + + &_log_option($s->{opt_log}, "RCVD", "WONT", $opt) + if $s->{opt_log}; + } + elsif ($opt_request eq "dont") { + $enable_cmd = "\377\373" . pack("C", $opt); # will command + $disable_cmd = "\377\374" . pack("C", $opt); # wont command + $is_remote = ''; + $ack = "WILL"; + $nak = "WONT"; + + &_log_option($s->{opt_log}, "RCVD", "DONT", $opt) + if $s->{opt_log}; + } + else { # internal error + die; + } + + ## Respond to WONT or DONT based on the current negotiation state. + if ($$state eq "no") { # state is already disabled + } + elsif ($$state eq "yes") { # they're initiating disable + $$is_enabled = ''; + $$state = "no"; + + ## Send positive acknowledgment. + $s->{unsent_opts} .= $disable_cmd; + &_log_option($s->{opt_log}, "SENT", $nak, $opt) + if $s->{opt_log}; + + ## Invoke callbacks. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + elsif ($$state eq "wantno") { # they sent positive ack + $$is_enabled = ''; + $$state = "no"; + + ## Invoke callback. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + elsif ($$state eq "wantno opposite") { # pos ack but we changed our mind + ## Indicate disabled but now we want to enable. + $$is_enabled = ''; + $$state = "wantyes"; + + ## Send queued request. + $s->{unsent_opts} .= $enable_cmd; + &_log_option($s->{opt_log}, "SENT", $ack, $opt) + if $s->{opt_log}; + + ## Invoke callback. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + elsif ($$state eq "wantyes") { # they sent negative ack + $$is_enabled = ''; + $$state = "no"; + + ## Invoke callback. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + elsif ($$state eq "wantyes opposite") { # nak but we changed our mind + $$is_enabled = ''; + $$state = "no"; + + ## Invoke callback. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } +} # end sub _negotiate_recv_disable + + +sub _negotiate_recv_enable { + my ($self, $s, $opt, $opt_request, + $opt_bufpos, $enable_ok, $is_enabled, $state) = @_; + my ( + $ack, + $disable_cmd, + $enable_cmd, + $is_remote, + $nak, + $was_enabled, + ); + + ## What we use to send enable/disable request or send ack/nak response. + if ($opt_request eq "will") { + $enable_cmd = "\377\375" . pack("C", $opt); # do command + $disable_cmd = "\377\376" . pack("C", $opt); # dont command + $is_remote = 1; + $ack = "DO"; + $nak = "DONT"; + + &_log_option($s->{opt_log}, "RCVD", "WILL", $opt) + if $s->{opt_log}; + } + elsif ($opt_request eq "do") { + $enable_cmd = "\377\373" . pack("C", $opt); # will command + $disable_cmd = "\377\374" . pack("C", $opt); # wont command + $is_remote = ''; + $ack = "WILL"; + $nak = "WONT"; + + &_log_option($s->{opt_log}, "RCVD", "DO", $opt) + if $s->{opt_log}; + } + else { # internal error + die; + } + + ## Save current enabled state. + $was_enabled = $$is_enabled; + + ## Respond to WILL or DO based on the current negotiation state. + if ($$state eq "no") { # they're initiating enable + if ($enable_ok) { # we agree they/us should enable + $$is_enabled = 1; + $$state = "yes"; + + ## Send positive acknowledgment. + $s->{unsent_opts} .= $enable_cmd; + &_log_option($s->{opt_log}, "SENT", $ack, $opt) + if $s->{opt_log}; + + ## Invoke callbacks. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + else { # we disagree they/us should enable + ## Send negative acknowledgment. + $s->{unsent_opts} .= $disable_cmd; + &_log_option($s->{opt_log}, "SENT", $nak, $opt) + if $s->{opt_log}; + } + } + elsif ($$state eq "yes") { # state is already enabled + } + elsif ($$state eq "wantno") { # error: our disable req answered by enable + $$is_enabled = ''; + $$state = "no"; + + ## Invoke callbacks. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + elsif ($$state eq "wantno opposite") { # err: disable req answerd by enable + $$is_enabled = 1; + $$state = "yes"; + + ## Invoke callbacks. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + elsif ($$state eq "wantyes") { # they sent pos ack + $$is_enabled = 1; + $$state = "yes"; + + ## Invoke callback. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + elsif ($$state eq "wantyes opposite") { # pos ack but we changed our mind + ## Indicate enabled but now we want to disable. + $$is_enabled = 1; + $$state = "wantno"; + + ## Inform other side we changed our mind. + $s->{unsent_opts} .= $disable_cmd; + &_log_option($s->{opt_log}, "SENT", $nak, $opt) + if $s->{opt_log}; + + ## Invoke callback. + &_negotiate_callback($self, $opt, $is_remote, + $$is_enabled, $was_enabled, $opt_bufpos); + } + + 1; +} # end sub _negotiate_recv_enable + + +sub _new_handle { + if ($INC{"IO/Handle.pm"}) { + return IO::Handle->new; + } + else { + require FileHandle; + return FileHandle->new; + } +} # end sub _new_handle + + +sub _next_getlines { + my ($self, $s) = @_; + my ( + $len, + $line, + $pos, + @lines, + ); + + ## Fill buffer and get first line. + $line = $self->getline + or return; + push @lines, $line; + + ## Extract subsequent lines from buffer. + while (($pos = index($s->{buf}, $s->{"rs"})) != -1) { + $len = $pos + length $s->{"rs"}; + push @lines, substr($s->{buf}, 0, $len); + substr($s->{buf}, 0, $len) = ""; + } + + @lines; +} # end sub _next_getlines + + +sub _opt_accept { + my ($self, @args) = @_; + my ( + $arg, + $option, + $s, + ); + + ## Init. + $s = *$self->{net_telnet}; + + foreach $arg (@args) { + ## Ensure data structure defined for this option. + $option = $arg->{option}; + if (!defined $s->{opts}{$option}) { + &_set_default_option($s, $option); + } + + ## Save whether we'll accept or reject this option. + if ($arg->{is_remote}) { + $s->{opts}{$option}{remote_enable_ok} = $arg->{is_enable}; + } + else { + $s->{opts}{$option}{local_enable_ok} = $arg->{is_enable}; + } + } + + 1; +} # end sub _opt_accept + + +sub _optimal_blksize { + my ($blksize) = @_; + local $^W = ''; # avoid non-numeric warning for ms-windows blksize of "" + + ## Use default when block size is invalid. + if (!defined $blksize or $blksize < 512 or $blksize > 1_048_576) { + $blksize = 4096; + } + + $blksize; +} # end sub _optimal_blksize + + +sub _parse_cmd_remove_mode { + my ($self, $mode) = @_; + + if (!defined $mode) { + $mode = 0; + } + elsif ($mode =~ /^\s*auto\s*$/i) { + $mode = "auto"; + } + elsif ($mode !~ /^\d+$/) { + &_carp($self, "ignoring bad Cmd_remove_mode " . + "argument \"$mode\": it's not \"auto\" or a " . + "non-negative integer"); + $mode = *$self->{net_telnet}{cmd_rm_mode}; + } + + $mode; +} # end sub _parse_cmd_remove_mode + + +sub _parse_errmode { + my ($self, $errmode) = @_; + + ## Set the error mode. + if (!defined $errmode) { + &_carp($self, "ignoring undefined Errmode argument"); + $errmode = *$self->{net_telnet}{errormode}; + } + elsif ($errmode =~ /^\s*return\s*$/i) { + $errmode = "return"; + } + elsif ($errmode =~ /^\s*die\s*$/i) { + $errmode = "die"; + } + elsif (ref($errmode) eq "CODE") { + } + elsif (ref($errmode) eq "ARRAY") { + unless (ref($errmode->[0]) eq "CODE") { + &_carp($self, "ignoring bad Errmode argument: " . + "first list item isn't a code ref"); + $errmode = *$self->{net_telnet}{errormode}; + } + } + else { + &_carp($self, "ignoring bad Errmode argument \"$errmode\""); + $errmode = *$self->{net_telnet}{errormode}; + } + + $errmode; +} # end sub _parse_errmode + + +sub _parse_family { + my ($self, $family) = @_; + my ( + $parsed_family, + ); + + unless (defined $family) { + $family = ""; + } + + if ($family =~ /^\s*ipv4\s*$/i) { # family arg is "ipv4" + $parsed_family = "ipv4"; + } + elsif ($family =~ /^\s*any\s*$/i) { # family arg is "any" + if ($Socket::VERSION >= 1.94 and defined $AF_INET6) { # has IPv6 + $parsed_family = "any"; + } + else { # IPv6 not supported on this machine + $parsed_family = "ipv4"; + } + } + elsif ($family =~ /^\s*ipv6\s*$/i) { # family arg is "ipv6" + return $self->error("Family arg ipv6 not supported when " . + "Socket.pm version < 1.94") + unless $Socket::VERSION >= 1.94; + return $self->error("Family arg ipv6 not supported by " . + "this OS: AF_INET6 not in Socket.pm") + unless defined $AF_INET6; + + $parsed_family = "ipv6"; + } + else { + return $self->error("bad Family argument \"$family\": " . + "must be \"ipv4\", \"ipv6\", or \"any\""); + } + + $parsed_family; +} # end sub _parse_family + + +sub _parse_input_record_separator { + my ($self, $rs) = @_; + + unless (defined $rs and length $rs) { + &_carp($self, "ignoring null Input_record_separator argument"); + $rs = *$self->{net_telnet}{"rs"}; + } + + $rs; +} # end sub _parse_input_record_separator + + +sub _parse_localfamily { + my ($self, $family) = @_; + + unless (defined $family) { + $family = ""; + } + + if ($family =~ /^\s*ipv4\s*$/i) { # family arg is "ipv4" + $family = "ipv4"; + } + elsif ($family =~ /^\s*any\s*$/i) { # family arg is "any" + if ($Socket::VERSION >= 1.94 and defined $AF_INET6) { # has IPv6 + $family = "any"; + } + else { # IPv6 not supported on this machine + $family = "ipv4"; + } + } + elsif ($family =~ /^\s*ipv6\s*$/i) { # family arg is "ipv6" + return $self->error("Localfamily arg ipv6 not supported when " . + "Socket.pm version < 1.94") + unless $Socket::VERSION >= 1.94; + return $self->error("Localfamily arg ipv6 not supported by " . + "this OS: AF_INET6 not in Socket.pm") + unless defined $AF_INET6; + + $family = "ipv6"; + } + else { + return $self->error("bad Localfamily argument \"$family\": " . + "must be \"ipv4\", \"ipv6\", or \"any\""); + } + + $family; +} # end sub _parse_localfamily + + +sub _parse_port { + my ($self, $port) = @_; + my ( + $service, + ); + + unless (defined $port) { + $port = ""; + } + + return $self->error("bad Port argument \"$port\"") + unless $port; + + if ($port !~ /^\d+$/) { # port isn't all digits + $service = $port; + $port = getservbyname($service, "tcp"); + + return $self->error("bad Port argument \"$service\": " . + "it's an unknown TCP service") + unless $port; + } + + $port; +} # end sub _parse_port + + +sub _parse_prompt { + my ($self, $prompt) = @_; + + unless (defined $prompt) { + $prompt = ""; + } + + return $self->error("bad Prompt argument \"$prompt\": " . + "missing opening delimiter of match operator") + unless $prompt =~ m(^\s*/) or $prompt =~ m(^\s*m\s*\W); + + $prompt; +} # end sub _parse_prompt + + +sub _parse_timeout { + my ($self, $timeout) = @_; + local $@; + + ## Ensure valid timeout. + if (defined $timeout) { + ## Test for non-numeric or negative values. + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + local $SIG{"__WARN__"} = sub { die "non-numeric\n" }; + local $^W = 1; + $timeout *= 1; + }; + if ($@) { # timeout arg is non-numeric + &_carp($self, + "ignoring non-numeric Timeout argument \"$timeout\""); + $timeout = *$self->{net_telnet}{time_out}; + } + elsif ($timeout < 0) { # timeout arg is negative + &_carp($self, "ignoring negative Timeout argument \"$timeout\""); + $timeout = *$self->{net_telnet}{time_out}; + } + } + + $timeout; +} # end sub _parse_timeout + + +sub _put { + my ($self, $buf, $subname) = @_; + my ( + $endtime, + $len, + $nfound, + $nwrote, + $offset, + $ready, + $s, + $timed_out, + $timeout, + $zero_wrote_count, + ); + + ## Init. + $s = *$self->{net_telnet}; + $s->{num_wrote} = 0; + $zero_wrote_count = 0; + $offset = 0; + $len = length $$buf; + $endtime = &_endtime($s->{time_out}); + + return $self->error("write error: filehandle isn't open") + unless $s->{opened}; + + ## Try to send any waiting option negotiation. + if (length $s->{unsent_opts}) { + &_flush_opts($self); + } + + ## Write until all data blocks written. + while ($len) { + ## Determine how long to wait for output ready. + ($timed_out, $timeout) = &_timeout_interval($endtime); + if ($timed_out) { + $s->{timedout} = 1; + return $self->error("$subname timed-out"); + } + + ## Wait for output ready. + $nfound = select "", $ready=$s->{fdmask}, "", $timeout; + + ## Handle any errors while waiting. + if ((!defined $nfound or $nfound <= 0) and $s->{select_supported}) { + if (defined $nfound and $nfound == 0) { # timed-out + $s->{timedout} = 1; + return $self->error("$subname timed-out"); + } + else { # error waiting for output ready + if (defined $EINTR) { + next if $! == $EINTR; # restart select() + } + else { + next if $! =~ /^interrupted/i; # restart select() + } + + $s->{opened} = ''; + return $self->error("write error: $!"); + } + } + + ## Write the data. + $nwrote = syswrite $self, $$buf, $s->{blksize}, $offset; + + ## Handle any write errors. + if (!defined $nwrote) { # write failed + if (defined $EINTR) { + next if $! == $EINTR; # restart syswrite() + } + else { + next if $! =~ /^interrupted/i; # restart syswrite() + } + + $s->{opened} = ''; + return $self->error("write error: $!"); + } + elsif ($nwrote == 0) { # zero chars written + ## Try ten more times to write the data. + if ($zero_wrote_count++ <= 10) { + &_sleep(0.01); + next; + } + + $s->{opened} = ''; + return $self->error("write error: zero length write: $!"); + } + + ## Display network traffic if requested. + if ($s->{dumplog}) { + &_log_dump('>', $s->{dumplog}, $buf, $offset, $nwrote); + } + + ## Increment. + $s->{num_wrote} += $nwrote; + $offset += $nwrote; + $len -= $nwrote; + } + + 1; +} # end sub _put + + +sub _qualify_fh { + my ($obj, $name) = @_; + my ( + $user_class, + ); + local $@; + local $_; + + ## Get user's package name. + ($user_class) = &_user_caller($obj); + + ## Ensure name is qualified with a package name. + $name = qualify($name, $user_class); + + ## If it's not already, make it a typeglob ref. + if (!ref $name) { + no strict; + local $SIG{"__DIE__"} = "DEFAULT"; + local $^W = ''; + + $name =~ s/^\*+//; + $name = eval "\\*$name"; + return unless ref $name; + } + + $name; +} # end sub _qualify_fh + + +sub _reset_options { + my ($opts) = @_; + my ( + $opt, + ); + + foreach $opt (keys %$opts) { + $opts->{$opt}{remote_enabled} = ''; + $opts->{$opt}{remote_state} = "no"; + $opts->{$opt}{local_enabled} = ''; + $opts->{$opt}{local_state} = "no"; + } + + 1; +} # end sub _reset_options + + +sub _save_lastline { + my ($s) = @_; + my ( + $firstpos, + $lastpos, + $len_w_sep, + $len_wo_sep, + $offset, + ); + my $rs = "\n"; + + if (($lastpos = rindex $s->{buf}, $rs) > -1) { # eol found + while (1) { + ## Find beginning of line. + $firstpos = rindex $s->{buf}, $rs, $lastpos - 1; + if ($firstpos == -1) { + $offset = 0; + } + else { + $offset = $firstpos + length $rs; + } + + ## Determine length of line with and without separator. + $len_wo_sep = $lastpos - $offset; + $len_w_sep = $len_wo_sep + length $rs; + + ## Save line if it's not blank. + if (substr($s->{buf}, $offset, $len_wo_sep) + !~ /^\s*$/) + { + $s->{last_line} = substr($s->{buf}, + $offset, + $len_w_sep); + last; + } + + last if $firstpos == -1; + + $lastpos = $firstpos; + } + } + + 1; +} # end sub _save_lastline + + +sub _set_default_option { + my ($s, $option) = @_; + + $s->{opts}{$option} = { + remote_enabled => '', + remote_state => "no", + remote_enable_ok => '', + local_enabled => '', + local_state => "no", + local_enable_ok => '', + }; +} # end sub _set_default_option + + +sub _sleep { + my ($secs) = @_; + my $bitmask = ""; + local *SOCK; + + socket SOCK, AF_INET, SOCK_STREAM, 0; + vec($bitmask, fileno(SOCK), 1) = 1; + select $bitmask, "", "", $secs; + CORE::close SOCK; + + 1; +} # end sub _sleep + + +sub _timeout_interval { + my ($endtime) = @_; + my ( + $timeout, + ); + + ## Return timed-out boolean and timeout interval. + if (defined $endtime) { + ## Is it a one-time poll. + return ('', 0) if $endtime == 0; + + ## Calculate the timeout interval. + $timeout = $endtime - time; + + ## Did we already timeout. + return (1, 0) unless $timeout > 0; + + return ('', $timeout); + } + else { # there is no timeout + return ('', undef); + } +} # end sub _timeout_interval + + +sub _unpack_sockaddr { + my ($self, $sockaddr) = @_; + my ( + $packed_addr, + $sockfamily, + ); + my $addr = ""; + my $port = ""; + + $sockfamily = $self->sockfamily; + + ## Parse sockaddr struct. + if ($sockfamily eq "ipv4") { + ($port, $packed_addr) = sockaddr_in($sockaddr); + $addr = Socket::inet_ntoa($packed_addr); + } + elsif ($sockfamily eq "ipv6") { + ($port, $packed_addr) = Socket::sockaddr_in6($sockaddr); + $addr = Socket::inet_ntop($AF_INET6, $packed_addr); + } + + ($port, $addr); +} # end sub _unpack_sockaddr + + +sub _user_caller { + my ($obj) = @_; + my ( + $class, + $curr_pkg, + $file, + $i, + $line, + $pkg, + %isa, + @isa, + ); + local $@; + local $_; + + ## Create a boolean hash to test for isa. Make sure current + ## package and the object's class are members. + $class = ref $obj; + @isa = eval "\@${class}::ISA"; + push @isa, $class; + ($curr_pkg) = caller 1; + push @isa, $curr_pkg; + %isa = map { $_ => 1 } @isa; + + ## Search back in call frames for a package that's not in isa. + $i = 1; + while (($pkg, $file, $line) = caller ++$i) { + next if $isa{$pkg}; + + return ($pkg, $file, $line); + } + + ## If not found, choose outer most call frame. + ($pkg, $file, $line) = caller --$i; + return ($pkg, $file, $line); +} # end sub _user_caller + + +sub _verify_telopt_arg { + my ($self, $option, $argname) = @_; + local $@; + + ## If provided, use argument name in error message. + if (defined $argname) { + $argname = "for arg $argname"; + } + else { + $argname = ""; + } + + ## Ensure telnet option is a non-negative integer. + eval { + local $SIG{"__DIE__"} = "DEFAULT"; + local $SIG{"__WARN__"} = sub { die "non-numeric\n" }; + local $^W = 1; + $option = abs(int $option); + }; + return $self->error("bad telnet option $argname: non-numeric") + if $@; + + return $self->error("bad telnet option $argname: option > 255") + unless $option <= 255; + + $option; +} # end sub _verify_telopt_arg + + +######################## Exported Constants ########################## + + +sub TELNET_IAC () {255}; # interpret as command: +sub TELNET_DONT () {254}; # you are not to use option +sub TELNET_DO () {253}; # please, you use option +sub TELNET_WONT () {252}; # I won't use option +sub TELNET_WILL () {251}; # I will use option +sub TELNET_SB () {250}; # interpret as subnegotiation +sub TELNET_GA () {249}; # you may reverse the line +sub TELNET_EL () {248}; # erase the current line +sub TELNET_EC () {247}; # erase the current character +sub TELNET_AYT () {246}; # are you there +sub TELNET_AO () {245}; # abort output--but let prog finish +sub TELNET_IP () {244}; # interrupt process--permanently +sub TELNET_BREAK () {243}; # break +sub TELNET_DM () {242}; # data mark--for connect. cleaning +sub TELNET_NOP () {241}; # nop +sub TELNET_SE () {240}; # end sub negotiation +sub TELNET_EOR () {239}; # end of record (transparent mode) +sub TELNET_ABORT () {238}; # Abort process +sub TELNET_SUSP () {237}; # Suspend process +sub TELNET_EOF () {236}; # End of file +sub TELNET_SYNCH () {242}; # for telfunc calls + +sub TELOPT_BINARY () {0}; # Binary Transmission +sub TELOPT_ECHO () {1}; # Echo +sub TELOPT_RCP () {2}; # Reconnection +sub TELOPT_SGA () {3}; # Suppress Go Ahead +sub TELOPT_NAMS () {4}; # Approx Message Size Negotiation +sub TELOPT_STATUS () {5}; # Status +sub TELOPT_TM () {6}; # Timing Mark +sub TELOPT_RCTE () {7}; # Remote Controlled Trans and Echo +sub TELOPT_NAOL () {8}; # Output Line Width +sub TELOPT_NAOP () {9}; # Output Page Size +sub TELOPT_NAOCRD () {10}; # Output Carriage-Return Disposition +sub TELOPT_NAOHTS () {11}; # Output Horizontal Tab Stops +sub TELOPT_NAOHTD () {12}; # Output Horizontal Tab Disposition +sub TELOPT_NAOFFD () {13}; # Output Formfeed Disposition +sub TELOPT_NAOVTS () {14}; # Output Vertical Tabstops +sub TELOPT_NAOVTD () {15}; # Output Vertical Tab Disposition +sub TELOPT_NAOLFD () {16}; # Output Linefeed Disposition +sub TELOPT_XASCII () {17}; # Extended ASCII +sub TELOPT_LOGOUT () {18}; # Logout +sub TELOPT_BM () {19}; # Byte Macro +sub TELOPT_DET () {20}; # Data Entry Terminal +sub TELOPT_SUPDUP () {21}; # SUPDUP +sub TELOPT_SUPDUPOUTPUT () {22}; # SUPDUP Output +sub TELOPT_SNDLOC () {23}; # Send Location +sub TELOPT_TTYPE () {24}; # Terminal Type +sub TELOPT_EOR () {25}; # End of Record +sub TELOPT_TUID () {26}; # TACACS User Identification +sub TELOPT_OUTMRK () {27}; # Output Marking +sub TELOPT_TTYLOC () {28}; # Terminal Location Number +sub TELOPT_3270REGIME () {29}; # Telnet 3270 Regime +sub TELOPT_X3PAD () {30}; # X.3 PAD +sub TELOPT_NAWS () {31}; # Negotiate About Window Size +sub TELOPT_TSPEED () {32}; # Terminal Speed +sub TELOPT_LFLOW () {33}; # Remote Flow Control +sub TELOPT_LINEMODE () {34}; # Linemode +sub TELOPT_XDISPLOC () {35}; # X Display Location +sub TELOPT_OLD_ENVIRON () {36}; # Environment Option +sub TELOPT_AUTHENTICATION () {37}; # Authentication Option +sub TELOPT_ENCRYPT () {38}; # Encryption Option +sub TELOPT_NEW_ENVIRON () {39}; # New Environment Option +sub TELOPT_TN3270E () {40}; # TN3270 Enhancements +sub TELOPT_CHARSET () {42}; # CHARSET Option +sub TELOPT_COMPORT () {44}; # Com Port Control Option +sub TELOPT_KERMIT () {47}; # Kermit Option +sub TELOPT_EXOPL () {255}; # Extended-Options-List + + +1; +__END__; + + +######################## User Documentation ########################## + + +## To format the following documentation into a more readable format, +## use one of these programs: perldoc; pod2man; pod2html; pod2text. +## For example, to nicely format this documentation for printing, you +## may use pod2man and groff to convert to postscript: +## pod2man Net/Telnet.pm | groff -man -Tps > Net::Telnet.ps + +=head1 NAME + +Net::Telnet - interact with TELNET port or other TCP ports + +=head1 SYNOPSIS + +C + +see METHODS or EXAMPLES sections below + +=head1 DESCRIPTION + +Net::Telnet allows you to make client connections to a TCP port and do +network I/O, especially to a port using the TELNET protocol. Simple +I/O methods such as print, get, and getline are provided. More +sophisticated interactive features are provided because connecting to +a TELNET port ultimately means communicating with a program designed +for human interaction. These interactive features include the ability +to specify a time-out and to wait for patterns to appear in the input +stream, such as the prompt from a shell. IPv6 support is available +when using perl 5.14 or later (see C. + +Other reasons to use this module than strictly with a TELNET port are: + +=over 2 + +=item * + +You're not familiar with sockets and you want a simple way to make +client connections to TCP services. + +=item * + +You want to be able to specify your own time-out while connecting, +reading, or writing. + +=item * + +You're communicating with an interactive program at the other end of +some socket or pipe and you want to wait for certain patterns to +appear. + +=back + +Here's an example that prints who's logged-on to a remote host. In +addition to a username and password, you must also know the user's +shell prompt, which for this example is C<"bash$ "> + + use Net::Telnet (); + $t = new Net::Telnet (Timeout => 10, + Prompt => '/bash\$ $/'); + $t->open($host); + $t->login($username, $passwd); + @lines = $t->cmd("who"); + print @lines; + +See the B section below for more examples. + +Usage questions should be directed to the perlmonks.org discussion +group. Bugs can be viewed or reported at cpan.org on the Net::Telnet +page. + +=head2 What To Know Before Using + +=over 2 + +=item * + +All output is flushed while all input is buffered. Each object +contains its own input buffer. + +=item * + +The output record separator for C and C is set to +C<"\n"> by default, so that you don't have to append all your commands +with a newline. To avoid printing a trailing C<"\n"> use C or +set the I to C<"">. + +=item * + +The methods C and C use the I setting in the +object to determine when a login or remote command is complete. Those +methods will fail with a time-out if you don't set the prompt +correctly. + +=item * + +Use a combination of C and C as an alternative to +C or C when they don't do what you want. + +=item * + +Errors such as timing-out are handled according to the error mode +action. The default action is to print an error message to standard +error and have the program die. See the C method for more +information. + +=item * + +When constructing the match operator argument for C or +C, always use single quotes instead of double quotes to +avoid unexpected backslash interpretation (e.g. C<'/bash\$ $/'>). If +you're constructing a DOS like file path, you'll need to use four +backslashes to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). + +Of course don't forget about regexp metacharacters like C<.>, C<[>, or +C<$>. You'll only need a single backslash to quote them. The anchor +metacharacters C<^> and C<$> refer to positions in the input buffer. +To avoid matching characters read that look like a prompt, it's a good +idea to end your prompt pattern with the C<$> anchor. That way the +prompt will only match if it's the last thing read. + +=item * + +In the input stream, each sequence of I and I (i.e. C<"\015\012"> or CR LF) is converted to C<"\n">. In the +output stream, each occurrence of C<"\n"> is converted to a sequence +of CR LF. See C to change the behavior. TCP protocols +typically use the ASCII sequence, carriage return and line feed to +designate a newline. + +=item * + +Timing-out while making a connection is disabled for machines that +don't support the C function. Most notably these include +MS-Windows machines. + +=item * + +You'll need to be running at least Perl version 5.002 to use this +module. This module does not require any libraries that don't already +come with a standard Perl distribution. + +If you have the IO:: libraries installed (they come standard with +perl5.004 and later) then IO::Socket::INET is used as a base class, +otherwise FileHandle is used. + +=back + +=head2 Debugging + +The typical usage bug causes a time-out error because you've made +incorrect assumptions about what the remote side actually sends. The +easiest way to reconcile what the remote side sends with your +expectations is to use C or C. + +C allows you to see the data being sent from the remote +side before any translation is done, while C shows you +the results after translation. The translation includes converting +end of line characters, removing and responding to TELNET protocol +commands in the data stream. + +=head2 Style of Named Parameters + +Two different styles of named parameters are supported. This document +only shows the IO:: style: + + Net::Telnet->new(Timeout => 20); + +however the dash-option style is also allowed: + + Net::Telnet->new(-timeout => 20); + +=head2 Connecting to a Remote MS-Windows Machine + +By default MS-Windows doesn't come with a TELNET server. However +third party TELNET servers are available. Unfortunately many of these +servers falsely claim to be a TELNET server. This is especially true +of the so-called "Microsoft Telnet Server" that comes installed with +some newer versions MS-Windows. + +When a TELNET server first accepts a connection, it must use the ASCII +control characters carriage-return and line-feed to start a new line +(see RFC854). A server like the "Microsoft Telnet Server" that +doesn't do this, isn't a TELNET server. These servers send ANSI +terminal escape sequences to position to a column on a subsequent line +and to even position while writing characters that are adjacent to +each other. Worse, when sending output these servers resend +previously sent command output in a misguided attempt to display an +entire terminal screen. + +Connecting Net::Telnet to one of these false TELNET servers makes your +job of parsing command output very difficult. It's better to replace +a false TELNET server with a real TELNET server. The better TELNET +servers for MS-Windows allow you to avoid the ANSI escapes by turning +off something some of them call I. + + +=head1 METHODS + +In the calling sequences below, square brackets B<[]> represent +optional parameters. + +=over 4 + +=item B - create a new Net::Telnet object + + $obj = new Net::Telnet ([$host]); + + $obj = new Net::Telnet ([Binmode => $mode,] + [Cmd_remove_mode => $mode,] + [Dump_Log => $filename,] + [Errmode => $errmode,] + [Family => $family,] + [Fhopen => $filehandle,] + [Host => $host,] + [Input_log => $file,] + [Input_record_separator => $chars,] + [Localfamily => $family,] + [Localhost => $host,] + [Max_buffer_length => $len,] + [Ofs => $chars,] + [Option_log => $file,] + [Ors => $chars,] + [Output_field_separator => $chars,] + [Output_log => $file,] + [Output_record_separator => $chars,] + [Port => $port,] + [Prompt => $matchop,] + [Rs => $chars,] + [Telnetmode => $mode,] + [Timeout => $secs,]); + +This is the constructor for Net::Telnet objects. A new object is +returned on success, the error mode action is performed on failure - +see C. The optional arguments are short-cuts to methods of +the same name. + +If the I<$host> argument is given then the object is opened by +connecting to TCP I<$port> on I<$host>. Also see C. The new +object returned is given the following defaults in the absence of +corresponding named parameters: + +=over 4 + +=item + +The default I is C<"localhost"> + +=item + +The default I is C<23> + +=item + +The default I is C<"ipv4"> + +=item + +The default I is C<'/[\$%#E] $/'> + +=item + +The default I is C<10> + +=item + +The default I is C<"die"> + +=item + +The default I is C<"\n">. Note that I +is synonymous with I. + +=item + +The default I is C<"\n">. Note that I is +synonymous with I. + +=item + +The default I is C<0>, which means do newline translation. + +=item + +The default I is C<1>, which means respond to TELNET +commands in the data stream. + +=item + +The default I is C<"auto"> + +=item + +The defaults for I, I, I, and +I are C<"">, which means that logging is turned-off. + +=item + +The default I is C<1048576> bytes, i.e. 1 MiB. + +=item + +The default I is C<"">. Note that I +is synonymous with I. + +=item + +The default I is C<""> + +=item + +The default I is C<"ipv4"> + +=back + +=back + + +=over 4 + +=item B - toggle newline translation + + $mode = $obj->binmode; + + $prev = $obj->binmode($mode); + +This method controls whether or not sequences of carriage returns and +line feeds (CR LF or more specifically C<"\015\012">) are translated. +By default they are translated (i.e. binmode is C<0>). + +If no argument is given, the current mode is returned. + +If I<$mode> is C<1> then binmode is I and newline translation is +not done. + +If I<$mode> is C<0> then binmode is I and newline translation is +done. In the input stream, each sequence of CR LF is converted to +C<"\n"> and in the output stream, each occurrence of C<"\n"> is +converted to a sequence of CR LF. + +Note that input is always buffered. Changing binmode doesn't effect +what's already been read into the buffer. Output is not buffered and +changing binmode will have an immediate effect. + +=back + + +=over 4 + +=item B - send TELNET break character + + $ok = $obj->break; + +This method sends the TELNET break character. This character is +provided because it's a signal outside the ASCII character set which +is currently given local meaning within many systems. It's intended +to indicate that the Break Key or the Attention Key was hit. + +This method returns C<1> on success, or performs the error mode action +on failure. + +=back + + +=over 4 + +=item B - scalar reference to object's input buffer + + $ref = $obj->buffer; + +This method returns a scalar reference to the input buffer for +I<$obj>. Data in the input buffer is data that has been read from the +remote side but has yet to be read by the user. Modifications to the +input buffer are returned by a subsequent read. + +=back + + +=over 4 + +=item B - discard all data in object's input buffer + + $obj->buffer_empty; + +This method removes all data in the input buffer for I<$obj>. + +=back + + +=over 4 + +=item B - close object + + $ok = $obj->close; + +This method closes the socket, file, or pipe associated with the +object. It always returns a value of C<1>. + +=back + + +=over 4 + +=item B - issue command and retrieve output + + $ok = $obj->cmd($string); + $ok = $obj->cmd(String => $string, + [Output => $ref,] + [Cmd_remove_mode => $mode,] + [Errmode => $mode,] + [Input_record_separator => $chars,] + [Ors => $chars,] + [Output_record_separator => $chars,] + [Prompt => $match,] + [Rs => $chars,] + [Timeout => $secs,]); + + @output = $obj->cmd($string); + @output = $obj->cmd(String => $string, + [Output => $ref,] + [Cmd_remove_mode => $mode,] + [Errmode => $mode,] + [Input_record_separator => $chars,] + [Ors => $chars,] + [Output_record_separator => $chars,] + [Prompt => $match,] + [Rs => $chars,] + [Timeout => $secs,]); + +This method sends the command I<$string>, and reads the characters +sent back by the command up until and including the matching prompt. +It's assumed that the program to which you're sending is some kind of +command prompting interpreter such as a shell. + +The command I<$string> is automatically appended with the +output_record_separator, by default it is C<"\n">. This is similar +to someone typing a command and hitting the return key. Set the +output_record_separator to change this behavior. + +In a scalar context, the characters read from the remote side are +discarded and C<1> is returned on success. On time-out, eof, or other +failures, the error mode action is performed. See C. + +In a list context, just the output generated by the command is +returned, one line per element. In other words, all the characters in +between the echoed back command string and the prompt are returned. +If the command happens to return no output, a list containing one +element, the empty string is returned. This is so the list will +indicate true in a boolean context. On time-out, eof, or other +failures, the error mode action is performed. See C. + +The characters that matched the prompt may be retrieved using +C. + +Many command interpreters echo back the command sent. In most +situations, this method removes the first line returned from the +remote side (i.e. the echoed back command). See C +for more control over this feature. + +Use C to debug when this method keeps timing-out and you +don't think it should. + +Consider using a combination of C and C as an +alternative to this method when it doesn't do what you want, e.g. the +command you send prompts for input. + +The I named parameter provides an alternative method of +receiving command output. If you pass a scalar reference, all the +output (even if it contains multiple lines) is returned in the +referenced scalar. If you pass an array or hash reference, the lines +of output are returned in the referenced array or hash. You can use +C to change the notion of what separates a +line. + +Optional named parameters are provided to override the current +settings of cmd_remove_mode, errmode, input_record_separator, ors, +output_record_separator, prompt, rs, and timeout. Rs is synonymous +with input_record_separator and ors is synonymous with +output_record_separator. + +=back + + +=over 4 + +=item B - toggle removal of echoed commands + + $mode = $obj->cmd_remove_mode; + + $prev = $obj->cmd_remove_mode($mode); + +This method controls how to deal with echoed back commands in the +output returned by cmd(). Typically, when you send a command to the +remote side, the first line of output returned is the command echoed +back. Use this mode to remove the first line of output normally +returned by cmd(). + +If no argument is given, the current mode is returned. + +If I<$mode> is C<0> then the command output returned from cmd() has no +lines removed. If I<$mode> is a positive integer, then the first +I<$mode> lines of command output are stripped. + +By default, I<$mode> is set to C<"auto">. Auto means that whether or +not the first line of command output is stripped, depends on whether +or not the remote side offered to echo. By default, Net::Telnet +always accepts an offer to echo by the remote side. You can change +the default to reject such an offer using C. + +A warning is printed to STDERR when attempting to set this attribute +to something that is not C<"auto"> or a non-negative integer. + +=back + + +=over 4 + +=item B - log all I/O in dump format + + $fh = $obj->dump_log; + + $fh = $obj->dump_log($fh); + + $fh = $obj->dump_log($filename); + +This method starts or stops dump format logging of all the object's +input and output. The dump format shows the blocks read and written +in a hexadecimal and printable character format. This method is +useful when debugging, however you might want to first try +C as it's more readable. + +If no argument is given, the log filehandle is returned. A returned +empty string indicates logging is off. + +To stop logging, use an empty string as an argument. The stopped +filehandle is not closed. + +If an open filehandle is given, it is used for logging and returned. +Otherwise, the argument is assumed to be the name of a file, the +filename is opened for logging and a filehandle to it is returned. If +the filehandle is not already opened or the filename can't be opened +for writing, the error mode action is performed. + +=back + + +=over 4 + +=item B - end of file indicator + + $eof = $obj->eof; + +This method returns C<1> if end of file has been read, otherwise it +returns an empty string. Because the input is buffered this isn't the +same thing as I<$obj> has closed. In other words I<$obj> can be +closed but there still can be stuff in the buffer to be read. Under +this condition you can still read but you won't be able to write. + +=back + + +=over 4 + +=item B - define action to be performed on error + + $mode = $obj->errmode; + + $prev = $obj->errmode($mode); + +This method gets or sets the action used when errors are encountered +using the object. The first calling sequence returns the current +error mode. The second calling sequence sets it to I<$mode> and +returns the previous mode. Valid values for I<$mode> are C<"die"> +(the default), C<"return">, a I, or an I. + +When mode is C<"die"> and an error is encountered using the object, +then an error message is printed to standard error and the program +dies. + +When mode is C<"return"> then the method generating the error places +an error message in the object and returns an undefined value in a +scalar context and an empty list in list context. The error message +may be obtained using C. + +When mode is a I, then when an error is encountered +I is called with the error message as its first argument. +Using this mode you may have your own subroutine handle errors. If +I itself returns then the method generating the error returns +undefined or an empty list depending on context. + +When mode is an I, the first element of the array must be a +I. Any elements that follow are the arguments to I. +When an error is encountered, the I is called with its +arguments. Using this mode you may have your own subroutine handle +errors. If the I itself returns then the method generating +the error returns undefined or an empty list depending on context. + +A warning is printed to STDERR when attempting to set this attribute +to something that is not C<"die">, C<"return">, a I, or an +I whose first element isn't a I. + +=back + + +=over 4 + +=item B - most recent error message + + $msg = $obj->errmsg; + + $prev = $obj->errmsg(@msgs); + +The first calling sequence returns the error message associated with +the object. The empty string is returned if no error has been +encountered yet. The second calling sequence sets the error message +for the object to the concatenation of I<@msgs> and returns the +previous error message. Normally, error messages are set internally +by a method when an error is encountered. + +=back + + +=over 4 + +=item B - perform the error mode action + + $obj->error(@msgs); + +This method concatenates I<@msgs> into a string and places it in the +object as the error message. Also see C. It then performs +the error mode action. Also see C. + +If the error mode doesn't cause the program to die, then an undefined +value or an empty list is returned depending on the context. + +This method is primarily used by this class or a sub-class to perform +the user requested action when an error is encountered. + +=back + + +=over 4 + +=item B - IP address family for remote host + + $family = $obj->family; + + $prev = $obj->family($family); + +This method designates which IP address family C refers to, +i.e. IPv4 or IPv6. IPv6 support is available when using perl 5.14 or +later. With no argument it returns the current value set in the +object. With an argument it sets the current address family to +I<$family> and returns the previous address family. Valid values are +C<"ipv4">, C<"ipv6">, or C<"any">. When C<"any">, the C can +be a hostname or IP address for either IPv4 or IPv6. After +connecting, you can use C to determine which IP address +family was used. + +The default value is C<"ipv4">. + +The error mode action is performed when attempting to set this +attribute to something that isn't C<"ipv4">, C<"ipv6">, or C<"any">. +It is also performed when attempting to set it to C<"ipv6"> when the +Socket module is less than version 1.94 or IPv6 is not supported in +the OS as indicated by Socket::AF_INET6 not being defined. + +=back + + +=over 4 + +=item B - use already open filehandle for I/O + + $ok = $obj->fhopen($fh); + +This method associates the open filehandle I<$fh> with I<$obj> for +further I/O. Filehandle I<$fh> must already be opened. + +Suppose you want to use the features of this module to do I/O to +something other than a TCP port, for example STDIN or a filehandle +opened to read from a process. Instead of opening the object for I/O +to a TCP port by using C or C, call this method +instead. + +The value C<1> is returned success, the error mode action is performed +on failure. + +=back + + +=over 4 + +=item B - read block of data + + $data = $obj->get([Binmode => $mode,] + [Errmode => $errmode,] + [Telnetmode => $mode,] + [Timeout => $secs,]); + +This method reads a block of data from the object and returns it along +with any buffered data. If no buffered data is available to return, +it will wait for data to read using the timeout specified in the +object. You can override that timeout using I<$secs>. Also see +C. If buffered data is available to return, it also checks +for a block of data that can be immediately read. + +On eof an undefined value is returned. On time-out or other failures, +the error mode action is performed. To distinguish between eof or an +error occurring when the error mode is not set to C<"die">, use +C. + +Optional named parameters are provided to override the current +settings of binmode, errmode, telnetmode, and timeout. + +=back + + +=over 4 + +=item B - read next line + + $line = $obj->getline([Binmode => $mode,] + [Errmode => $errmode,] + [Input_record_separator => $chars,] + [Rs => $chars,] + [Telnetmode => $mode,] + [Timeout => $secs,]); + +This method reads and returns the next line of data from the object. +You can use C to change the notion of what +separates a line. The default is C<"\n">. If a line isn't +immediately available, this method blocks waiting for a line or a +time-out. + +On eof an undefined value is returned. On time-out or other failures, +the error mode action is performed. To distinguish between eof or an +error occurring when the error mode is not set to C<"die">, use +C. + +Optional named parameters are provided to override the current +settings of binmode, errmode, input_record_separator, rs, telnetmode, +and timeout. Rs is synonymous with input_record_separator. + +=back + + +=over 4 + +=item B - read next lines + + @lines = $obj->getlines([Binmode => $mode,] + [Errmode => $errmode,] + [Input_record_separator => $chars,] + [Rs => $chars,] + [Telnetmode => $mode,] + [Timeout => $secs,] + [All => $boolean,]); + +This method reads and returns all the lines of data from the object +until end of file is read. You can use C to +change the notion of what separates a line. The default is C<"\n">. +A time-out error occurs if all the lines can't be read within the +time-out interval. See C. + +The behavior of this method was changed in version 3.03. Prior to +version 3.03 this method returned just the lines available from the +next read. To get that old behavior, use the optional named parameter +I and set I<$boolean> to C<""> or C<0>. + +If only eof is read then an empty list is returned. On time-out or +other failures, the error mode action is performed. Use C to +distinguish between reading only eof or an error occurring when the +error mode is not set to C<"die">. + +Optional named parameters are provided to override the current +settings of binmode, errmode, input_record_separator, rs, telnetmode, +and timeout. Rs is synonymous with input_record_separator. + +=back + + +=over 4 + +=item B - name or IP address of remote host + + $host = $obj->host; + + $prev = $obj->host($host); + +This method designates the remote host for C. It is either a +hostname or an IP address. With no argument it returns the current +value set in the object. With an argument it sets the current host +name to I<$host> and returns the previous value. Use C to +control which IP address family, IPv4 or IPv6, host refers to. + +The default value is C<"localhost">. It may also be set by C +or C. + +=back + + +=over 4 + +=item B - log all input + + $fh = $obj->input_log; + + $fh = $obj->input_log($fh); + + $fh = $obj->input_log($filename); + +This method starts or stops logging of input. This is useful when +debugging. Also see C. Because most command interpreters +echo back commands received, it's likely all your output will also be +in this log. Note that input logging occurs after newline +translation. See C for details on newline translation. + +If no argument is given, the log filehandle is returned. A returned +empty string indicates logging is off. + +To stop logging, use an empty string as an argument. The stopped +filehandle is not closed. + +If an open filehandle is given, it is used for logging and returned. +Otherwise, the argument is assumed to be the name of a file, the +filename is opened for logging and a filehandle to it is returned. If +the filehandle is not already opened or the filename can't be opened +for writing, the error mode action is performed. + +=back + + +=over 4 + +=item B - input line delimiter + + $chars = $obj->input_record_separator; + + $prev = $obj->input_record_separator($chars); + +This method designates the line delimiter for input. It's used with +C, C, and C to determine lines in the +input. + +With no argument this method returns the current input record +separator set in the object. With an argument it sets the input +record separator to I<$chars> and returns the previous value. Note +that I<$chars> must have length. + +A warning is printed to STDERR when attempting to set this attribute +to a string with no length. + +=back + + +=over 4 + +=item B - last prompt read + + $string = $obj->last_prompt; + + $prev = $obj->last_prompt($string); + +With no argument this method returns the last prompt read by cmd() or +login(). See C. With an argument it sets the last prompt +read to I<$string> and returns the previous value. Normally, only +internal methods set the last prompt. + +=back + + +=over 4 + +=item B - last line read + + $line = $obj->lastline; + + $prev = $obj->lastline($line); + +This method retrieves the last line read from the object. This may be +a useful error message when the remote side abnormally closes the +connection. Typically the remote side will print an error message +before closing. + +With no argument this method returns the last line read from the +object. With an argument it sets the last line read to I<$line> and +returns the previous value. Normally, only internal methods set the +last line. + +=back + + +=over 4 + +=item B - IP address family for local host + + $localfamily = $obj->localfamily; + + $prev = $obj->localfamily($family); + +This method designates which IP address family C refers +to, i.e. IPv4 or IPv6. IPv6 support is available when using perl 5.14 +or later. With no argument it returns the current value set in the +object. With an argument it sets the current local address family to +I<$family> and returns the previous address family. Valid values +are C<"ipv4">, C<"ipv6">, or C<"any">. When C<"any">, the +C can be a hostname or IP address for either IPv4 or +IPv6. + +The default value is C<"ipv4">. + +The error mode action is performed when attempting to set this +attribute to something that isn't C<"ipv4">, C<"ipv6">, or C<"any">. +It is also performed when attempting to set it to C<"ipv6"> when the +Socket module is less than version 1.94 or IPv6 is not supported in +the OS as indicated by Socket::AF_INET6 not being defined. + +=back + + +=over 4 + +=item B - bind local socket to a specific network interface + + $localhost = $obj->localhost; + + $prev = $obj->localhost($host); + +This method designates the local socket IP address for C. It +is either a hostname, an IP address, or a null string (i.e. C<"">). A +null string disables this feature. + +Normally the OS picks which local network interface to use. This +method is useful when the local machine has more than one network +interface and you want to bind to a specific one. With no argument it +returns the current value set in the object. With an argument it sets +the current local host name to I<$host> and returns the previous +value. Use C to control which IP address family, IPv4 +or IPv6, local host refers to. + +The default value is C<"">. + +=back + + +=over 4 + +=item B - perform standard login + + $ok = $obj->login($username, $password); + + $ok = $obj->login(Name => $username, + Password => $password, + [Errmode => $mode,] + [Prompt => $match,] + [Timeout => $secs,]); + +This method performs a standard login by waiting for a login prompt +and responding with I<$username>, then waiting for the password prompt +and responding with I<$password>, and then waiting for the command +interpreter prompt. If any of those prompts sent by the remote side +don't match what's expected, this method will time-out, unless timeout +is turned off. + +Login prompt must match either of these case insensitive patterns: + + /login[: ]*$/i + /username[: ]*$/i + +Password prompt must match this case insensitive pattern: + + /password[: ]*$/i + +The command interpreter prompt must match the current setting of +prompt. See C. + +Use C to debug when this method keeps timing-out and you +don't think it should. + +Consider using a combination of C and C as an +alternative to this method when it doesn't do what you want, e.g. the +remote host doesn't prompt for a username. + +On success, C<1> is returned. On time out, eof, or other failures, +the error mode action is performed. See C. + +Optional named parameters are provided to override the current +settings of errmode, prompt, and timeout. + +=back + + +=over 4 + +=item B - maximum size of input buffer + + $len = $obj->max_buffer_length; + + $prev = $obj->max_buffer_length($len); + +This method designates the maximum size of the input buffer. An error +is generated when a read causes the buffer to exceed this limit. The +default value is 1,048,576 bytes (1 MiB). The input buffer can grow +much larger than the block size when you continuously read using +C or C and the data stream contains no newlines +or matching waitfor patterns. + +With no argument, this method returns the current maximum buffer +length set in the object. With an argument it sets the maximum buffer +length to I<$len> and returns the previous value. Values of I<$len> +smaller than 512 will be adjusted to 512. + +A warning is printed to STDERR when attempting to set this attribute +to something that isn't a positive integer. + +=back + + +=over 4 + +=item B - field separator for print + + $chars = $obj->ofs + + $prev = $obj->ofs($chars); + +This method is synonymous with C. + +=back + + +=over 4 + +=item B - connect to port on remote host + + $ok = $obj->open($host); + + $ok = $obj->open([Host => $host,] + [Port => $port,] + [Family => $family,] + [Errmode => $mode,] + [Timeout => $secs,] + [Localhost => $host,] + [Localfamily => $family,]); + +This method opens a TCP connection to I<$port> on I<$host> for the IP +address I<$family>. If any of those arguments are missing then the +current attribute value for the object is used. Specifing I +sets that attribute for the object. Specifing any of the other +optional named parameters overrides the current setting. + +The default IP address family is C<"ipv4">. I<$family> may be set to +C<"ipv4">, C<"ipv6">, or C<"any">. See C for more details. + +I is used to bind to a specific local network interface. + +If the object is already open, it is closed before attempting a +connection. + +On success C<1> is returned. On time-out or other connection +failures, the error mode action is performed. See C. + +Time-outs don't work for this method on machines that don't implement +SIGALRM - most notably MS-Windows machines. For those machines, an +error is returned when the system reaches its own time-out while +trying to connect. + +A side effect of this method is to reset the alarm interval associated +with SIGALRM. + +=back + + +=over 4 + +=item B - indicate willingness to accept a TELNET option + + $fh = $obj->option_accept([Do => $telopt,] + [Dont => $telopt,] + [Will => $telopt,] + [Wont => $telopt,]); + +This method is used to indicate whether to accept or reject an offer +to enable a TELNET option made by the remote side. If you're using +I or I to indicate a willingness to enable, then a +notification callback must have already been defined by a prior call +to C. See C for details on +receiving enable/disable notification of a TELNET option. + +You can give multiple I, I, I, or I arguments +for different TELNET options in the same call to this method. + +The following example describes the meaning of the named parameters. +A TELNET option, such as C used below, is an integer +constant that you can import from Net::Telnet. See the source in file +Telnet.pm for the complete list. + +=over 4 + +=item + +I => C + +=over 4 + +=item + +we'll accept an offer to enable the echo option on the local side + +=back + +=item + +I => C + +=over 4 + +=item + +we'll reject an offer to enable the echo option on the local side + +=back + +=item + +I => C + +=over 4 + +=item + +we'll accept an offer to enable the echo option on the remote side + +=back + +=item + +I => C + +=over 4 + +=item + +we'll reject an offer to enable the echo option on the remote side + +=back + +=back + +=item + +Use C to send a request to the remote side to enable or +disable a particular TELNET option. + +=back + + +=over 4 + +=item B - define the option negotiation callback + + $coderef = $obj->option_callback; + + $prev = $obj->option_callback($coderef); + +This method defines the callback subroutine that is called when a +TELNET option is enabled or disabled. Once defined, the +I may not be undefined. However, calling this method +with a different I<$coderef> changes it. + +A warning is printed to STDERR when attempting to set this attribute +to something that isn't a coderef. + +Here are the circumstances that invoke I<$coderef>: + +=over 4 + +=item + +An option becomes enabled because the remote side requested an enable +and C had been used to arrange that it be accepted. + +=item + +The remote side arbitrarily decides to disable an option that is +currently enabled. Note that Net::Telnet always accepts a request to +disable from the remote side. + +=item + +C was used to send a request to enable or disable an +option and the response from the remote side has just been received. +Note, that if a request to enable is rejected then I<$coderef> is +still invoked even though the option didn't change. + +=back + +=item + +Here are the arguments passed to I<&$coderef>: + + &$coderef($obj, $option, $is_remote, + $is_enabled, $was_enabled, $buf_position); + +=over 4 + +=item + +1. I<$obj> is the Net::Telnet object + +=item + +2. I<$option> is the TELNET option. Net::Telnet exports constants +for the various TELNET options which just equate to an integer. + +=item + +3. I<$is_remote> is a boolean indicating for which side the option +applies. + +=item + +4. I<$is_enabled> is a boolean indicating the option is enabled or +disabled + +=item + +5. I<$was_enabled> is a boolean indicating the option was previously +enabled or disabled + +=item + +6. I<$buf_position> is an integer indicating the position in the +object's input buffer where the option takes effect. See C +to access the object's input buffer. + +=back + +=back + + +=over 4 + +=item B - log all TELNET options sent or received + + $fh = $obj->option_log; + + $fh = $obj->option_log($fh); + + $fh = $obj->option_log($filename); + +This method starts or stops logging of all TELNET options being sent +or received. This is useful for debugging when you send options via +C or you arrange to accept option requests from the +remote side via C. Also see C. + +If no argument is given, the log filehandle is returned. An empty +string indicates logging is off. + +To stop logging, use an empty string as an argument. The stopped +filehandle is not closed. + +If an open filehandle is given, it is used for logging and returned. +Otherwise, the argument is assumed to be the name of a file, the +filename is opened for logging and a filehandle to it is returned. If +the filehandle is not already opened or the filename can't be opened +for writing, the error mode action is performed. + +=back + + +=over 4 + +=item B - send TELNET option negotiation request + + $ok = $obj->option_send([Do => $telopt,] + [Dont => $telopt,] + [Will => $telopt,] + [Wont => $telopt,] + [Async => $boolean,]); + +This method is not yet implemented. Look for it in a future version. + +=back + + +=over 4 + +=item B - get current state of a TELNET option + + $hashref = $obj->option_state($telopt); + +This method returns a hashref containing a copy of the current state +of TELNET option I<$telopt>. + +Here are the values returned in the hash: + +=over 4 + +=item + +I<$hashref>->{remote_enabled} + +=over 4 + +=item + +boolean that indicates if the option is enabled on the remote side. + +=back + +=item + +I<$hashref>->{remote_enable_ok} + +=over 4 + +=item + +boolean that indicates if it's ok to accept an offer to enable this +option on the remote side. + +=back + +=item + +I<$hashref>->{remote_state} + +=over 4 + +=item + +string used to hold the internal state of option negotiation for this +option on the remote side. + +=back + +=item + +I<$hashref>->{local_enabled} + +=over 4 + +=item + +boolean that indicates if the option is enabled on the local side. + +=back + +=item + +I<$hashref>->{local_enable_ok} + +=over 4 + +=item + +boolean that indicates if it's ok to accept an offer to enable this +option on the local side. + +=back + +=item + +I<$hashref>->{local_state} + +=over 4 + +=item + +string used to hold the internal state of option negotiation for this +option on the local side. + +=back + +=back + +=back + + +=over 4 + +=item B - output line delimiter + + $chars = $obj->ors; + + $prev = $obj->ors($chars); + +This method is synonymous with C. + +=back + + +=over 4 + +=item B - field separator for print + + $chars = $obj->output_field_separator; + + $prev = $obj->output_field_separator($chars); + +This method designates the output field separator for C. +Ordinarily the print method simply prints out the comma separated +fields you specify. Set this to specify what's printed between +fields. + +With no argument this method returns the current output field +separator set in the object. With an argument it sets the output +field separator to I<$chars> and returns the previous value. + +By default it's set to an empty string. + +=back + + +=over 4 + +=item B - log all output + + $fh = $obj->output_log; + + $fh = $obj->output_log($fh); + + $fh = $obj->output_log($filename); + +This method starts or stops logging of output. This is useful when +debugging. Also see C. Because most command interpreters +echo back commands received, it's likely all your output would also be +in an input log. See C. Note that output logging occurs +before newline translation. See C for details on newline +translation. + +If no argument is given, the log filehandle is returned. A returned +empty string indicates logging is off. + +To stop logging, use an empty string as an argument. The stopped +filehandle is not closed. + +If an open filehandle is given, it is used for logging and returned. +Otherwise, the argument is assumed to be the name of a file, the +filename is opened for logging and a filehandle to it is returned. If +the filehandle is not already opened or the filename can't be opened +for writing, the error mode action is performed. + +=back + + +=over 4 + +=item B - output line delimiter + + $chars = $obj->output_record_separator; + + $prev = $obj->output_record_separator($chars); + +This method designates the output line delimiter for C and +C. Set this to specify what's printed at the end of C +and C. + +The output record separator is set to C<"\n"> by default, so there's +no need to append all your commands with a newline. To avoid printing +the output_record_separator use C or set the +output_record_separator to an empty string. + +With no argument this method returns the current output record +separator set in the object. With an argument it sets the output +record separator to I<$chars> and returns the previous value. + +=back + + +=over 4 + +=item B - IP address of the other end of the socket connection + + $ipaddr = $obj->peerhost; + +This method returns a string which is the IPv4 or IPv6 address the +remote socket is bound to (i.e. it is the IP address of C). +It returns C<""> when not connected. + +=back + + +=over 4 + +=item B - TCP port of the other end of the socket connection + + $port = $obj->peerport; + +This method returns the port number which the remote socket is bound +to. It is the same as the C number when connected. It +returns C<""> when not connected. + +=back + + +=over 4 + +=item B - remote port + + $port = $obj->port; + + $prev = $obj->port($port); + +This method designates the remote TCP port for C. With no +argument this method returns the current port number. With an +argument it sets the current port number to I<$port> and returns the +previous port. If I<$port> is a TCP service name, then it's first +converted to a port number using the perl function C. + +The default value is C<23>. + +The error mode action is performed when attempting to set this +attribute to something that is not a positive integer or a valid TCP +service name. + +=back + + +=over 4 + +=item B - write to object + + $ok = $obj->print(@list); + +This method writes I<@list> followed by the I +to the open object and returns C<1> if all data was successfully +written. On time-out or other failures, the error mode action is +performed. See C. + +By default, the C is set to C<"\n"> so all +your commands automatically end with a newline. In most cases your +output is being read by a command interpreter which won't accept a +command until newline is read. This is similar to someone typing a +command and hitting the return key. To avoid printing a trailing +C<"\n"> use C instead or set the output_record_separator to an +empty string. + +On failure, it's possible that some data was written. If you choose +to try and recover from a print timing-out, use C to +determine how much was written before the error occurred. + +You may also use the output field separator to print a string between +the list elements. See C. + +=back + + +=over 4 + +=item B - number of bytes written by print + + $num = $obj->print_length; + +This returns the number of bytes successfully written by the most +recent C or C. + +=back + + +=over 4 + +=item B - pattern to match a prompt + + $matchop = $obj->prompt; + + $prev = $obj->prompt($matchop); + +This method sets the pattern used to find a prompt in the input +stream. It must be a string representing a valid perl pattern match +operator. The methods C and C try to read until +matching the prompt. They will fail with a time-out error if the +pattern you've chosen doesn't match what the remote side sends. + +With no argument this method returns the prompt set in the object. +With an argument it sets the prompt to I<$matchop> and returns the +previous value. + +The default prompt is C<'/[\$%#E] $/'> + +Always use single quotes, instead of double quotes, to construct +I<$matchop> (e.g. C<'/bash\$ $/'>). If you're constructing a DOS like +file path, you'll need to use four backslashes to represent one +(e.g. C<'/c:\\\\users\\\\billE$/i'>). + +Of course don't forget about regexp metacharacters like C<.>, C<[>, or +C<$>. You'll only need a single backslash to quote them. The anchor +metacharacters C<^> and C<$> refer to positions in the input buffer. + +The error mode action is performed when attempting to set this +attribute with a match operator missing its opening delimiter. + +=back + + +=over 4 + +=item B - write to object + + $ok = $obj->put($string); + + $ok = $obj->put(String => $string, + [Binmode => $mode,] + [Errmode => $errmode,] + [Telnetmode => $mode,] + [Timeout => $secs,]); + +This method writes I<$string> to the opened object and returns C<1> if +all data was successfully written. This method is like C +except that it doesn't write the trailing output_record_separator +("\n" by default). On time-out or other failures, the error mode +action is performed. See C. + +On failure, it's possible that some data was written. If you choose +to try and recover from a put timing-out, use C to +determine how much was written before the error occurred. + +Optional named parameters are provided to override the current +settings of binmode, errmode, telnetmode, and timeout. + +=back + + +=over 4 + +=item B - input line delimiter + + $chars = $obj->rs; + + $prev = $obj->rs($chars); + +This method is synonymous with C. + +=back + + +=over 4 + +=item B - IP address family of connected local socket + + $sockfamily = $obj->sockfamily; + +This method returns which IP address family C used to +successfully connect. It is most useful when the requested address +C for C was C<"any">. Values returned may be +C<"ipv4">, C<"ipv6">, or C<""> (when not connected). + +=back + + +=over 4 + +=item B - IP address of this end of the socket connection + + $ipaddr = $obj->sockhost; + +This method returns a string which is the IPv4 or IPv6 address the +local socket is bound to. It returns C<""> when not connected. + +=back + + +=over 4 + +=item B - TCP port of this end of the socket connection + + $port = $obj->sockport; + +This method returns the port number which the local socket is bound +to. It returns C<""> when not connected. + +=back + + +=over 4 + +=item B - turn off/on telnet command interpretation + + $mode = $obj->telnetmode; + + $prev = $obj->telnetmode($mode); + +This method controls whether or not TELNET commands in the data stream +are recognized and handled. The TELNET protocol uses certain +character sequences sent in the data stream to control the session. +If the port you're connecting to isn't using the TELNET protocol, then +you should turn this mode off. The default is I. + +If no argument is given, the current mode is returned. + +If I<$mode> is C<0> then telnet mode is off. If I<$mode> is C<1> then +telnet mode is on. + +=back + + +=over 4 + +=item B - time-out indicator + + $boolean = $obj->timed_out; + + $prev = $obj->timed_out($boolean); + +This method indicates if a previous read, write, or open method +timed-out. Remember that timing-out is itself an error. To be able +to invoke C after a time-out error, you'd have to change +the default error mode to something other than C<"die">. See +C. + +With no argument this method returns C<1> if the previous method +timed-out. With an argument it sets the indicator. Normally, only +internal methods set this indicator. + +=back + + +=over 4 + +=item B - I/O time-out interval + + $secs = $obj->timeout; + + $prev = $obj->timeout($secs); + +This method sets the timeout interval used when performing I/O +or connecting to a port. When a method doesn't complete within the +timeout interval then it's an error and the error mode action is +performed. + +A timeout may be expressed as a relative or absolute value. If +I<$secs> is greater than or equal to the time the program started, as +determined by $^T, then it's an absolute time value for when time-out +occurs. The perl function C may be used to obtain an absolute +time value. For a relative time-out value less than $^T, time-out +happens I<$secs> from when the method begins. + +If I<$secs> is C<0> then time-out occurs if the data cannot be +immediately read or written. Use the undefined value to turn off +timing-out completely. + +With no argument this method returns the timeout set in the object. +With an argument it sets the timeout to I<$secs> and returns the +previous value. The default timeout value is C<10> seconds. + +A warning is printed to STDERR when attempting to set this attribute +to something that is not an C or a non-negative integer. + +=back + + +=over 4 + +=item B - wait for pattern in the input + + $ok = $obj->waitfor($matchop); + $ok = $obj->waitfor([Match => $matchop,] + [String => $string,] + [Binmode => $mode,] + [Errmode => $errmode,] + [Telnetmode => $mode,] + [Timeout => $secs,]); + + ($prematch, $match) = $obj->waitfor($matchop); + ($prematch, $match) = $obj->waitfor([Match => $matchop,] + [String => $string,] + [Binmode => $mode,] + [Errmode => $errmode,] + [Telnetmode => $mode,] + [Timeout => $secs,]); + +This method reads until a pattern match or string is found in the +input stream. All the characters before and including the match are +removed from the input stream. + +In a list context the characters before the match and the matched +characters are returned in I<$prematch> and I<$match>. In a scalar +context, the matched characters and all characters before it are +discarded and C<1> is returned on success. On time-out, eof, or other +failures, for both list and scalar context, the error mode action is +performed. See C. + +You can specify more than one pattern or string by simply providing +multiple I and/or I named parameters. A I<$matchop> +must be a string representing a valid Perl pattern match operator. +The I<$string> is just a substring to find in the input stream. + +Use C to debug when this method keeps timing-out and you +don't think it should. + +An optional named parameter is provided to override the current +setting of timeout. + +To avoid unexpected backslash interpretation, always use single quotes +instead of double quotes to construct a match operator argument for +C and C (e.g. C<'/bash\$ $/'>). If you're +constructing a DOS like file path, you'll need to use four backslashes +to represent one (e.g. C<'/c:\\\\users\\\\billE$/i'>). + +Of course don't forget about regexp metacharacters like C<.>, C<[>, or +C<$>. You'll only need a single backslash to quote them. The anchor +metacharacters C<^> and C<$> refer to positions in the input buffer. + +Optional named parameters are provided to override the current +settings of binmode, errmode, telnetmode, and timeout. + +=back + + +=head1 SEE ALSO + +=over 2 + +=item RFC 854 + +S + +S + +=item RFC 1143 + +S + +S + +=item TELNET Option Assignments + +S + +=back + + +=head1 EXAMPLES + +Setting C to match a user's shell prompt can be tricky. +This example logs in without knowing the shell prompt and then sets it +to match C. It requires /usr/bin/env and /bin/sh on the +remote host. + + my $host = 'your_destination_host_here'; + my $user = 'your_username_here'; + my $passwd = 'your_password_here'; + my ($t, @output); + + ## Create a Net::Telnet object. + use Net::Telnet (); + $t = new Net::Telnet (Timeout => 10); + + ## Connect and login. + $t->open($host); + + $t->waitfor('/login: ?$/i'); + $t->print($user); + + $t->waitfor('/password: ?$/i'); + $t->print($passwd); + + ## Switch to a known shell, using a known prompt. + $t->prompt('/ $/'); + $t->errmode("return"); + + $t->cmd("exec /usr/bin/env 'PS1= ' /bin/sh -i") + or die "login failed to remote host $host"; + + $t->errmode("die"); + + ## Now you can do cmd() to your heart's content. + @output = $t->cmd("uname -a"); + print @output; + + exit; + + +Usually you want the remote TERM environment variable to be +set to something like "dumb" so you don't read escape +sequences meant to be interpreted by a display terminal. It +is best to set it via C, or via C and +C. It is also possible to negotiate the terminal +type via telnet. Here is how to do that. + + ## Module import. + use Net::Telnet qw(TELNET_IAC TELNET_SB TELNET_SE TELOPT_TTYPE); + + ## Global variables. + my $Term; + + ## Main program. + { + my $host = "your_destination_host_here"; + my $user = "your_username_here"; + my $passwd = "your_password_here"; + my $prompt = '/bash\$ $/'; # your regexp for shell prompt here + my $t; + + $t = new Net::Telnet (Prompt => $prompt); + + ## Set up callbacks to negotiate terminal type. + $t->option_callback(sub {}); + $t->suboption_callback(\&subopt_callback); + $t->option_accept(Do => TELOPT_TTYPE); + + ## Login and print value of TERM. + $Term = "dumb"; + $t->open($host); + $t->login($user, $passwd); + print $t->cmd('hostname'); + print "TERM=", $t->cmd('echo $TERM'); + $t->close; + + exit; + } # end main program + + sub subopt_callback { + my ($t, $option, $parameters) = @_; + my $telcmd; + + if ($option == TELOPT_TTYPE) { + $telcmd = pack("C4 A* C2", TELNET_IAC, TELNET_SB, TELOPT_TTYPE, 0, + $Term, TELNET_IAC, TELNET_SE); + $t->put(String => $telcmd, + Telnetmode => 0); + } + + 1; + } # end sub subopt_callback + + +You can also use Net::Telnet to interact with local programs. This +example changes a user's login password. It introduces the C +subroutine to start a program and associate a filehandle with its +standard I/O. Because the passwd program always prompts for passwords +on its controlling terminal, the IO::Pty module is used to create a +new pseudo terminal for use by passwd. The Net::Telnet object reads +and writes to that pseudo terminal. To use the code below, substitute +"changeme" with the actual old and new passwords. + +## Main program. +{ + my ($pty, $passwd); + my $oldpw = "changeme"; + my $newpw = "changeme"; + + ## Start passwd program. + $pty = spawn("passwd"); + + ## Create a Net::Telnet object to perform I/O on passwd's tty. + use Net::Telnet; + $passwd = new Net::Telnet (-fhopen => $pty, + -timeout => 2, + -output_record_separator => "\r", + -telnetmode => 0, + -cmd_remove_mode => 1); + $passwd->errmode("return"); + + ## Send existing password. + $passwd->waitfor('/password: ?$/i') + or die "no old password prompt: ", $passwd->lastline; + $passwd->print($oldpw); + + ## Send new password. + $passwd->waitfor('/new (\w+\s)?password: ?$/i') + or die "bad old password: ", $passwd->lastline; + $passwd->print($newpw); + + ## Send new password verification. + $passwd->waitfor('/new (\w+\s)?password: ?$/i') + or die "bad new password: ", $passwd->lastline; + $passwd->print($newpw); + + ## Display success or failure. + $passwd->waitfor('/(changed|updated)/') + or die "bad new password: ", $passwd->lastline; + print $passwd->lastline; + + $passwd->close; + exit; +} # end main program + +sub spawn { + my (@cmd) = @_; + my ($pid, $pty, $tty, $tty_fd); + + ## Create a new pseudo terminal. + use IO::Pty (); + $pty = new IO::Pty + or die $!; + + ## Execute the program in another process. + unless ($pid = fork) { # child process + die "problem spawning program: $!\n" unless defined $pid; + + ## Disassociate process from its controlling terminal. + use POSIX (); + POSIX::setsid() + or die "setsid failed: $!"; + + ## Associate process with a new controlling terminal. + $pty->make_slave_controlling_terminal; + $tty = $pty->slave; + $tty_fd = $tty->fileno; + close $pty; + + ## Make standard I/O use the new controlling terminal. + open STDIN, "<&$tty_fd" or die $!; + open STDOUT, ">&$tty_fd" or die $!; + open STDERR, ">&STDOUT" or die $!; + close $tty; + + ## Execute requested program. + exec @cmd + or die "problem executing $cmd[0]\n"; + } # end child process + + $pty; +} # end sub spawn + + +Here is an example that uses the openssh program to connect to a +remote host. It uses the C subroutine, from the password +changing example above, to start the ssh program and then read and +write to it via a Net::Telnet object. This example turns off ssh host +key checking, which reduces your ability to know when someone on the +network is impersonating the remote host. To use the code below, +substitute "changeme" with the actual host, user, password, and +command prompt. + + ## Main program. + { + my $host = "changeme"; + my $user = "changeme"; + my $passwd = "changeme"; + my $prompt = '/changeme\$ $/'; + my ($buf, $match, $pty, $ssh, @lines); + + ## Start ssh program. + $pty = spawn("ssh", + "-l", $user, + "-e", "none", + "-F", "/dev/null", + "-o", "PreferredAuthentications=password", + "-o", "NumberOfPasswordPrompts=1", + "-o", "StrictHostKeyChecking=no", + "-o", "UserKnownHostsFile=/dev/null", + $host); + + ## Create a Net::Telnet object to perform I/O on ssh's tty. + use Net::Telnet; + $ssh = new Net::Telnet (-fhopen => $pty, + -prompt => $prompt, + -telnetmode => 0, + -output_record_separator => "\r", + -cmd_remove_mode => 1); + + ## Wait for the password prompt and send password. + $ssh->waitfor(-match => '/password: ?$/i', + -errmode => "return") + or die "problem connecting to \"$host\": ", $ssh->lastline; + $ssh->print($passwd); + + ## Wait for the shell prompt. + (undef, $match) = $ssh->waitfor(-match => $ssh->prompt, + -match => '/^Permission denied/m', + -errmode => "return") + or return $ssh->error("login failed: expected shell prompt ", + "doesn't match actual\n"); + return $ssh->error("login failed: bad login-name or password\n") + if $match =~ /^Permission denied/m; + + ## Run commands on remote host. + print $ssh->cmd("hostname"); + print $ssh->cmd("uptime"); + + $ssh->close; + exit; + } # end main program + + +Some shells have a rather restrictive 255 character line limit. If +you run into this problem, here is an example for sending lines longer +than 254 as a sequence of shorter lines. + + ## Main program. + { + my $host = "changeme"; + my $user = "changeme"; + my $passwd = "changeme"; + my $prompt = '/changeme\$ $/'; + my $cmd = join("", "echo ", + "11111111112222222222333333333344444444445555555555", + "66666666667777777777888888888899999999990000000000", + "11111111112222222222333333333344444444445555555555", + "66666666667777777777888888888899999999990000000000", + "11111111112222222222333333333344444444445555555555", + "66666666667777777777888888888899999999990000000000"); + + use Net::Telnet (); + my $t = new Net::Telnet (-prompt => $prompt); + $t->open($host); + $t->login($user, $passwd); + + my @output = cmd_unixlong($t, $cmd); + print @output; + + exit; + } # end main program + + sub cmd_unixlong { + my ($obj, $cmd) = @_; + my ($line, $pos); + my $max_tty_line = 254; + + ## Start a Bourne shell. + $obj->cmd(-string => "/usr/bin/env " . + "'PS1= ' 'PS2= ' /bin/sh -i", + -prompt => '/ $/') + or return; + + ## Break-up the one large command line and send as shorter lines. + $pos = 0; + while (1) { + $line = substr $cmd, $pos, $max_tty_line; + $pos += length $line; + last unless $pos < length $cmd; + + ## Send the line with continuation char. + $obj->cmd(-string => "$line\\", + -prompt => '/ $/') + or return; + } + + ## Send the last line and return the output. + $obj->cmd("$line ; exit"); + } # end sub cmd_unixlong + + +=head1 AUTHOR + +Jay Rogers + +=head1 CREDITS + +Dave Martin, Dave Cardosi + +=head1 COPYRIGHT + +Copyright 1997, 2000, 2002, 2013 by Jay Rogers. All rights reserved. +This program is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. diff --git a/lib/sendemail.php b/lib/process_email.php similarity index 69% rename from lib/sendemail.php rename to lib/process_email.php index eb965e6..8ca340c 100644 --- a/lib/sendemail.php +++ b/lib/process_email.php @@ -15,38 +15,52 @@ $maildata = $db->dbquery($datasql); - + error_log($datasql."\n"); + error_log($maildata."\n"); $body = $tmpl['emailtext']; $subject = $tmpl['mailsubject']; foreach ($data as $key => $value){ $body = str_replace('%%'.$key.'%%',$value,$body); $subject = str_replace('%%'.$key.'%%',$value,$subject); } - foreach ($maildata as $key => $value){ + if ($maildata != null){ + foreach ($maildata as $key => $value){ $body = str_replace('%%'.$key.'%%',$value,$body); $subject = str_replace('%%'.$key.'%%',$value,$subject); + } } - //pregreplace - + $body = str_replace(chr(13),"",$body); + $body = str_replace(chr(10),"",$body); + $body = str_replace('"','\"',$body); + $body = str_replace("'","\\'",$body); + if (strpos($body,'%%') !== false) { + error_log("body element not replaced: ".$body); + return 1; + } + if (strpos($subject,'%%') !== false){ + error_log("subject element not replaced: ".$subject); + return 1; + } if (($body != "") && ($subject != "")){ - $body = str_replace(chr(13),"",$body); + $cmd= 'perl "'.$_SERVER['DOCUMENT_ROOT'].''.$baseurl.'/lib/sendEmail" -f '.$tmpl["from"].' '; - $cmd .= '-t "'.$data["email"].'" '; - $cmd .= '-u "'.$subject.'" '; - $cmd .= '-m "'.$body.'" '; + $cmd .= ' -s "mail.your-server.de:587" -xu "ksaffran@dks.lu" -xp "FB1ia1ka" -q '; $cmd .= '-o tls=auto '; $cmd .= '-o message-content-type=html '; $cmd .= '-o message-charset=utf-8 '; + $cmd .= '-t "'.$data["email"].'" '; + $cmd .= '-u "'.$subject.'" '; + $cmd .= '-m "'.$body.'" '; if ($attach){ $cmd .= " -a"; foreach ($attach as $a){ $cmd .= " ".$a." "; } } - #$cmd .= '-o message-header="Content-Type: text/html; charset=utf-8" '; - $cmd .= '-s mail.your-server.de:587 -xu "ksaffran@dks.lu" -xp "FB1ia1ka" -q'; $status = 1; + + //$retdata =shell_exec($cmd); system($cmd,$status); return $status; diff --git a/lib/process_payment.php b/lib/process_payment.php new file mode 100644 index 0000000..c79247c --- /dev/null +++ b/lib/process_payment.php @@ -0,0 +1,127 @@ +dbquery($sql); + $pdffile = create_pdfinvoice($pdfdata); + $msg .= '
'.$pdffile; + if ($pdffile != ""){ + $send = sendemail('user_invoice',array("email" => $user["useremail"],"id" => $user["id"]),array($pdffile)); + if ($send == 0){ + $msg = '
Nous vous avons envoyé un email avec la facture à payer!
'; + } else { + $msg = '
ERROR d\'envoie, reessayer plus tard!
'; + } + } else { + $msg = '
ERREUR!, reessayer plus tard
'; + } + $p = 'profile'; + $sp = 'profile/payement'; +} + +function create_pdfinvoice($idata){ + global $baseurl,$msg; + $idata["recipient"] = str_replace("'","\\'",$idata["recipient"]); + $idata["recipient"] = str_replace('"','\\"',$idata["recipient"]); + + $invlang="fr"; + $invdata='{ +"CURRENCY":"€", +"RECIPIENT":"'.$idata["recipient"].'", +"ADDRESS":"'.$idata["address"].'", +"COUNTRYSHORT":"'.$idata["countryshort"].'", +"ZIP":"'.$idata["zip"].'", +"CITY":"'.$idata["city"].'", +"REFERENCE":"'.$idata["reference"].'", +"INVOICEDATE":"'.$idata["invoicedate"].'", +"REMINDERDATE":"'.$idata["reminderdate"].'", +"CLIENTNUMBER":"'.$idata["clientnumber"].'", +"PRODUCTLIST":[ +{ + "PRODUCT":"'.$idata["product"].'", + "QUANTITY":"'.$idata["quantity"].'", + "UNIT":"'.$idata["unit"].'", + "UNITAMOUNT":"'.$idata["unitamount"].'", + "NETAMOUNT":"'.$idata["netamount"].'", + "CURRENCY":"€" +} +], +"SUMNETAMOUNT":"'.$idata["sumnetamount"].'", +"VATPERCENT":"'.$idata["vatpercent"].'", +"SUMVATAMOUNT":"'.$idata["sumvatamount"].'", +"SUMGROSSAMOUNT":"'.$idata["sumgrossamount"].'" +}'; +$invdata = str_replace("\n",'',$invdata); +$invdata = str_replace("\r",'',$invdata); +$pdffile=$idata["pdfname"]; +$cmd = "perl ".$_SERVER['DOCUMENT_ROOT'].''.$baseurl.'/lib/createpdfA4invoice'; +$cmd .= ' -d \''.$invdata.'\''; +$cmd .= ' -o "'.$_SERVER['DOCUMENT_ROOT'].''.$baseurl.'/data/invoices/'.$pdffile.'"'; +$cmd .= ' -l "'.$invlang.'"'; + +$status = 1; +// $msg .= '
'.$cmd; +$ret = system($cmd,$status); +// $msg .= "$ret"; +if ($status == 0){ + return $_SERVER['DOCUMENT_ROOT'].''.$baseurl.'/data/invoices/'.$pdffile; +} +return ""; +} + +function activate_evaluation($gdt){ + global $db,$user,$msg; + $sql = "select us.service,us.expiration,us.payeddate,us.isevaluation,apps.name from userservices us join apps on (us.id_app=apps.id) where us.id_app='".$gdt["app"]."' and us.id_user=".$user["id"].";"; + $eval = $db->dbquery($sql); + if ($eval){ + $msg = '
Vous avez déjà testé le service '.$eval["name"].'
'; + } else { + $sql = "select id,app,name,evaluationdays from apps where id=".$gdt["app"]; + + $eapp = $db->dbquery($sql); + if ($eapp["evaluationdays"] == null){ + $msg = '
Cette Application n\'a pas une periode d\'évaluation
'; + }else { + $evaldate = date('Y-m-d',strtotime("+".$eapp["evaluationdays"]." days")); + $evaldateshow = date('d.m.Y',strtotime("+".$eapp["evaluationdays"]." days")); + $sql = "INSERT INTO userservices (id_user,service,expiration,isevaluation,id_app) VALUES (".$user["id"].",'".$eapp["app"]."',date('".$evaldate."'),1,".$eapp["id"].")"; + $db->dbexec($sql); + $msg = '
Periode d\'évaluation a été activé jusqu\'au '.$evaldateshow.'
'; + } + + + } +} + function enable_app($gdt){ + global $db,$user,$msg; + $sql = "select id,service,expiration,payeddate,isevaluation from userservices where id_app='".$gdt["id"]."' and id_user=".$user["id"].";"; + $eval = $db->dbquery($sql); + // $msg = $sql; + if ($eval){ + if ($gdt["enable"] == "0"){ $gdt["enable"] = 'null';} + $sql = "UPDATE userservices set enabled=".$gdt["enable"]." WHERE id=".$eval["id"].";"; + // $msg .= '
'.$sql; + $db->dbexec($sql); + } else { + $sql = "select id,evaluationdays,app from apps where id=".$gdt["id"].";"; + $eapp = $db->dbquery($sql); + if (($eapp) && ($eapp["evaluationdays"] == null)){ + + $sql = "INSERT INTO userservices (id_user,service,id_app,enabled) VALUES (".$user["id"].",'".$eapp["app"]."',".$gdt["id"].",".$gdt["enable"].")"; + // $msg .= '
'.$sql; + $db->dbexec($sql); + } + } + } +?> \ No newline at end of file diff --git a/lib/process_profile.php b/lib/process_profile.php new file mode 100644 index 0000000..0661618 --- /dev/null +++ b/lib/process_profile.php @@ -0,0 +1,142 @@ +dbquery("SELECT count(*) as cnt FROM users WHERE useremail='".$pdt["useremail"]."';"); + if ($haveuser["cnt"] > 0){ + $msg = '
Un utilisateur '.$pdt["useremail"].' existe déjà!
'; + return; + } + $pdt["usergroup"] = "client"; + if (substr($pdt["useremail"], -11) === '@barreau.lu'){ + $pdt["usergroup"] = "avocat"; + } + if ((substr($pdt["useremail"], -11) === '@dks.lu') || (substr($pdt["useremail"], -11) === '@juridig.lu')){ + $pdt["usergroup"] = "administrator"; + } + $pdt["aktivationcode"] = generateRandomString(8); + $sql2 = " INSERT INTO users (usersurname, userprename, useremail, md5pwd,usergroup,activationkey) VALUES ('".$pdt["usersurname"]."','".$pdt["userprename"]."','".$pdt["useremail"]."',md5('".$pdt["userpassword"]."'),'".$pdt["usergroup"]."','".$pdt["aktivationcode"]."');"; + $db->dbexec($sql2); + $sql3 = "select id,useremail as email,activationkey as activationcode from users where useremail='".$pdt["useremail"]."';"; + $mdata = $db->dbquery($sql3); + $send = sendemail('user_registration_confirmation',$mdata); + if ($send == 0){ + $msg= '
Votre compte a été créé sur juridig.lu!
+ Nous vous avons envoyé un email avec un code de confirmation pour votre régistration.
Pour activer votre compte vous devez entrer ce code formulaire ci-dessous! +
'; + $p = "activationcode"; + } else { + $msg= '
Erreur! quelque chose n\'a pas bien fonctionnée!
'; + } + return; +} + +function activate_user($email,$akey){ + global $db,$msg,$p,$sp; + $email = $db->secvalue($email); + $akey = $db->secvalue($akey); + $sql = "select count(*) as cnt from users where useremail='".$email."' and activationkey='".$akey."'"; + $hasuser = $db->dbquery($sql); + if ($hasuser["cnt"] > 0){ + //$hasuser = $db->dbquery("select * from users where useremail='".$email."' and activationkey='".$akey."'"); + $db->dbexec("update users set activationkey=null where useremail='".$email."' and activationkey='".$akey."'"); + $msg = '
le compte a été activé!
'; + $p = 'profile'; + $sp = array('profile'); + } else { + $msg= '
le code activation n\'est pas correcte!
'; + $p = 'activationcode'; + $sp = array('activationcode'); + } +} + +function sendnewpassword($email){ + global $db,$msg; + $email = $db->secvalue($email); + $sql = "select id,useremail from users where useremail='".$email."';"; + $tmpuser = $db->dbquery($sql); + if (count($tmpuser) > 0){ + $newpasswd = randomPassword(10,'lower_case,upper_case,numbers,special_symbols'); + $sql2 = "UPDATE users SET md5pwd=md5('".$newpasswd."') WHERE useremail='".$email."';"; + $db->dbexec($sql2); + $send = sendemail('user_forgotpasswd',array("email" => $email, "newpassword" => $newpasswd,"id" => $tmpuser["id"])); + if ($send == 0){ + $msg = '
Nous vous avons envoyés un nouveau mot de passe!
'; + } else { + $msg = '
ERROR sending message!
'; + } + } +} + +function checklogin($username,$passwd){ + global $db,$msg; + $sql = "select count(*) as cnt,id from users where useremail='".$db->secvalue($username)."' and md5pwd=md5('".$db->secvalue($passwd)."');"; + + $luser = $db->dbquery($sql); + $sid = null; + $retuser=null; + //echo "
$sql
".$luser["cnt"]."
"; + if ($luser["cnt"] == 1){ + $sid = generateRandomString(); + $sql = "INSERT INTO usersession (sessionid, id_user, lastlogin, useragent, remoteaddr) + VALUES('".$sid."', ".$luser['id'].", CURRENT_TIMESTAMP, '".$_SERVER['HTTP_USER_AGENT']."', '".$_SERVER['REMOTE_ADDR']."');"; + $db->dbexec($sql); + setcookie("juridig",$sid); + $retuser = getsessiondata($sid); + + //$p='profile'; + }else { + setcookie("juridig",""); + $msg='
Utilisateur et/ou mot de passe non connu!
'; + //$p='/home'; + } + return $retuser; +} + + + +function getsessiondata($sessid){ + global $db; + $sql = "SELECT us.*,ses.sessionid, + GROUP_CONCAT(CASE WHEN srv.expiration >= CURRENT_DATE or (prc.minmonth=0 and srv.expiration is null) then srv.service else null end) as service_valid, + GROUP_CONCAT(CASE WHEN srv.expiration < CURRENT_DATE then srv.service else null end) as service_expired + from usersession ses + left JOIN users us on (ses.id_user=us.id) + left join userservices srv on (srv.id_user=us.id) + join appprices prc on (prc.id_app=srv.id_app) + where ses.sessionid='".$sessid."';"; + $sesuser = $db->dbquery($sql); + return $sesuser; +} + +function randomPassword($length, $characters) { + $symbols = array(); + $password = ''; + $used_symbols = ''; + $pass = ''; + $symbols["lower_case"] = 'abcdefghijklmnopqrstuvwxyz'; + $symbols["upper_case"] = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; + $symbols["numbers"] = '1234567890'; + $symbols["special_symbols"] = '!?@#-_+*&='; + + $characters = explode(",",$characters); + foreach ($characters as $key=>$value) { + $used_symbols .= $symbols[$value]; + } + $symbols_length = strlen($used_symbols) - 1; + + + for ($i = 0; $i < $length; $i++) { + $n = rand(0, $symbols_length); + $password .= $used_symbols[$n]; + } + + return $password; +} + +function delete_profile_user(){ + //must save email in separate table to + //first save user to evaluationtable + $db->dbexec("delete FROM users WHERE id=".$user["id"])." cascade;"; +} +?> \ No newline at end of file diff --git a/lib/process_rdv.php b/lib/process_rdv.php new file mode 100644 index 0000000..e0a0bd3 --- /dev/null +++ b/lib/process_rdv.php @@ -0,0 +1,111 @@ +secvalue($rdv["useremail"])."';"; + $clientuser = $db->dbquery($sqlsenderuser); + if (!isset($clientuser)){ + //save new client user + $usersql = "INSERT INTO users (usersurname, userprename, useremail, usergroup,userphone) VALUES ('".$rdv["usersurname"]."','".$rdv["userprename"]."','".$rdv["useremail"]."','client','".$rdv["userphone"]."');"; + $db->dbexec($sql2); + $usersql = "select id,userblocked as email from users where useremail='".$rdv["useremail"]."';"; + $clientuser = $db->dbquery($usersql); + } + + if ($clientuser["userblocked"] == "1"){ + $msg = '
L\'utilisateur avec l\'email '.$rdv["useremail"].' a été blocké par le système!
'; + return; + }else { + if (preg_match('/^\d\d.\d\d.\d\d\d\d$/',$rdv["rendezvousdatepicker"]) == 1){ + $rdv["eventdate"] = str_replace('/', '-', $rdv["rendezvousdatepicker"]); + $rdv["eventdate"] = date('Y-m-d', strtotime($rdv["eventdate"])); + } + $options=""; + if (isset($rdv["option1"]) || isset($rdv["option2"]) || isset($rdv["option3"]) || isset($rdv["option4"])){ + $sqlopt = "select option1_name,option2_name,option3_name,option4_name from timesheets where startdate <= date('".$rdv["eventdate"]."') order by startdate desc LIMIT 1"; + $optionnames = $db->dbquery($sqlopt); + if (isset($rdv["option1"]) && $rdv["option1"] != ""){ + $options .= $optionnames["option1_name"].': '.$rdv["option1"]."
"; + } + if (isset($rdv["option2"]) && $rdv["option2"] != ""){ + $options .= $optionnames["option2_name"].': '.$rdv["option2"]."
"; + } + if (isset($rdv["option3"]) && $rdv["option3"] != ""){ + $options .= $optionnames["option3_name"].': '.$rdv["option3"]."
"; + } + if (isset($rdv["option4"]) && $rdv["option4"] != ""){ + $options .= $optionnames["option4_name"].': '.$rdv["option4"]."
"; + } + } + $to_user = $db->dbquery("select userprename,usersurname from users where id=".$db->secvalue($rdv["id_user"])); + $rdvuuid = gen_uuid(); + $sqlevent = "INSERT INTO events (id_user, id_client, eventdate, eventoptions, eventuuid, eventhour, user_status, client_status,clientuuid,useruuid) + VALUES(".$db->secvalue($rdv["id_user"]).", ".$db->secvalue($clientuser["id"]).", date('".$db->secvalue($rdv["eventdate"])."'), ".(($options != "")?"'".$options."'":'null').", '".$rdvuuid."', '".$db->secvalue($rdv["eventhour"])."', 'unconfirmed', 'unconfirmed',uuid(),uuid());"; + $db->dbexec($sqlevent); + $mdata= array("email" => $rdv["useremail"], "eventuuid" => $rdvuuid, "siteurl" => $_SERVER['REQUEST_SCHEME'].'://'.$_SERVER["HTTP_HOST"].$baseurl); + $send = sendemail('client_rendezvous_confirmation',$mdata); + // $msg .= $senddata; + // $send = 0; + if ($send == 0){ + $msg .= '
Votre demande à été enregistrée!
+ Nous vous avons envoyés un email avec un lien de confirmation.
Après confirmation votre demande sera tranférée au avocat! +
'; + } else { + $msg .= '
Erreur! quelque chose n\'a pas bien fonctionnée!
'; + } + } + + } + +function rdv_changestatus($rdv){ + global $db,$msg,$baseurl; + $sql = "select DATE_FORMAT(ev.eventdate,'%d/%m/%Y') as eventdate,ev.eventoptions,ev.eventhour,ev.user_status,ev.client_status,ev.eventuuid, + CONCAT(usr.userprename,' ',usr.usersurname) as username, + CONCAT(cl.userprename,' ',cl.usersurname) as clientname, + ev.clientuuid,ev.useruuid,cl.userphone as clientphone,cl.useremail as clientemail,usr.useremail, + from events ev + left join users usr on (ev.id_user=usr.id) + left join users cl on (ev.id_client=cl.id) where ev.clientuuid='".$db->secvalue($rdv["uuid"])."' or ev.useruuid='".$db->secvalue($rdv["uuid"])."'"; + $event = $db->dbquery($sql); + $sql = ""; + $newrdv = 0; + if ($event != null){ + if ($rdv["uuid"] == $event["clientuuid"]){ + + if (($rdv["setstatus"] == "confirm") && ($event["client_status"] != "confirmed")){ + if ($event["client_status"] == "unconfirmed"){ + $newrdv = 1; + } + $sql = "UPDATE events SET client_status='confirmed' where clientuuid='".$rdv["uuid"]."'"; + } else if (($rdv["setstatus"] == "cancel") && ($event["client_status"] != "canceled")){ + $sql = "UPDATE events SET client_status='canceled' where clientuuid='".$rdv["uuid"]."'"; + } + } else if ($rdv["uuid"] == $event["useruuid"]){ + if (($rdv["setstatus"] == "confirm") && ($event["user_status"] != "confirmed")){ + $sql = "UPDATE events SET user_status='confirmed' where useruuid='".$rdv["uuid"]."'"; + } else if (($rdv["setstatus"] == "cancel") && ($event["user_status"] != "canceled")){ + $sql = "UPDATE events SET user_status='canceled' where useruuid='".$rdv["uuid"]."'"; + } + } + if ($sql != ""){ + $res = $db->dbexec($sql); + if ($res !== false){ + if ($rdv["uuid"] == $event["clientuuid"]){ + $mdata= array("email" => $event["useremail"], "eventuuid" => $event["eventuuid"], "siteurl" => $_SERVER['REQUEST_SCHEME'].'://'.$_SERVER["HTTP_HOST"].$baseurl); + $mailtmpl = 'user_rendezvous_status_change'; + if ($newrdv == 1){ + $mailtmpl = 'user_rendezvous'; + } + $send = sendemail('user_rendezvous_status_change',$mdata); + } else if ($rdv["uuid"] == $event["useruuid"]){ + $mdata= array("email" => $event["clientemail"], "eventuuid" => $event["eventuuid"], "siteurl" => $_SERVER['REQUEST_SCHEME'].'://'.$_SERVER["HTTP_HOST"].$baseurl); + $send = sendemail('client_rendezvous_status_change',$mdata); + } + } else { + $msg = = '
Erreur! quelque chose n\'a pas bien fonctionnée!
'; + } + } + } +} +?> \ No newline at end of file diff --git a/lib/processdata.php b/lib/processdata.php index 411587c..ca387d6 100644 --- a/lib/processdata.php +++ b/lib/processdata.php @@ -1,5 +1,9 @@ secvalue($rdv["useremail"])."';"; - $clientuser = $db->dbquery($sqlsenderuser); - if (!isset($clientuser)){ - //save new client user - $usersql = "INSERT INTO users (usersurname, userprename, useremail, usergroup,userphone) VALUES ('".$rdv["usersurname"]."','".$rdv["userprename"]."','".$rdv["useremail"]."','client','".$rdv["userphone"]."');"; - $db->dbexec($sql2); - $usersql = "select id,userblocked as email from users where useremail='".$rdv["useremail"]."';"; - $clientuser = $db->dbquery($usersql); - } - - if ($clientuser["userblocked"] == "1"){ - $msg = '
L\'utilisateur avec l\'email '.$rdv["useremail"].' a été blocké par le système!
'; - return; - }else { - if (preg_match('/^\d\d.\d\d.\d\d\d\d$/',$rdv["rendezvousdatepicker"]) == 1){ - $rdv["eventdate"] = str_replace('/', '-', $rdv["rendezvousdatepicker"]); - $rdv["eventdate"] = date('Y-m-d', strtotime($val)); - } - $options=""; - if (isset($rdv["option1"]) || isset($rdv["option2"]) || isset($rdv["option3"]) || isset($rdv["option4"])){ - $sqlopt = "select option1_name,option2_name,option3_name,option4_name from timesheets where startdate <= date('".$rdv["eventdate"]."') order by startdate desc LIMIT 1"; - $optionnames = $db->dbquery($sqlopt); - if (isset($rdv["option1"]) && $rdv["option1"] != ""){ - $options .= $optionnames["option1_name"].': '.$rdv["option1"]."
"; - } - if (isset($rdv["option2"]) && $rdv["option2"] != ""){ - $options .= $optionnames["option2_name"].': '.$rdv["option2"]."
"; - } - if (isset($rdv["option3"]) && $rdv["option3"] != ""){ - $options .= $optionnames["option3_name"].': '.$rdv["option3"]."
"; - } - if (isset($rdv["option4"]) && $rdv["option4"] != ""){ - $options .= $optionnames["option4_name"].': '.$rdv["option4"]."
"; - } - } - $to_user = $db->dbquery("select prename,surname from users where id=".$db->secvalue($rdv["id_user"])); - $rdvuuid = gen_uuid(); - $sqlevent = "INSERT INTO events (id_user, id_client, eventdate, eventoptions, eventuuid, eventhour, user_status, client_status) - VALUES(".$db->secvalue($rdv["id_user"]).", ".$db->secvalue($clientuser["id"]).", date('".$db->secvalue($rdv["eventdate"])."'), ".(($options != "")?"'".$options."'":'null').", '".$rdvuuid."', '".$db->secvalue($rdv["eventhour"])."', 'unconfirmed', 'unconfirmed');"; - $db->dbexec($sqlevent); - $mdata= array("email" => $rdv["useremail"],"prename" => $rdv["userprename"],"surname" =>$rdv["userprename"], "eventdate" => $rdv["rendezvousdatepicker"], "eventhour" => $rdv["eventhour"], "event_ident" => $rdvuuid, "event_options" => $options); - $send = 0;// sendemail('client_rendezvous_confirmation',$mdata); - if ($send == 0){ - $msg= '
Votre demande à été enregistrer!
- Nous vous avons envoyé un email avec un lien de confirmation.
Après confirmation votre demande sera tranféré au avocat! -
'; - } else { - $msg= '
Erreur! quelque chose n\'a pas bien fonctionnée!
'; - } - } - - } - - function register_user($pdt){ - global $db,$msg,$p; - //do we have already an account for this user? - $haveuser = $db->dbquery("SELECT count(*) as cnt FROM users WHERE useremail='".$pdt["useremail"]."';"); - if ($haveuser["cnt"] > 0){ - $msg = '
Un utilisateur '.$pdt["useremail"].' existe déjà!
'; - return; - } - $pdt["usergroup"] = "client"; - if (substr($pdt["useremail"], -11) === '@barreau.lu'){ - $pdt["usergroup"] = "avocat"; - } - if ((substr($pdt["useremail"], -11) === '@dks.lu') || (substr($pdt["useremail"], -11) === '@juridig.lu')){ - $pdt["usergroup"] = "administrator"; - } - $pdt["aktivationcode"] = generateRandomString(8); - $sql2 = " INSERT INTO users (usersurname, userprename, useremail, md5pwd,usergroup,activationkey) VALUES ('".$pdt["usersurname"]."','".$pdt["userprename"]."','".$pdt["useremail"]."',md5('".$pdt["userpassword"]."'),'".$pdt["usergroup"]."','".$pdt["aktivationcode"]."');"; - $db->dbexec($sql2); - $sql3 = "select id,useremail as email,activationkey as activationcode from users where useremail='".$pdt["useremail"]."';"; - $mdata = $db->dbquery($sql3); - $send = sendemail('user_registration_confirmation',$mdata); - if ($send == 0){ - $msg= '
Votre compte a été créé sur juridig.lu!
- Nous vous avons envoyé un email avec un code de confirmation pour votre régistration.
Pour activer votre compte vous devez entrer ce code formulaire ci-dessous! -
'; - $p = "activationcode"; - } else { - $msg= '
Erreur! quelque chose n\'a pas bien fonctionnée!
'; - } - return; - } - - function activate_user($email,$akey){ - global $db,$msg,$p,$sp; - $email = $db->secvalue($email); - $akey = $db->secvalue($akey); - $sql = "select count(*) as cnt from users where useremail='".$email."' and activationkey='".$akey."'"; - $hasuser = $db->dbquery($sql); - if ($hasuser["cnt"] > 0){ - //$hasuser = $db->dbquery("select * from users where useremail='".$email."' and activationkey='".$akey."'"); - $db->dbexec("update users set activationkey=null where useremail='".$email."' and activationkey='".$akey."'"); - $msg = '
le compte a été activé!
'; - $p = 'profile'; - $sp = array('profile'); - } else { - $msg= '
le code activation n\'est pas correcte!
'; - $p = 'activationcode'; - $sp = array('activationcode'); - } - } - - function sendnewpassword($email){ - global $db,$msg; - $email = $db->secvalue($email); - $sql = "select id,useremail from users where useremail='".$email."';"; - $tmpuser = $db->dbquery($sql); - if (count($tmpuser) > 0){ - $newpasswd = randomPassword(10,'lower_case,upper_case,numbers,special_symbols'); - $sql2 = "UPDATE users SET md5pwd=md5('".$newpasswd."') WHERE useremail='".$email."';"; - $db->dbexec($sql2); - $send = sendemail('user_forgotpasswd',array("email" => $email, "newpassword" => $newpasswd,"id" => $tmpuser["id"])); - if ($send == 0){ - $msg = '
Nous vous avons envoyés un nouveau mot de passe!
'; - } else { - $msg = '
ERROR sending message!
'; - } - } - } - - function send_invoice(){ - global $db,$msg,$user,$p,$sp; - $sql = "select id, id_user, email, recipient, address, zip, city, countryshort, reference, pdfname,clientnumber,unit, - REPLACE(product,'\n','\\n') as product, - DATE_FORMAT(invoicedate, '%d.%m.%Y') as invoicedate, - DATE_FORMAT(reminderdate,'%d.%m.%Y') as reminderdate, - FORMAT(quantity, 0) as quantity, - REPLACE(FORMAT(unitamount, 2),'.',',') as unitamount, - REPLACE(FORMAT(netamount, 2),'.',',') as netamount, - REPLACE(FORMAT(sumnetamount, 2),'.',',') as sumnetamount, - REPLACE(FORMAT(vatpercent * 100, 2),'.',',') as vatpercent, - REPLACE(FORMAT(sumvatamount, 2),'.',',') as sumvatamount, - REPLACE(FORMAT(sumgrossamount, 2),'.',',') as sumgrossamount, - REPLACE(FORMAT(payedamount, 2),'.',',') as payedamount from invoicedata where id_user=".$user["id"]." order by invoicedate DESC,id DESC LIMIT 1;"; - $pdfdata = $db->dbquery($sql); - $pdffile = create_pdfinvoice($pdfdata); - $msg .= '
'.$pdffile; - if ($pdffile != ""){ - $send = sendemail('user_invoice',array("email" => $user["useremail"],"id" => $user["id"]),array($pdffile)); - if ($send == 0){ - $msg = '
Nous vous avons envoyé un email avec la facture à payer!
'; - } else { - $msg = '
ERROR d\'envoie, reessayer plus tard!
'; - } - } else { - $msg = '
ERREUR!, reessayer plus tard
'; - } - $p = 'profile'; - $sp = 'profile/payement'; - } - - function create_pdfinvoice($idata){ - global $baseurl,$msg; - $idata["recipient"] = str_replace("'","\\'",$idata["recipient"]); - $idata["recipient"] = str_replace('"','\\"',$idata["recipient"]); - - $invlang="fr"; - $invdata='{ - "CURRENCY":"€", - "RECIPIENT":"'.$idata["recipient"].'", - "ADDRESS":"'.$idata["address"].'", - "COUNTRYSHORT":"'.$idata["countryshort"].'", - "ZIP":"'.$idata["zip"].'", - "CITY":"'.$idata["city"].'", - "REFERENCE":"'.$idata["reference"].'", - "INVOICEDATE":"'.$idata["invoicedate"].'", - "REMINDERDATE":"'.$idata["reminderdate"].'", - "CLIENTNUMBER":"'.$idata["clientnumber"].'", - "PRODUCTLIST":[ - { - "PRODUCT":"'.$idata["product"].'", - "QUANTITY":"'.$idata["quantity"].'", - "UNIT":"'.$idata["unit"].'", - "UNITAMOUNT":"'.$idata["unitamount"].'", - "NETAMOUNT":"'.$idata["netamount"].'", - "CURRENCY":"€" - } - ], - "SUMNETAMOUNT":"'.$idata["sumnetamount"].'", - "VATPERCENT":"'.$idata["vatpercent"].'", - "SUMVATAMOUNT":"'.$idata["sumvatamount"].'", - "SUMGROSSAMOUNT":"'.$idata["sumgrossamount"].'" -}'; - $invdata = str_replace("\n",'',$invdata); - $invdata = str_replace("\r",'',$invdata); - $pdffile=$idata["pdfname"]; - $cmd = "perl ".$_SERVER['DOCUMENT_ROOT'].''.$baseurl.'/lib/createpdfA4invoice'; - $cmd .= ' -d \''.$invdata.'\''; - $cmd .= ' -o "'.$_SERVER['DOCUMENT_ROOT'].''.$baseurl.'/data/invoices/'.$pdffile.'"'; - $cmd .= ' -l "'.$invlang.'"'; - - $status = 1; - // $msg .= '
'.$cmd; - $ret = system($cmd,$status); - // $msg .= "$ret"; - if ($status == 0){ - return $_SERVER['DOCUMENT_ROOT'].''.$baseurl.'/data/invoices/'.$pdffile; - } - return ""; - } - - function checklogin($username,$passwd){ - global $db,$msg; - $sql = "select count(*) as cnt,id from users where useremail='".$db->secvalue($username)."' and md5pwd=md5('".$db->secvalue($passwd)."');"; - - $luser = $db->dbquery($sql); - $sid = null; - $retuser=null; - //echo "
$sql
".$luser["cnt"]."
"; - if ($luser["cnt"] == 1){ - $sid = generateRandomString(); - $sql = "INSERT INTO usersession (sessionid, id_user, lastlogin, useragent, remoteaddr) - VALUES('".$sid."', ".$luser['id'].", CURRENT_TIMESTAMP, '".$_SERVER['HTTP_USER_AGENT']."', '".$_SERVER['REMOTE_ADDR']."');"; - $db->dbexec($sql); - setcookie("juridig",$sid); - $retuser = getsessiondata($sid); - - //$p='profile'; - }else { - setcookie("juridig",""); - $msg='
Utilisateur et/ou mot de passe non connu!
'; - //$p='/home'; - } - return $retuser; - } - - - - function getsessiondata($sessid){ - global $db; - $sql = "SELECT us.*,ses.sessionid, - GROUP_CONCAT(CASE WHEN srv.expiration >= CURRENT_DATE then srv.service else null end) as service_valid, - GROUP_CONCAT(CASE WHEN srv.expiration < CURRENT_DATE then srv.service else null end) as service_expired - from usersession ses - LEFT JOIN users us on (ses.id_user=us.id) - left join userservices srv on (srv.id_user=us.id) - where ses.sessionid='".$sessid."';"; - $sesuser = $db->dbquery($sql); - return $sesuser; - } - - function generateRandomString($length = 40) { +function generateRandomString($length = 40) { $characters = '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; $charactersLength = strlen($characters); $randomString = ''; @@ -351,54 +114,18 @@ return $randomString; } - function randomPassword($length, $characters) { - $symbols = array(); - $password = ''; - $used_symbols = ''; - $pass = ''; - $symbols["lower_case"] = 'abcdefghijklmnopqrstuvwxyz'; - $symbols["upper_case"] = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; - $symbols["numbers"] = '1234567890'; - $symbols["special_symbols"] = '!?@#-_+*&='; - - $characters = explode(",",$characters); - foreach ($characters as $key=>$value) { - $used_symbols .= $symbols[$value]; - } - $symbols_length = strlen($used_symbols) - 1; - - - for ($i = 0; $i < $length; $i++) { - $n = rand(0, $symbols_length); - $password .= $used_symbols[$n]; - } - - return $password; - } - - function gen_uuid() { + +function gen_uuid() { return sprintf( '%04x%04x-%04x-%04x-%04x-%04x%04x%04x', - // 32 bits for "time_low" mt_rand( 0, 0xffff ), mt_rand( 0, 0xffff ), - - // 16 bits for "time_mid" mt_rand( 0, 0xffff ), - - // 16 bits for "time_hi_and_version", - // four most significant bits holds version number 4 mt_rand( 0, 0x0fff ) | 0x4000, - - // 16 bits, 8 bits for "clk_seq_hi_res", - // 8 bits for "clk_seq_low", - // two most significant bits holds zero and one for variant DCE1.1 mt_rand( 0, 0x3fff ) | 0x8000, - - // 48 bits for "node" mt_rand( 0, 0xffff ), mt_rand( 0, 0xffff ), mt_rand( 0, 0xffff ) ); } - function save_data($dbtable,$data){ +function save_data($dbtable,$data){ global $db,$msg; $type = "ins"; @@ -448,65 +175,13 @@ } //echo '
'.$sql.'
'; $rows = $db->dbexec($sql); - $msg = '
'.$sql.'
Les données ont été sauvegardés!
'; + $msg = '
Les données ont été sauvegardés!
'; return $rows; - } - - - function delete_profile_user(){ - //must save email in separate table to - //first save user to evaluationtable - $db->dbexec("delete FROM users WHERE id=".$user["id"])." cascade;"; - } - - function activate_evaluation($gdt){ - global $db,$user,$msg; - $sql = "select us.service,us.expiration,us.payeddate,us.isevaluation,apps.name from userservices us join apps on (us.id_app=apps.id) where us.id_app='".$gdt["app"]."' and us.id_user=".$user["id"].";"; - $eval = $db->dbquery($sql); - if ($eval){ - $msg = '
Vous avez déjà testé le service '.$eval["name"].'
'; - } else { - $sql = "select id,app,name,evaluationdays from apps where id=".$gdt["app"]; - - $eapp = $db->dbquery($sql); - if ($eapp["evaluationdays"] == null){ - $msg = '
Cette Application n\'a pas une periode d\'évaluation
'; - }else { - $evaldate = date('Y-m-d',strtotime("+".$eapp["evaluationdays"]." days")); - $evaldateshow = date('d.m.Y',strtotime("+".$eapp["evaluationdays"]." days")); - $sql = "INSERT INTO userservices (id_user,service,expiration,isevaluation,id_app) VALUES (".$user["id"].",'".$eapp["app"]."',date('".$evaldate."'),1,".$eapp["id"].")"; - $db->dbexec($sql); - $msg = '
Periode d\'évaluation a été activé jusqu\'au '.$evaldateshow.'
'; - } - - - } - } - function enable_app($gdt){ - global $db,$user,$msg; - $sql = "select id,service,expiration,payeddate,isevaluation from userservices where id_app='".$gdt["id"]."' and id_user=".$user["id"].";"; - $eval = $db->dbquery($sql); - // $msg = $sql; - if ($eval){ - if ($gdt["enable"] == "0"){ $gdt["enable"] = 'null';} - $sql = "UPDATE userservices set enabled=".$gdt["enable"]." WHERE id=".$eval["id"].";"; - // $msg .= '
'.$sql; - $db->dbexec($sql); - } else { - $sql = "select id,evaluationdays,app from apps where id=".$gdt["id"].";"; - $eapp = $db->dbquery($sql); - if (($eapp) && ($eapp["evaluationdays"] == null)){ - - $sql = "INSERT INTO userservices (id_user,service,id_app,enabled) VALUES (".$user["id"].",'".$eapp["app"]."',".$gdt["id"].",".$gdt["enable"].")"; - // $msg .= '
'.$sql; - $db->dbexec($sql); - } - } } - function crypt_mailaddress($mailadr){ +function crypt_mailaddress($mailadr){ $n = 0; $r = ""; $mailadr = 'mailto:'.$mailadr; diff --git a/phpinfo.php b/phpinfo.php new file mode 100644 index 0000000..c9f5eeb --- /dev/null +++ b/phpinfo.php @@ -0,0 +1 @@ + \ No newline at end of file diff --git a/site.js b/site.js index 90c69f3..ab3862d 100644 --- a/site.js +++ b/site.js @@ -20,33 +20,14 @@ $( document ).ready(function() { initdata(); }); -// function readUrl(input) { - -// if (input.files && input.files[0]) { -// let reader = new FileReader(); -// reader.onload = (e) => { -// let imgData = e.target.result; -// let imgName = input.files[0].name; -// input.setAttribute("data-title", imgName); -// //console.log(e.target.result); -// } -// reader.readAsDataURL(input.files[0]); -// } -// } function handleFileSelect(evt) { var files = evt.target.files; // FileList object var utype = ""; - if ($("form").attr('id') = "dksrdv_userprofile"){ - utype = "user"; - } else if ($("form").attr('id') = "dksrdv_companyprofile"){ - utype = "company"; - } - $("form").prepend(''); - //if (!$("#userphoto")){ - - //} + if ($("form").attr('id') == "dksrdv_catalog"){ + $("form").prepend(''); + // Loop through the FileList and render image files as thumbnails. for (var i = 0, f; f = files[i]; i++) { @@ -69,7 +50,7 @@ function handleFileSelect(evt) { // Read in the image file as a data URL. reader.readAsDataURL(f); } - +} } function removephoto(utype){ @@ -91,14 +72,7 @@ function initstandard(){ todayHighlight: true, daysOfWeekDisabled: [0,6] }); - // $('.datepicker').on('changeDate', function() { - // //console.log($('#rendezvousdatepicker').datepicker('getFormattedDate')); - // $('#dateselected').val( - // $('#rendezvousdatepicker').datepicker('getFormattedDate') - // ); - // }); - //$(".btn-group-toggle").twbsToggleButtons(); - //console.log("init now tinymce!"); + tinymce.init({ selector: '.richeditarea', //height: 300, @@ -108,16 +82,6 @@ function initstandard(){ plugins: 'searchreplace autolink directionality visualblocks visualchars advlist lists textcolor colorpicker textpattern', toolbar: 'bold italic underline strikethrough forecolor backcolor | link | alignleft aligncenter alignright alignjustify | numlist bullist outdent indent | removeformat', image_advtab: true -// language: 'fr_FR', -// init_instance_callback: function (editor) { -// editor.on('blur', function (e) { -// console.log(e); -// var msgdata = tinymce.get(e.target.id).getContent(); -// focusouttinymce(e.target.id,msgdata); -// -// }); -// } - }); } } diff --git a/tmpl/blocks/avocatsearch.php b/tmpl/blocks/avocatsearch.php index 3141309..4405eef 100644 --- a/tmpl/blocks/avocatsearch.php +++ b/tmpl/blocks/avocatsearch.php @@ -1,9 +1,12 @@ = CURRENT_DATE then 1 else null end as rendezvous_active,usr.* from users usr - join userservices annu on (usr.id=annu.id_user and annu.service='annuaire' and annu.enabled=1) - join userservices srv on (usr.id=srv.id_user) - where usr.usergroup in ('avocat') and usr.userblocked is null and usr.activationkey is null group by usr.id;"; + $sql = "SELECT case when srv.enabled='1' and srv.expiration >= CURRENT_DATE then 1 else null end as rendezvous_active,cat.*,srv.id_user + from users usr + join userservices annu on (usr.id=annu.id_user and annu.service='annuaire' and annu.enabled=1) + join userservices srv on (usr.id=srv.id_user and srv.service='rendezvous') + left join `catalog` cat on (usr.id=cat.id_user) + where usr.usergroup in ('avocat') and usr.userblocked is null and usr.activationkey is null group by usr.id order by cat.company,cat.surname,cat.prename;"; $avocats = $db->dbqueryall($sql); + // echo "$sql"; ?>
@@ -31,32 +34,32 @@ foreach ($avocats as $avo) { echo '
-
'.$avo['usersurname'].' '.$avo['userprename'].' '.(($avo['usercompany'] != "")?'('.$avo['usercompany'].')':'').'
+
'.$avo['surname'].' '.$avo['prename'].' '.(($avo['company'] != "")?'('.$avo['company'].')':'').'
'; //echo '
; echo '
'; - if ($avo["userphoto"] != ''){ - echo 'picture'; + if ($avo["photo"] != ''){ + echo 'picture'; } - echo (($avo['userdescription'] != "")?$avo['userdescription']:'').'
'; + echo (($avo['description'] != "")?$avo['description']:'').'
'; if ($avo["rendezvous_active"] == "1"){ - echo 'prendre rendez-vous'; + echo 'prendre rendez-vous'; } echo '
'; - if (($avo['useraddress'] != '') || ($avo['userzip'] != '') || ($avo['usercity'] != '') || ($avo['useremail'] != '') || ($avo['userphone'] != '')){ + if (($avo['address'] != '') || ($avo['zip'] != '') || ($avo['city'] != '') || ($avo['email'] != '') || ($avo['phone'] != '')){ echo '
Contact
'; - if ($avo['useraddress'] != '') { echo $avo['useraddress'].'
';} - if ($avo['userzip'] != '' || $avo['usercity'] != ''){ - echo '
'.(($avo['userzip'] != "")?$avo['userzip']:'').' '.(($avo['usercity'] != "")?$avo['usercity']:'').'
'; + if ($avo['address'] != '') { echo $avo['address'].'
';} + if ($avo['zip'] != '' || $avo['city'] != ''){ + echo '
'.(($avo['zip'] != "")?$avo['zip']:'').' '.(($avo['city'] != "")?$avo['city']:'').'
'; } - if ($avo['userphone'] != ''){ - echo ''; + if ($avo['phone'] != ''){ + echo ''; } - if ($avo['useremail']){ - echo ': '; + if ($avo['email']){ + echo ': '; } echo '
'; } @@ -71,9 +74,9 @@ foreach ($avocats as $avo) { .(($avo['consultsun'] != "")?''.$avo['consultsun'].'
':''). '
'; } - if ($avo['userspecialisations'] != ""){ + if ($avo['specialisations'] != ""){ echo '
'; - $spa = explode(',',$avo['userspecialisations']); + $spa = explode(',',$avo['specialisations']); echo '
Specialisation
  • '.join('
  • ',$spa).'
'; echo '
'; diff --git a/tmpl/javascript.php b/tmpl/javascript.php index ceb91a3..d5d840d 100644 --- a/tmpl/javascript.php +++ b/tmpl/javascript.php @@ -8,4 +8,4 @@ - \ No newline at end of file + \ No newline at end of file diff --git a/tmpl/pages/profile/annuaire.php b/tmpl/pages/profile/annuaire.php new file mode 100644 index 0000000..d04873d --- /dev/null +++ b/tmpl/pages/profile/annuaire.php @@ -0,0 +1,144 @@ + +dbquery($sql); + // print_r($cataloguser); +?> +
+ + +
+
Données de l'annuaire
+
+ +
+
Données de base
+
+ + +
+
+ + +
+
+ + + +
+
+ + +
+ +
+ + +
+
+ + +
+
+ + +
+
+ + +
+ +
+
+
Descriptions
+
+
+ + +
+ " style="width: 150px; max-width: 150px; max-height: 150px;" id="preview"/> +
+
+
+
+ Photo +
+
+ + +
+
+  supprimer la photo +
+
+
+
+ + +
+
+ +
+
+ +
+ +
+
€
+
+
+
+
+
+ +
+ + +
+
+
+ +
+
+
+ + +
+
+ +
+
+ +
+
+ +
+
+
+
+ +
+
+ +
+
+ +
+
+
+ +
+ +
+ +
+ +
+ + diff --git a/tmpl/pages/profile/profile.php b/tmpl/pages/profile/profile.php index 2a52eea..e5bf6cd 100644 --- a/tmpl/pages/profile/profile.php +++ b/tmpl/pages/profile/profile.php @@ -6,15 +6,15 @@ $subpath = ""; } } + // print_r($user); ?> +
Profile
Mon Profile - Changer Mot de Passe - Supprimer mon profile - - + +
Applications - 0) || (strlen($user["service_expired"]) > 0) ){ - - // echo ' Factures'; - - // } - - ?> +
+ +
Anuaire
+ Données d'annuaire +
- -
Rendez-Vous
+
Rendez-Vous
+ Mes Clients Mes Rendez-Vous Aciens Rendez-Vous @@ -49,7 +51,7 @@ Calendrier/Horaires - + dbquery($sql); ?> -
- -
-
Profile
-
+
+
+
+
Profil
+
+ + +
+ + +
+
+ + +
+
+ + +
+
+ + +
+
+ +

(*) champs requis

+
+ +
+
+
+
+
+ +
+
+
Changement mot de passe
+
+
+ + +
+
+
Le mot de passe doit contenir au moins 10 charactères
+
+
    avec: +
  • au moins 1 lettre minuscule
    • +
  • au moins 1 lettre majuscule
    • +
  • au moins 1 nombre
    • +
  • au moins 1 charactère spéciale
    • +
+
+
+
+ +
+
+
+
+
+
-
-
Mes coordonnées
-
- - -
-
- - -
-
- - - -
-
- - -
- -
- - -
-
- - -
-
- - -
-
- - -
- -
- -
-
Descriptions
-
-
- - -
- " style="width: 150px; max-width: 150px; max-height: 150px;" id="preview"/> -
-
-
-
- Photo -
-
- - -
-
-  supprimer la photo +
+
+
Supprimer le Profil
+
+
+
+ + +
+
+
+
-
-
- - -
-
- -
-
- -
- -
-
€
-
-
-
-
-
- -
- - -
-
-
- -
-
-
- - -
-
- -
-
- -
-
- -
-
-
-
- -
-
- -
-
- -
-
-
- -
- - } - ?> -
- - -

(*) champs requis

-
+ +
+
-
- + + function initdata(){ initstandard(); } +
= CURRENT_DATE;"; -$avolist = $db->dbqueryall($sql); +$sql = "SELECT usr.id,usr.userprename,usr.usersurname from users usr left join userservices srv on (usr.id=srv.id_user) where srv.service='rendezvous' and srv.expiration >= CURRENT_DATE and usr.id='".$_GET["id"]."';"; +// echo $sql; +$avosel = $db->dbquery($sql); } ?>

Demande de Rendez-Vous

- +
- +
@@ -87,7 +81,7 @@ $avolist = $db->dbqueryall($sql);
- +
@@ -109,7 +103,7 @@ var rdvdata = {"id_user":"", function initdata(){ moment.locale('fr'); - console.log("INIT RDV DATA!"); + //console.log("INIT RDV DATA!"); moment.locale('fr'); getuserdata(); $('.datepicker').datepicker({ @@ -163,8 +157,8 @@ function initdata(){ function getuserdata(){ console.log("Get User Data!"); - $("#tr_id_user > td").html($("#id_user :selected").text()); - rdvdata.id_user = $("#id_user :selected").val(); + $("#tr_id_user > td").html($("#avoname").val()); + rdvdata.id_user = $("#id_user").val(); getdaydata(rdvdata.eventstartdate); } diff --git a/tmpl/pages/rendezvousevent.php b/tmpl/pages/rendezvousevent.php index 5e9d9ea..217ad4f 100644 --- a/tmpl/pages/rendezvousevent.php +++ b/tmpl/pages/rendezvousevent.php @@ -15,7 +15,7 @@ if ($_GET["uuid"] == $event["clientuuid"]){ if ($event["client_status"] == 'unconfirmed'){ ?> -
+ echo '
@@ -90,7 +90,7 @@
Liste des rendezvous
'; } ?>