—

              
package Mail::AuthenticationResults::Header::Base;
# ABSTRACT: Base class for modelling parts of the Authentication Results Header
require 5.008;
use strict;
use warnings;
our $VERSION = '2.20231031'; # VERSION
use Scalar::Util qw{ weaken refaddr };
use JSON;
use Carp;
use Clone qw{ clone };
use Mail::AuthenticationResults::Header::Group;
use Mail::AuthenticationResults::FoldableHeader;
sub _HAS_KEY{ return 0; }
sub _HAS_VALUE{ return 0; }
sub _HAS_CHILDREN{ return 0; }
sub _ALLOWED_CHILDREN{ # uncoverable subroutine
    # does not run in Base as HAS_CHILDREN returns 0
    return 0; # uncoverable statement
}
sub new {
    my ( $class ) = @_;
    my $self = {};
    bless $self, $class;
    return $self;
}
sub set_key {
    my ( $self, $key ) = @_;
    croak 'Does not have key' if ! $self->_HAS_KEY();
    croak 'Key cannot be undefined' if ! defined $key;
    croak 'Key cannot be empty' if $key eq q{};
    croak 'Invalid characters in key' if $key =~ /"/;
    croak 'Invalid characters in key' if $key =~ /\n/;
    croak 'Invalid characters in key' if $key =~ /\r/;
    $self->{ 'key' } = $key;
    return $self;
}
sub key {
    my ( $self ) = @_;
    croak 'Does not have key' if ! $self->_HAS_KEY();
    return q{} if ! defined $self->{ 'key' }; #5.8
    return $self->{ 'key' };
}
sub safe_set_value {
    my ( $self, $value ) = @_;
    $value = q{} if ! defined $value;
    $value =~ s/\t/ /g;
    $value =~ s/\n/ /g;
    $value =~ s/\r/ /g;
    $value =~ s/\(/ /g;
    $value =~ s/\)/ /g;
    $value =~ s/\\/ /g;
    $value =~ s/"/ /g;
    $value =~ s/;/ /g;
    $value =~ s/^\s+//;
    $value =~ s/\s+$//;
    #$value =~ s/ /_/g;
    $self->set_value( $value );
    return $self;
}
sub set_value {
    my ( $self, $value ) = @_;
    croak 'Does not have value' if ! $self->_HAS_VALUE();
    croak 'Value cannot be undefined' if ! defined $value;
    #croak 'Value cannot be empty' if $value eq q{};
    croak 'Invalid characters in value' if $value =~ /"/;
    croak 'Invalid characters in value' if $value =~ /\n/;
    croak 'Invalid characters in value' if $value =~ /\r/;
    $self->{ 'value' } = $value;
    return $self;
}
sub value {
    my ( $self ) = @_;
    croak 'Does not have value' if ! $self->_HAS_VALUE();
    return q{} if ! defined $self->{ 'value' }; # 5.8
    return $self->{ 'value' };
}
sub stringify {
    my ( $self, $value ) = @_;
    my $string = $value;
    $string = q{} if ! defined $string; #5.8;
    my $strict_quotes = $self->strict_quotes;
    if (  (  $strict_quotes && $string =~ /[\s\t \(\);=<>@,:\\\/\[\]\?]/ )
       || ( !$strict_quotes && $string =~ /[\s\t \(\);=]/ ) ) {
        $string = '"' . $string . '"';
    }
    return $string;
}
sub children {
    my ( $self ) = @_;
    croak 'Does not have children' if ! $self->_HAS_CHILDREN();
    return [] if ! defined $self->{ 'children' }; #5.8
    return $self->{ 'children' };
}
sub orphan {
    my ( $self, $parent ) = @_;
    croak 'Child does not have a parent' if ! exists $self->{ 'parent' };
    delete $self->{ 'parent' };
    return;
}
sub copy_children_from {
  my ( $self, $object ) = @_;
  for my $original_entry (@{$object->children()}) {
    my $entry = clone $original_entry;
    $entry->orphan if exists $entry->{ 'parent' };;
    $self->add_child( $entry );
  }
}
sub add_parent {
    my ( $self, $parent ) = @_;
    return if ( ref $parent eq 'Mail::AuthenticationResults::Header::Group' );
    croak 'Child already has a parent' if exists $self->{ 'parent' };
    croak 'Cannot add parent' if ! $parent->_ALLOWED_CHILDREN( $self ); # uncoverable branch true
    # Does not run as test is also done in add_child before add_parent is called.
    $self->{ 'parent' } = $parent;
    weaken $self->{ 'parent' };
    return;
}
sub parent {
    my ( $self ) = @_;
    return $self->{ 'parent' };
}
sub remove_child {
    my ( $self, $child ) = @_;
    croak 'Does not have children' if ! $self->_HAS_CHILDREN();
    croak 'Cannot add child' if ! $self->_ALLOWED_CHILDREN( $child );
    croak 'Cannot add a class as its own parent' if refaddr $self == refaddr $child; # uncoverable branch true
    # Does not run as there are no ALLOWED_CHILDREN results which permit this
    my @children;
    my $child_removed = 0;
    foreach my $mychild ( @{ $self->{ 'children' } } ) {
        if ( refaddr $child == refaddr $mychild ) {
            if ( ref $self ne 'Mail::AuthenticationResults::Header::Group' ) {
                $child->orphan();
            }
            $child_removed = 1;
        }
        else {
            push @children, $mychild;
        }
    }
    my $children = $self->{ 'children' };
    croak 'Not a child of this class' if ! $child_removed;
    $self->{ 'children' } = \@children;
    return $self;
}
sub add_child {
    my ( $self, $child ) = @_;
    croak 'Does not have children' if ! $self->_HAS_CHILDREN();
    croak 'Cannot add child' if ! $self->_ALLOWED_CHILDREN( $child );
    croak 'Cannot add a class as its own parent' if refaddr $self == refaddr $child; # uncoverable branch true
    # Does not run as there are no ALLOWED_CHILDREN results which permit this
    $child->add_parent( $self );
    push @{ $self->{ 'children' } }, $child;
    return $child;
}
sub ancestor {
    my ( $self ) = @_;
    my $depth = 0;
    my $ancestor = $self->parent();
    my $eldest = $self;
    while ( defined $ancestor ) {
        $eldest = $ancestor;
        $ancestor = $ancestor->parent();
        $depth++;
    }
    return ( $eldest, $depth );
}
sub strict_quotes {
    my ( $self ) = @_;
    return $self->{ 'strict_quotes' } if defined $self->{ 'strict_quotes' };
    my ( $eldest, $depth ) = $self->ancestor();
    return 0 if $depth == 0;
    return $eldest->strict_quotes;
}
sub set_strict_quotes {
    my ( $self, $value ) = @_;
    $self->{ 'strict_quotes' } = $value ? 1 : 0;
    return $self;
}
sub as_string_prefix {
    my ( $self, $header ) = @_;
    my ( $eldest, $depth ) = $self->ancestor();
    my $indents = 1;
    if ( $eldest->can( 'indent_by' ) ) {
        $indents = $eldest->indent_by();
    }
    my $eol = "\n";
    if ( $eldest->can( 'eol' ) ) {
        $eol = $eldest->eol();
    }
    my $indent = ' ';
    my $added = 0;
    if ( $eldest->can( 'indent_on' ) ) {
        if ( $eldest->indent_on( ref $self ) ) {
            $header->space( $eol );
            $header->space( ' ' x ( $indents * $depth ) );
            $added = 1;
        }
    }
    $header->space( ' ' ) if ! $added;
    return $indent;
}
sub _as_hashref {
    my ( $self ) = @_;
    my $type = lc ref $self;
    $type =~ s/^(.*::)//;
    my $hashref = { 'type' => $type };
    $hashref->{'key'} = $self->key() if $self->_HAS_KEY();
    $hashref->{'value'} = $self->value() if $self->_HAS_VALUE();
    if ( $self->_HAS_CHILDREN() ) {
        my @children = map { $_->_as_hashref() } @{ $self->children() };
        $hashref->{'children'} = \@children;
    }
    return $hashref;
}
sub as_json {
    my ( $self ) = @_;
    my $J = JSON->new();
    $J->canonical();
    return $J->encode( $self->_as_hashref() );
}
sub as_string {
    my ( $self ) = @_;
    my $header = Mail::AuthenticationResults::FoldableHeader->new();
    $self->build_string( $header );
    return $header->as_string();
}
sub build_string {
    my ( $self, $header ) = @_;
    if ( ! $self->key() ) {
        return;
    }
    $header->string( $self->stringify( $self->key() ) );
    if ( $self->value() ) {
        $header->assignment( '=' );
        $header->string( $self->stringify( $self->value() ) );
    }
    elsif ( $self->value() eq '0' ) {
        $header->assignment( '=' );
        $header->string( '0' );
    }
    elsif ( $self->value() eq q{} ) {
        # special case none here
        if ( $self->key() ne 'none' ) {
            $header->assignment( '=' );
            $header->string( '""' );
        }
    }
    if ( $self->_HAS_CHILDREN() ) { # uncoverable branch false
        # There are no classes which run this code without having children
        foreach my $child ( @{$self->children()} ) {
            $child->as_string_prefix( $header );
            $child->build_string( $header );
        }
    }
    return;
}
sub search {
    my ( $self, $search ) = @_;
    my $group = Mail::AuthenticationResults::Header::Group->new();
    my $match = 1;
    if ( exists( $search->{ 'key' } ) ) {
        if ( $self->_HAS_KEY() ) {
            if ( ref $search->{ 'key' } eq 'Regexp' && $self->key() =~ m/$search->{'key'}/ ) {
                $match = $match && 1; # uncoverable statement
                # $match is always 1 at this point, left this way for consistency
            }
            elsif ( lc $search->{ 'key' } eq lc $self->key() ) {
                $match = $match && 1; # uncoverable statement
                # $match is always 1 at this point, left this way for consistency
            }
            else {
                $match = 0;
            }
        }
        else {
            $match = 0;
        }
    }
    if ( exists( $search->{ 'value' } ) ) {
        $search->{ 'value' } = '' if ! defined $search->{ 'value' };
        if ( $self->_HAS_VALUE() ) {
            if ( ref $search->{ 'value' } eq 'Regexp' && $self->value() =~ m/$search->{'value'}/ ) {
                $match = $match && 1;
            }
            elsif ( lc $search->{ 'value' } eq lc $self->value() ) {
                $match = $match && 1;
            }
            else {
                $match = 0;
            }
        }
        else {
            $match = 0; # uncoverable statement
            # There are no code paths with the current classes which end up here
        }
    }
    if ( exists( $search->{ 'authserv_id' } ) ) {
        if ( $self->_HAS_VALUE() ) {
            if ( lc ref $self eq 'mail::authenticationresults::header' ) {
                my $authserv_id = eval{ $self->value()->value() } || q{};
                if ( ref $search->{ 'authserv_id' } eq 'Regexp' && $authserv_id =~ m/$search->{'authserv_id'}/ ) {
                    $match = $match && 1;
                }
                elsif ( lc $search->{ 'authserv_id' } eq lc $authserv_id ) {
                    $match = $match && 1;
                }
                else {
                    $match = 0;
                }
            }
            else {
                $match = 0;
            }
        }
        else {
            $match = 0; # uncoverable statement
            # There are no code paths with the current classes which end up here
        }
    }
    if ( exists( $search->{ 'isa' } ) ) {
        if ( lc ref $self eq 'mail::authenticationresults::header::' . lc $search->{ 'isa' } ) {
            $match = $match && 1;
        }
        elsif ( lc ref $self eq 'mail::authenticationresults::header' && lc $search->{ 'isa' } eq 'header' ) {
            $match = $match && 1;
        }
        else {
            $match = 0;
        }
    }
    if ( exists( $search->{ 'has' } ) ) {
        foreach my $query ( @{ $search->{ 'has' } } ) {
            $match = 0 if ( scalar @{ $self->search( $query )->children() } == 0 );
        }
    }
    if ( $match ) {
        $group->add_child( $self );
    }
    if ( $self->_HAS_CHILDREN() ) {
        foreach my $child ( @{$self->children()} ) {
            my $childfound = $child->search( $search );
            if ( scalar @{ $childfound->children() } ) {
                $group->add_child( $childfound );
            }
        }
    }
    return $group;
}
1;
__END__
HideShow 229 lines of Pod
=pod
=encoding UTF-8
=head1 NAME
Mail::AuthenticationResults::Header::Base - Base class for modelling parts of the Authentication Results Header
=head1 VERSION
version 2.20231031
=head1 DESCRIPTION
Set of classes representing the various parts and sub parts of Authentication Results Headers.
=over
=item *
L<Mail::AuthenticationResults::Header> represents a complete Authentication Results Header set
=item * 
L<Mail::AuthenticationResults::Header::AuthServID> represents the AuthServID part of the set
=item * 
L<Mail::AuthenticationResults::Header::Comment> represents a comment
=item * 
L<Mail::AuthenticationResults::Header::Entry> represents a main entry
=item * 
L<Mail::AuthenticationResults::Header::Group> represents a group of parts, typically as a search result
=item * 
L<Mail::AuthenticationResults::Header::SubEntry> represents a sub entry part
=item * 
L<Mail::AuthenticationResults::Header::Version> represents a version part
=back
    Header
        AuthServID
            Version
            Comment
            SubEntry
        Entry
            Comment
        Entry
            Comment
            SubEntry
                Comment
        Entry
            SubEntry
            SubEntry
    Group
        Entry
            Comment
        SubEntry
            Comment
        Entry
            SubEntry
=head1 METHODS
=head2 new()
Return a new instance of this class
=head2 set_key( $key )
Set the key for this instance.
Croaks if $key is invalid.
=head2 key()
Return the current key for this instance.
Croaks if this instance type can not have a key.
=head2 safe_set_value( $value )
Set the value for this instance.
Munges the value to remove invalid characters before setting.
This method also removes some value characters when their inclusion
would be likely to break simple parsers.
=head2 set_value( $value )
Set the value for this instance.
Croaks if the value contains invalid characters.
=head2 value()
Returns the current value for this instance.
=head2 stringify( $value )
Returns $value with stringify rules applied.
=head2 children()
Returns a listref of this instances children.
Croaks if this instance type can not have children.
=head2 orphan()
Removes the parent for this instance.
Croaks if this instance does not have a parent.
=head2 copy_children_from( $object )
Copy (clone) all of the children from the given object
into this object.
=head2 add_parent( $parent )
Sets the parent for this instance to the supplied object.
Croaks if the relationship between $parent and $self is not valid.
=head2 parent()
Returns the parent object for this instance.
=head2 remove_child( $child )
Removes $child as a child of this instance.
Croaks if the relationship between $child and $self is not valid.
=head2 add_child( $child )
Adds $child as a child of this instance.
Croaks if the relationship between $child and $self is not valid.
=head2 ancestor()
Returns the top Header object and depth of this child
=head2 strict_quotes()
Return the current value of strict quotes flag for this header or for its
ancestor if not set locally
If true, we are stricter about which characters result in a quoted string
=head2 set_strict_quotes( $value )
Set the value of strict quotes
If true, we are stricter about which characters result in a quoted string
Default false
=head2 as_string_prefix( $header )
Add the prefix to as_string for this object when calledas a child
of another objects as_string method call.
=head2 as_json()
Return this instance as a JSON serialised string
=head2 as_string()
Returns this instance as a string.
=head2 build_string( $header )
Build a string using the supplied Mail::AuthenticationResults::FoldableHeader object.
=head2 search( $search )
Apply search rules in $search to this instance and return a
Mail::AuthenticationResults::Header::Group object containing the matches.
$search is a HASHREF with the following possible key/value pairs
=over
=item key
Match if the instance key matches the supplied value (string or regex)
=item value
Match if the instance value matches the supplied value (string or regex)
=item isa
Match is the instance class typs matches the supplied value. This is a lowercase version
of the class type, (comment,entry,subentry,etc))
=item has
An arrayref of searches, match this class if the supplied search queries would return at
least 1 result each
=back
=head1 AUTHOR
Marc Bradshaw <marc@marcbradshaw.net>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2021 by Marc Bradshaw.
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