view release on metacpan or  search on metacpan

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

    }

    return Socket6::inet_pton( AF_INET, $ip_txt )
        || croak "invalid IPv4: $ip_txt";
}

{
    my $public_suffixes;
    my $public_suffixes_stamp;

    sub get_public_suffix_list {
        my ( $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 {
        my ( $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 {
    my ( $self, $zone ) = @_;

    croak "missing zone name!" if !$zone;

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

    $zone = domain_to_unicode( $zone ) if $zone =~ /xn--/;

    return 1 if $public_suffixes->{$zone};

    my @labels = split /\./, $zone;
    $zone = join '.', '*', (@labels)[ 1 .. scalar(@labels) - 1 ];

    return 1 if $public_suffixes->{$zone};
    return 0;
}

sub update_psl_file {
    my ($self, $dryrun) = @_;

    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 {
    my ($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 {
    my ( $self, $type, $domain ) = @_;

    my @matches;
    my $res     = $self->get_resolver();
    my $query   = $res->query( $domain, $type ) or do {
        return 0 if ! wantarray;
        return @matches;
    };