view release on metacpan or  search on metacpan

lib/Mail/DMARC/Base.pm  view on Meta::CPAN

}

{
    my $public_suffixes;
    my $public_suffixes_stamp;

    sub get_public_suffix_list($self) {
        if ($public_suffixes) { return $public_suffixes; }
        no warnings 'once';    ## no critic
        $Mail::DMARC::psl_loads++;
        my $file = $self->find_psl_file();
        $public_suffixes_stamp = ( stat($file) )[9];

        open my $fh, '<:encoding(UTF-8)', $file
            or croak "unable to open $file for read: $!\n";

        # load PSL into hash for fast lookups, esp. for long running daemons
        my %psl = map { $_ => 1 }
            grep { $_ !~ /^[\/\s]/ }    # weed out comments & whitespace
            map  { chomp($_); $_ }      ## no critic, remove line endings
            <$fh>;
        close $fh;
        return $public_suffixes = \%psl;
    }

    sub check_public_suffix_list($self) {
        my $file                      = $self->find_psl_file();
        my $new_public_suffixes_stamp = ( stat($file) )[9];
        if ( $new_public_suffixes_stamp != $public_suffixes_stamp ) {
            $public_suffixes = undef;
            $self->get_public_suffix_list();
            return 1;
        }
        return 0;
    }
}

sub is_public_suffix( $self, $zone ) {
    croak "missing zone name!" if !$zone;

    my $public_suffixes = $self->get_public_suffix_list();

    $zone = URI::_idna::decode( $zone, 0 ) // $zone if $zone =~ /xn--/;

    # Check for exception rules
    return 0 if $public_suffixes->{"!$zone"};

    # Check for direct match
    return 1 if $public_suffixes->{$zone};

    # Check for wildcard match
    my @labels = split /\./, $zone;
    if ( @labels > 1 ) {
        my $wildcard = join '.', '*', (@labels)[ 1 .. scalar(@labels) - 1 ];
        return 1 if $public_suffixes->{$wildcard};
    }

    return 0;
}

sub update_psl_file( $self, $dryrun = undef ) {
    my $psl_file = $self->find_psl_file();

    die "No Public Suffix List file found\n"                  if ( !$psl_file );
    die "Public suffix list file $psl_file not found\n"       if ( !-f $psl_file );
    die "Cannot write to Public Suffix List file $psl_file\n" if ( !-w $psl_file );

    my $url = 'https://publicsuffix.org/list/effective_tld_names.dat';
    if ($dryrun) {
        print
            "Will attempt to update the Public Suffix List file at $psl_file (dryrun mode)\n";
        return;
    }

    my $response = HTTP::Tiny->new->mirror( $url, $psl_file );
    my $content  = $response->{'content'};
    if ( !$response->{'success'} ) {
        my $status = $response->{'status'};
        die
            "HTTP Request for Public Suffix List file failed with error $status ($content)\n";
    }
    else {
        if ( $response->{'status'} eq '304' ) {
            print "Public Suffix List file $psl_file not modified\n";
        }
        else {
            print "Public Suffix List file $psl_file updated\n";
        }
    }
    return;
}

sub find_psl_file($self) {
    my $file
        = $self->config->{dns}{public_suffix_list} || 'share/public_suffix_list';
    if ( $file =~ /^\// && -f $file && -r $file ) {
        print "using $file for Public Suffix List\n" if $self->verbose;
        return $file;
    }

    foreach my $path ( $self->get_prefix($file) ) {
        if ( -f $path && -r $path ) {
            print "using $path for Public Suffix List\n";    # if $self->verbose;
            return $path;
        }
    }

    # Fallback to included suffic list
    return $self->get_sharefile('public_suffix_list');
}

sub has_dns_rr( $self, $type, $domain ) {
    my @matches;
    my $res   = $self->get_resolver();
    my $query = $res->query( $domain, $type ) or do {
        return 0 if !wantarray;
        return @matches;
    };
    for my $rr ( $query->answer ) {
        next if $rr->type ne $type;
        push @matches,