Improve performance by optimizing critical code sections

lib/Zonemaster/Engine.pm

@@ -231,6 +231,7 @@ sub reset {
     Zonemaster::Engine::Nameserver->empty_cache();
     $logger->clear_history() if $logger;
     Zonemaster::Engine::Recursor->clear_cache();
+    Zonemaster::Engine::TestMethodsV2->clear_cache();
     return;
 }
 
@@ -408,7 +409,8 @@ Set the logger's start time to the current time.
 =item reset()
 
 Reset logger start time to current time, empty the list of log messages, clear
-nameserver object cache and recursor cache.
+nameserver object cache, clear recursor cache and clear all cached results of
+MethodsV2.
 
 =back
 

lib/Zonemaster/Engine/DNSName.pm

@@ -22,14 +22,20 @@ sub from_string {
     confess 'Argument must be a string: $domain'
       if !defined $domain || ref $domain ne '';
 
-    return $class->_new( { labels => [ split( /[.]/x, $domain ) ] } );
+    my $obj = Class::Accessor::new( $class, { labels => [ split( /[.]/x, $domain ) ] } );
+
+    # We have the raw string, so we can precompute the string representation
+    # easily and cheaply so it can be immediately returned by the string()
+    # method instead of recomputing it from the labels list. The only thing we
+    # need to do is to remove any trailing dot except if it’s the only
+    # character.
+    $obj->{_string} = ( $domain =~ s/.\K [.] \z//rx );
+
+    return $obj;
 }
 
 sub new {
-    my $proto = shift;
-    confess "must be called with a single argument"
-      if scalar( @_ ) != 1;
-    my $input = shift;
+    my ( $class, $input ) = @_;
 
     my $attrs = {};
     if ( !defined $input ) {
@@ -39,7 +45,7 @@ sub new {
         $attrs->{labels} = \@{ $input->labels };
     }
     elsif ( blessed $input && $input->isa( 'Zonemaster::Engine::Zone' ) ) {
-        $attrs->{labels} = [ split( /[.]/x, $input->name ) ];
+        $attrs->{labels} = \@{ $input->name->labels };
     }
     elsif ( ref $input eq '' ) {
         $attrs->{labels} = [ split( /[.]/x, $input ) ];
@@ -62,31 +68,20 @@ sub new {
         confess "Unrecognized argument: " . $what;
     }
 
-    # Type constraints
-    confess "Argument must be an ARRAYREF: labels"
-      if exists $attrs->{labels}
-      && ref $attrs->{labels} ne 'ARRAY';
-
-    my $class = ref $proto || $proto;
-    return $class->_new( $attrs );
-}
-
-sub _new {
-    my $class = shift;
-    my $attrs = shift;
-
-    my $obj = Class::Accessor::new( $class, $attrs );
-
-    return $obj;
+    return Class::Accessor::new( $class, $attrs );
 }
 
 sub string {
     my $self = shift;
 
-    my $name = join( '.', @{ $self->labels } );
-    $name = '.' if $name eq q{};
+    if ( not exists $self->{_string} ) {
+        my $string = join( '.', @{ $self->labels } );
+        $string = '.' if $string eq q{};
+
+        $self->{_string} = $string;
+    }
 
-    return $name;
+    return $self->{_string};
 }
 
 sub fqdn {
@@ -96,12 +91,21 @@ sub fqdn {
 }
 
 sub str_cmp {
-    my ( $self, $other ) = @_;
-    $other //= q{};    # Treat undefined value as root
+    # For performance reasons, we do not unpack @_.
+    # As a reminder, the calling convention is my ( $self, $other, $swap ) = @_.
 
-    $other =~ s/(.+)[.]\z/$1/x;
+    my $me = uc ( $_[0]->{_string} // $_[0]->string );
 
-    return ( uc( "$self" ) cmp uc( $other ) );
+    # Treat undefined value as root
+    my $other = $_[1] // q{};
+
+    if ( blessed $other and $other->isa( 'Zonemaster::Engine::DNSName' ) ) {
+        return $me cmp uc( $other->{_string} // $other->string() );
+    }
+    else {
+        # Assume $other is a string; remove trailing dot except if only character
+        return $me cmp uc( $other =~ s/.\K [.] \z//xr );
+    }
 }
 
 sub next_higher {
@@ -183,7 +187,7 @@ A reference to a list of strings, being the labels the DNS name is made up from.
 
 =over
 
-=item new($input) _or_ new({ labels => \@labellist})
+=item new($input) _or_ new({ labels => \@labellist })
 
 The constructor can be called with either a single argument or with a reference
 to a hash as in the example above.

lib/Zonemaster/Engine/Nameserver.pm

@@ -57,8 +57,7 @@ our %address_repr_cache;
 ###
 
 sub new {
-    my $proto = shift;
-    my $class = ref $proto || $proto;
+    my $class = shift;
     my $attrs = shift;
 
     my %lazy_attrs;
@@ -74,21 +73,21 @@ sub new {
       if !blessed $attrs->{name} || !$attrs->{name}->isa( 'Zonemaster::Engine::DNSName' );
 
     my $name = lc( q{} . $attrs->{name} );
-    $name = '$$$NONAME' unless $name;
+    $name = '$$$NONAME' if $name eq q{};
 
     my $address;
 
     # Use a object cache for IP type coercion (don't parse IP unless it is needed)
     if (!blessed $attrs->{address} || !$attrs->{address}->isa( 'Net::IP::XS' )) {
         if (!exists $address_object_cache{$attrs->{address}}) {
             $address_object_cache{$attrs->{address}} = Net::IP::XS->new($attrs->{address});
-            $address_repr_cache{$attrs->{address}} = $address_object_cache{$attrs->{address}}->ip;
+            $address_repr_cache{$attrs->{address}} = $address_object_cache{$attrs->{address}}->short;
         }
         # Fetch IP object from the address cache (avoid object creation and method call)
         $address = $address_repr_cache{$attrs->{address}};
         $attrs->{address} = $address_object_cache{$attrs->{address}};
     } else {
-        $address = $attrs->{address}->ip;
+        $address = $attrs->{address}->short;
     }
 
     # Return Nameserver object as soon as possible
@@ -131,7 +130,9 @@ sub new {
     $obj->{_dns}             = $lazy_attrs{dns}             if exists $lazy_attrs{dns};
     $obj->{_cache}           = $lazy_attrs{cache}           if exists $lazy_attrs{cache};
 
-    Zonemaster::Engine->logger->add( NS_CREATED => { name => $name, ip => $obj->address->ip } );
+    $obj->{_string}          = $name . q{/} . $address;
+
+    Zonemaster::Engine->logger->add( NS_CREATED => { name => $name, ip => $address } );
     $object_cache{$name}{$address} = $obj;
 
     return $obj;
@@ -201,12 +202,15 @@ sub query {
     my ( $self, $name, $type, $href ) = @_;
     $type //= 'A';
 
-    if ( $self->address->version == 4 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv4} ) ) {
+    my $address = $self->address;
+    my $profile = Zonemaster::Engine::Profile->effective;
+
+    if ( $address->version == 4 and not $profile->get( q{net.ipv4} ) ) {
         Zonemaster::Engine->logger->add( IPV4_BLOCKED => { ns => $self->string } );
         return;
     }
 
-    if ( $self->address->version == 6 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv6} ) ) {
+    if ( $address->version == 6 and not $profile->get( q{net.ipv6} ) ) {
         Zonemaster::Engine->logger->add( IPV6_BLOCKED => { ns => $self->string } );
         return;
     }
@@ -217,14 +221,14 @@ sub query {
             name  => "$name",
             type  => $type,
             flags => $href,
-            ip    => $self->address->short
+            ip    => $address->short
         }
     );
 
     my $class     = $href->{class}     // 'IN';
     my $dnssec    = $href->{dnssec}    // 0;
-    my $usevc     = $href->{usevc}     // Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.usevc} );
-    my $recurse   = $href->{recurse}   // Zonemaster::Engine::Profile->effective->get( q{resolver.defaults.recurse} );
+    my $usevc     = $href->{usevc}     // $profile->get( q{resolver.defaults.usevc} );
+    my $recurse   = $href->{recurse}   // $profile->get( q{resolver.defaults.recurse} );
 
     if ( exists $href->{edns_details} and exists $href->{edns_details}{do} ) {
         $dnssec = $href->{edns_details}{do};
@@ -275,7 +279,7 @@ sub query {
             $p->qr( 1 );
             $p->do( $dnssec );
             $p->rd( $recurse );
-            $p->answerfrom( $self->address->ip );
+            $p->answerfrom( $address->ip );
 
             Zonemaster::Engine->logger->add( FAKE_DELEGATION_RETURNED => { name  => "$name", type  => $type, class => $class, from  => "$self" } );
 
@@ -287,18 +291,18 @@ sub query {
 
     my $md5 = Digest::MD5->new;
 
-    $md5->add( q{NAME}    , $name );
-    $md5->add( q{TYPE}    , "\U$type" );
-    $md5->add( q{CLASS}   , "\U$class" );
-    $md5->add( q{DNSSEC}  , $dnssec );
-    $md5->add( q{USEVC}   , $usevc );
-    $md5->add( q{RECURSE} , $recurse );
+    $md5->add( q{NAME}    , $name,
+               q{TYPE}    , "\U$type",
+               q{CLASS}   , "\U$class",
+               q{DNSSEC}  , $dnssec,
+               q{USEVC}   , $usevc,
+               q{RECURSE} , $recurse );
 
     if ( exists $href->{edns_details} ) {
-        $md5->add( q{EDNS_VERSION}        , $href->{edns_details}{version} // 0 );
-        $md5->add( q{EDNS_Z}              , $href->{edns_details}{z} // 0 );
-        $md5->add( q{EDNS_EXTENDED_RCODE} , $href->{edns_details}{rcode} // 0 );
-        $md5->add( q{EDNS_DATA}           , $href->{edns_details}{data} // q{} );
+        $md5->add( q{EDNS_VERSION}        , $href->{edns_details}{version} // 0,
+                   q{EDNS_Z}              , $href->{edns_details}{z} // 0,
+                   q{EDNS_EXTENDED_RCODE} , $href->{edns_details}{rcode} // 0,
+                   q{EDNS_DATA}           , $href->{edns_details}{data} // q{} );
         $edns_size = $href->{edns_details}{size} // ( $href->{edns_size} // ( $dnssec ? $EDNS_UDP_PAYLOAD_DNSSEC_DEFAULT : $EDNS_UDP_PAYLOAD_DEFAULT ) );
     }
 
@@ -308,7 +312,7 @@ sub query {
 
     my $idx = $md5->b64digest();
 
-    my ( $in_cache, $p) = $self->cache->get_key( $idx );
+    my ( $in_cache, $p ) = $self->cache->get_key( $idx );
     if ( not $in_cache ) {
         $p = $self->_query( $name, $type, $href );
         $self->cache->set_key( $idx, $p );
@@ -504,9 +508,7 @@ sub _query {
 } ## end sub _query
 
 sub string {
-    my ( $self ) = @_;
-
-    return $self->name->string . q{/} . $self->address->short;
+    return $_[0]->{_string};
 }
 
 sub compare {

lib/Zonemaster/Engine/Packet.pm

@@ -107,40 +107,42 @@ sub is_redirect {
 
 sub get_records {
     my ( $self, $type, @section ) = @_;
+    @section = qw(answer authority additional) if !@section;
     my %sec = map { lc( $_ ) => 1 } @section;
     my @raw;
-
-    if ( !@section ) {
-        @raw = ( $self->packet->answer, $self->packet->authority, $self->packet->additional );
-    }
+    $type = uc( $type );
 
     if ( $sec{'answer'} ) {
-        push @raw, $self->packet->answer;
+        push @raw, grep { $_->type eq $type } $self->packet->answer;
     }
 
     if ( $sec{'authority'} ) {
-        push @raw, $self->packet->authority;
+        push @raw, grep { $_->type eq $type } $self->packet->authority;
     }
 
     if ( $sec{'additional'} ) {
-        push @raw, $self->packet->additional;
+        push @raw, grep { $_->type eq $type } $self->packet->additional;
     }
 
-    @raw = grep { $_->type eq uc( $type ) } @raw;
-
     return @raw;
 } ## end sub get_records
 
 sub get_records_for_name {
     my ( $self, $type, $name, @section ) = @_;
 
-    return grep { name( $_->name ) eq name( $name ) } $self->get_records( $type, @section );
+    # Make sure $name is a Zonemaster::Engine::DNSName
+    $name = name( $name );
+
+    return grep { name( $_->name ) eq $name } $self->get_records( $type, @section );
 }
 
 sub has_rrs_of_type_for_name {
     my ( $self, $type, $name, @section ) = @_;
 
-    return ( grep { name( $_->name ) eq name( $name ) } $self->get_records( $type, @section ) ) > 0;
+    # Make sure $name is a Zonemaster::Engine::DNSName
+    $name = name( $name );
+
+    return ( grep { name( $_->name ) eq $name } $self->get_records( $type, @section ) ) > 0;
 }
 
 sub answerfrom {

lib/Zonemaster/Engine/TestMethodsV2.pm

@@ -7,6 +7,7 @@ use version; our $VERSION = version->declare("v1.0.0");
 
 use Carp;
 use List::MoreUtils qw[uniq];
+use Memoize;
 
 use Zonemaster::Engine::Util;
 
@@ -35,6 +36,8 @@ Takes a L<Zonemaster::Engine::Zone> object.
 
 Returns an arrayref of L<Zonemaster::Engine::Nameserver> objects, or C<undef> if no parent zone was found.
 
+The result of this Method is cached for performance reasons. This cache can be invalidated by calling C<clear_cache()> if necessary.
+
 =back
 
 =cut
@@ -64,8 +67,9 @@ sub get_parent_ns_ips {
 
         CUR_SERVERS:
         while ( my $ns = shift @remaining_servers ) {
-            next CUR_SERVERS if grep { $_ eq $ns->address->short } @{ $handled_servers{$zone_name} };
-            push @{ $handled_servers{$zone_name} }, $ns->address->short;
+            my $addr = $ns->address->short;
+            next CUR_SERVERS if grep { $_ eq $addr } @{ $handled_servers{$zone_name} };
+            push @{ $handled_servers{$zone_name} }, $addr;
 
             if ( ( $ns->address->version == 4 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv4} ) )
                 or ( $ns->address->version == 6 and not Zonemaster::Engine::Profile->effective->get( q{net.ipv6} ) ) ) {
@@ -249,6 +253,11 @@ sub get_parent_ns_ips {
     }
 }
 
+# Memoize get_parent_ns_ips() because it is expensive and gets called a few
+# times with identical parameters.
+
+memoize('get_parent_ns_ips');
+
 =over
 
 =item _get_oob_ips($zone, $ns_names_ref)
@@ -779,4 +788,19 @@ sub get_zone_ns_ips {
     return [ uniq sort @ns_ips ];
 }
 
-1;
+
+=over
+
+=item clear_cache()
+
+Clears previously cached results of the C<get_parent_ns_ips()> method.
+
+=back
+
+=cut
+
+sub clear_cache() {
+    Memoize::flush_cache(\&get_parent_ns_ips);
+}
+
+1;