├── .envrc ├── shell.nix ├── .autom4te.cfg ├── sample-etc_systemd.service ├── .gitignore ├── sample-etc_dhclient-exit-hooks ├── sample-etc_dhcpc_dhcpcd-eth0.exe ├── sample-ddclient-wrapper.sh ├── sample-etc_cron.d_ddclient ├── autogen ├── t ├── lib │ ├── ddclient │ │ ├── t │ │ │ ├── ip.pm │ │ │ └── Logger.pm │ │ └── Test │ │ │ └── Fake │ │ │ └── HTTPD │ │ │ ├── dummy-server-key.pem │ │ │ ├── other-ca-cert.pem │ │ │ └── dummy-ca-cert.pem │ ├── Test │ │ ├── Tester │ │ │ ├── Delegate.pm │ │ │ ├── CaptureRunner.pm │ │ │ └── Capture.pm │ │ ├── Builder │ │ │ ├── Tester │ │ │ │ └── Color.pm │ │ │ ├── TodoDiag.pm │ │ │ ├── Formatter.pm │ │ │ └── Module.pm │ │ └── use │ │ │ └── ok.pm │ ├── Test2 │ │ ├── Hub │ │ │ ├── Interceptor │ │ │ │ └── Terminator.pm │ │ │ ├── Interceptor.pm │ │ │ └── Subtest.pm │ │ ├── Util │ │ │ ├── Trace.pm │ │ │ └── ExternalMeta.pm │ │ ├── Event │ │ │ ├── Waiting.pm │ │ │ ├── Note.pm │ │ │ ├── Diag.pm │ │ │ ├── Encoding.pm │ │ │ ├── TAP │ │ │ │ └── Version.pm │ │ │ ├── Bail.pm │ │ │ ├── Exception.pm │ │ │ ├── Pass.pm │ │ │ ├── Fail.pm │ │ │ ├── Skip.pm │ │ │ ├── Ok.pm │ │ │ ├── Subtest.pm │ │ │ └── Plan.pm │ │ ├── EventFacet │ │ │ ├── About.pm │ │ │ ├── Amnesty.pm │ │ │ ├── Assert.pm │ │ │ ├── Parent.pm │ │ │ ├── Error.pm │ │ │ ├── Plan.pm │ │ │ ├── Meta.pm │ │ │ ├── Hub.pm │ │ │ ├── Control.pm │ │ │ ├── Render.pm │ │ │ ├── Info │ │ │ │ └── Table.pm │ │ │ └── Info.pm │ │ ├── EventFacet.pm │ │ ├── IPC.pm │ │ ├── Formatter.pm │ │ └── API │ │ │ ├── Breakage.pm │ │ │ └── Stack.pm │ ├── ok.pm │ └── Devel │ │ └── Autoflush.pm ├── geturl_response.pl ├── use_cmd.pl ├── check_value.pl ├── interval_expired.pl ├── write_recap.pl ├── version.pl.in ├── header_ok.pl ├── geturl_connectivity.pl ├── is-and-extract-ipv4.pl ├── is-and-extract-ipv6-global.pl ├── get_ip_from_if.pl ├── use_web.pl ├── parse_assignments.pl ├── variable_defaults.pl ├── group_hosts_by.pl ├── read_recap.pl ├── ssl-validate.pl ├── skip.pl └── logmsg.pl ├── COPYRIGHT ├── sample-get-ip-from-fritzbox ├── README.cisco ├── sample-etc_ppp_ip-up.local ├── .github └── workflows │ ├── pr.yml │ ├── scripts │ └── dist-tarball-check │ └── ci.yml ├── docs └── ProviderGuidelines.md ├── configure.ac └── Makefile.am /.envrc: -------------------------------------------------------------------------------- 1 | if has lorri; then 2 | eval "$(lorri direnv)" 3 | else 4 | use nix 5 | fi 6 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import { } }: 2 | 3 | with pkgs; 4 | 5 | mkShellNoCC { 6 | buildInputs = [ 7 | autoconf 8 | automake 9 | gnumake 10 | ]; 11 | } 12 | -------------------------------------------------------------------------------- /.autom4te.cfg: -------------------------------------------------------------------------------- 1 | # Disable autom4te cache to ensure that any change to ddclient.in triggers a 2 | # rebuild of the configure script (which gets the version of ddclient from 3 | # ddclient.in). See . 4 | begin-language: "Autoconf-without-aclocal-m4" 5 | args: --no-cache 6 | end-language: "Autoconf-without-aclocal-m4" 7 | -------------------------------------------------------------------------------- /sample-etc_systemd.service: -------------------------------------------------------------------------------- 1 | [Unit] 2 | Description=Dynamic DNS Update Client 3 | Wants=network-online.target 4 | After=network-online.target nss-lookup.target 5 | 6 | [Service] 7 | Type=exec 8 | Environment=daemon_interval=5m 9 | ExecStart=/usr/bin/ddclient --daemon ${daemon_interval} --foreground 10 | Restart=on-failure 11 | 12 | [Install] 13 | WantedBy=multi-user.target 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | patches 2 | release 3 | .svn 4 | .cvsignore 5 | *~ 6 | /Makefile 7 | /Makefile.in 8 | /aclocal.m4 9 | /autom4te.cache/ 10 | /build-aux/config.guess 11 | /build-aux/config.sub 12 | /build-aux/install-sh 13 | /build-aux/missing 14 | /build-aux/tap-driver.sh 15 | /config.log 16 | /config.status 17 | /configure 18 | /ddclient 19 | /ddclient-*.tar.gz 20 | /ddclient.conf 21 | /t/*.log 22 | /t/*.trs 23 | /t/geturl_connectivity.pl 24 | /t/version.pl 25 | /test-suite.log 26 | -------------------------------------------------------------------------------- /sample-etc_dhclient-exit-hooks: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ###################################################################### 3 | # The /etc/dhclient-enter-hooks script is run by the ISC DHCP client's standard 4 | # update script whenever dhclient obtains or renews an address. 5 | 6 | PATH=/usr/bin:${PATH} 7 | case "$new_ip_address" in 8 | 10.*) ;; 9 | 172.1[6-9].* | 172.2[0-9].* | 172.3[0-1].*) ;; 10 | 192.168.*) ;; 11 | *) 12 | logger -t dhclient IP address changed to $new_ip_address 13 | ddclient -daemon=0 -syslog -use=ip -ip=$new_ip_address >/dev/null 2>&1 14 | ;; 15 | esac 16 | -------------------------------------------------------------------------------- /sample-etc_dhcpc_dhcpcd-eth0.exe: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ###################################################################### 3 | PATH=/usr/bin:${PATH} 4 | 5 | ## update the DNS server unless the IP address is a private address 6 | ## that may be used as an internal LAN address. This may be true if 7 | ## other interfaces are assigned private addresses from internal 8 | ## DHCP server. 9 | 10 | case "$1" in 11 | 10.*) ;; 12 | 172.1[6-9].* | 172.2[0-9].* | 172.3[0-1].*) ;; 13 | 192.168.*) ;; 14 | *) 15 | logger -t dhcpcd IP address changed to $1 16 | ddclient -daemon=0 -syslog -use=ip -ip=$1 >/dev/null 2>&1 17 | ;; 18 | esac 19 | -------------------------------------------------------------------------------- /sample-ddclient-wrapper.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # This wrapper should be usefull for people who want to run a postscript with 4 | # multiple arguments. Currently ddclient has a feature which doesn't allow 5 | # multiple arguments. 6 | # This example has been written to be able to update multiple domains with 7 | # multiple login. It expects a /etc/ddclient/ddclient-domain2.conf with the 8 | # configuration of the extra domain 9 | 10 | # the second domain who has to be updated 11 | : ${SECONDCONFIG:=/etc/ddclient/ddclient-domain2.conf} 12 | # ddclient adds the new IP as argument 13 | IP=$1 14 | 15 | ddclient -ip ${IP} -file ${SECONDCONFIG} -daemon 0 16 | -------------------------------------------------------------------------------- /sample-etc_cron.d_ddclient: -------------------------------------------------------------------------------- 1 | ###################################################################### 2 | ## ddclient is an IP address updater for www.dyndns.org 3 | ###################################################################### 4 | ## minute 0-59 5 | ## hour 0-23 6 | ## day of month 1-31 7 | ## month 1-12 (or names, see below) 8 | ## day of week 0-7 (0 or 7 is Sun, or use names) 9 | ###################################################################### 10 | ## force an update twice a month (only if you are not using daemon-mode) 11 | ## 12 | ## 30 23 1,15 * * root /usr/bin/ddclient -daemon=0 -syslog -quiet -force 13 | -------------------------------------------------------------------------------- /autogen: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | pecho() { printf %s\\n "$*"; } 4 | log() { pecho "$@"; } 5 | error() { log "ERROR: $@" >&2; } 6 | fatal() { error "$@"; exit 1; } 7 | try() { "$@" || fatal "'$@' failed"; } 8 | 9 | try cd "${0%/*}" 10 | # aclocal complains if a directory passed to AC_CONFIG_MACRO_DIR doesn't exist. 11 | try mkdir -p build-aux/m4 12 | # autoreconf's '--force' option doesn't affect any of the files installed by the '--install' option. 13 | # Remove the files to truly force them to be updated. 14 | try rm -f \ 15 | aclocal.m4 \ 16 | build-aux/config.guess \ 17 | build-aux/config.sub \ 18 | build-aux/install-sh \ 19 | build-aux/missing \ 20 | build-aux/tap-driver.sh \ 21 | ; 22 | try autoreconf -fviW all 23 | -------------------------------------------------------------------------------- /t/lib/ddclient/t/ip.pm: -------------------------------------------------------------------------------- 1 | package ddclient::t::ip; 2 | 3 | use v5.10.1; 4 | use strict; 5 | use warnings; 6 | use Exporter qw(import); 7 | use Test::More; 8 | 9 | our @EXPORT = qw(ipv6_ok ipv6_required $ipv6_supported $ipv6_support_error); 10 | 11 | our $ipv6_support_error; 12 | our $ipv6_supported = eval { 13 | require IO::Socket::IP; 14 | my $ipv6_socket = IO::Socket::IP->new( 15 | Domain => 'PF_INET6', 16 | LocalHost => '::1', 17 | Listen => 1, 18 | ); 19 | defined($ipv6_socket); 20 | } or $ipv6_support_error = $@; 21 | 22 | sub ipv6_ok { 23 | ok($ipv6_supported, "system supports IPv6") or diag($ipv6_support_error); 24 | } 25 | 26 | sub ipv6_required { 27 | plan(skip_all => $ipv6_support_error) if !$ipv6_supported; 28 | } 29 | 30 | 1; 31 | -------------------------------------------------------------------------------- /t/lib/Test/Tester/Delegate.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package Test::Tester::Delegate; 5 | 6 | our $VERSION = '1.302175'; 7 | 8 | use Scalar::Util(); 9 | 10 | use vars '$AUTOLOAD'; 11 | 12 | sub new 13 | { 14 | my $pkg = shift; 15 | 16 | my $obj = shift; 17 | my $self = bless {}, $pkg; 18 | 19 | return $self; 20 | } 21 | 22 | sub AUTOLOAD 23 | { 24 | my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/; 25 | 26 | return if $sub eq "DESTROY"; 27 | 28 | my $obj = $_[0]->{Object}; 29 | 30 | my $ref = $obj->can($sub); 31 | shift(@_); 32 | unshift(@_, $obj); 33 | goto &$ref; 34 | } 35 | 36 | sub can { 37 | my $this = shift; 38 | my ($sub) = @_; 39 | 40 | return $this->{Object}->can($sub) if Scalar::Util::blessed($this); 41 | 42 | return $this->SUPER::can(@_); 43 | } 44 | 45 | 1; 46 | -------------------------------------------------------------------------------- /COPYRIGHT: -------------------------------------------------------------------------------- 1 | ddclient - update client for www.dyndns.org accounts 2 | 3 | Copyright (C) 1999 Paul Burry (paul@burry.ca) 4 | Copyright (C) 2000 Paul Burry (paul@burry.ca) 5 | Copyright (C) 2001 Paul Burry (paul@burry.ca) 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | -------------------------------------------------------------------------------- /t/lib/Test2/Hub/Interceptor/Terminator.pm: -------------------------------------------------------------------------------- 1 | package Test2::Hub::Interceptor::Terminator; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | 1; 9 | 10 | __END__ 11 | 12 | =pod 13 | 14 | =encoding UTF-8 15 | 16 | =head1 NAME 17 | 18 | Test2::Hub::Interceptor::Terminator - Exception class used by 19 | Test2::Hub::Interceptor 20 | 21 | =head1 SOURCE 22 | 23 | The source code repository for Test2 can be found at 24 | F. 25 | 26 | =head1 MAINTAINERS 27 | 28 | =over 4 29 | 30 | =item Chad Granum Eexodist@cpan.orgE 31 | 32 | =back 33 | 34 | =head1 AUTHORS 35 | 36 | =over 4 37 | 38 | =item Chad Granum Eexodist@cpan.orgE 39 | 40 | =back 41 | 42 | =head1 COPYRIGHT 43 | 44 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 45 | 46 | This program is free software; you can redistribute it and/or 47 | modify it under the same terms as Perl itself. 48 | 49 | See F 50 | 51 | =cut 52 | -------------------------------------------------------------------------------- /t/lib/ddclient/t/Logger.pm: -------------------------------------------------------------------------------- 1 | package ddclient::t::Logger; 2 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 3 | use parent qw(-norequire ddclient::Logger); 4 | 5 | { 6 | package ddclient::t::LoggerAbort; 7 | use overload '""' => qw(stringify); 8 | sub new { 9 | my ($class, %args) = @_; 10 | return bless(\%args, $class); 11 | } 12 | sub stringify { 13 | return 'logged a FATAL message'; 14 | } 15 | } 16 | 17 | sub new { 18 | my ($class, $parent, $labelre) = @_; 19 | my $self = $class->SUPER::new(undef, $parent); 20 | $self->{logs} = []; 21 | $self->{_labelre} = $labelre; 22 | return $self; 23 | } 24 | 25 | sub _log { 26 | my ($self, $args) = @_; 27 | my $lre = $self->{_labelre}; 28 | my $lbl = $args->{label}; 29 | push(@{$self->{logs}}, $args) if !defined($lre) || (defined($lbl) && $lbl =~ $lre); 30 | return $self->SUPER::_log($args); 31 | } 32 | 33 | sub _abort { 34 | my ($self) = @_; 35 | push(@{$self->{logs}}, 'aborted'); 36 | die(ddclient::t::LoggerAbort->new()); 37 | } 38 | 39 | 1; 40 | -------------------------------------------------------------------------------- /t/lib/Test2/Util/Trace.pm: -------------------------------------------------------------------------------- 1 | package Test2::Util::Trace; 2 | require Test2::EventFacet::Trace; 3 | @ISA = ('Test2::EventFacet::Trace'); 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 1; 8 | 9 | __END__ 10 | 11 | =pod 12 | 13 | =encoding UTF-8 14 | 15 | =head1 NAME 16 | 17 | Test2::Util::Trace - Legacy wrapper fro L. 18 | 19 | =head1 DESCRIPTION 20 | 21 | All the functionality for this class has been moved to 22 | L. 23 | 24 | =head1 SOURCE 25 | 26 | The source code repository for Test2 can be found at 27 | F. 28 | 29 | =head1 MAINTAINERS 30 | 31 | =over 4 32 | 33 | =item Chad Granum Eexodist@cpan.orgE 34 | 35 | =back 36 | 37 | =head1 AUTHORS 38 | 39 | =over 4 40 | 41 | =item Chad Granum Eexodist@cpan.orgE 42 | 43 | =back 44 | 45 | =head1 COPYRIGHT 46 | 47 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 48 | 49 | This program is free software; you can redistribute it and/or 50 | modify it under the same terms as Perl itself. 51 | 52 | See F 53 | 54 | =cut 55 | -------------------------------------------------------------------------------- /sample-get-ip-from-fritzbox: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | # Script to fetch IP from fritzbox 4 | # 5 | # Contributed by @Rusk85 in request #45 6 | # Script can be used in the configuration by adding 7 | # 8 | # use=cmd, cmd=/etc/ddclient/get-ip-from-fritzbox 9 | # 10 | # All credits for this one liner go to the author of this blog: 11 | # http://scytale.name/blog/2010/01/fritzbox-wan-ip 12 | # Disclaimer: It might be necessary to make the script executable 13 | 14 | # Set default hostname to connect to the FritzBox 15 | : ${FRITZ_BOX_HOSTNAME:=fritz.box} 16 | 17 | curl -s -H 'Content-Type: text/xml; charset="utf-8"' \ 18 | -H 'SOAPAction: urn:schemas-upnp-org:service:WANIPConnection:1#GetExternalIPAddress' \ 19 | -d ' ' \ 20 | "http://$FRITZ_BOX_HOSTNAME:49000/igdupnp/control/WANIPConn1" | \ 21 | grep -Eo '\<[[:digit:]]{1,3}(\.[[:digit:]]{1,3}){3}\>' 22 | -------------------------------------------------------------------------------- /t/lib/ok.pm: -------------------------------------------------------------------------------- 1 | package ok; 2 | our $VERSION = '1.302175'; 3 | 4 | use strict; 5 | use Test::More (); 6 | 7 | sub import { 8 | shift; 9 | 10 | if (@_) { 11 | goto &Test::More::pass if $_[0] eq 'ok'; 12 | goto &Test::More::use_ok; 13 | } 14 | 15 | # No argument list - croak as if we are prototyped like use_ok() 16 | my (undef, $file, $line) = caller(); 17 | ($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n"; 18 | } 19 | 20 | 21 | __END__ 22 | 23 | =encoding UTF-8 24 | 25 | =head1 NAME 26 | 27 | ok - Alternative to Test::More::use_ok 28 | 29 | =head1 SYNOPSIS 30 | 31 | use ok 'Some::Module'; 32 | 33 | =head1 DESCRIPTION 34 | 35 | With this module, simply change all C in test scripts to C, 36 | and they will be executed at C time. 37 | 38 | Please see L for the full description. 39 | 40 | =head1 CC0 1.0 Universal 41 | 42 | To the extent possible under law, 唐鳳 has waived all copyright and related 43 | or neighboring rights to L. 44 | 45 | This work is published from Taiwan. 46 | 47 | L 48 | 49 | =cut 50 | -------------------------------------------------------------------------------- /t/lib/Test/Builder/Tester/Color.pm: -------------------------------------------------------------------------------- 1 | package Test::Builder::Tester::Color; 2 | 3 | use strict; 4 | our $VERSION = '1.302175'; 5 | 6 | require Test::Builder::Tester; 7 | 8 | 9 | =head1 NAME 10 | 11 | Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester 12 | 13 | =head1 SYNOPSIS 14 | 15 | When running a test script 16 | 17 | perl -MTest::Builder::Tester::Color test.t 18 | 19 | =head1 DESCRIPTION 20 | 21 | Importing this module causes the subroutine color in Test::Builder::Tester 22 | to be called with a true value causing colour highlighting to be turned 23 | on in debug output. 24 | 25 | The sole purpose of this module is to enable colour highlighting 26 | from the command line. 27 | 28 | =cut 29 | 30 | sub import { 31 | Test::Builder::Tester::color(1); 32 | } 33 | 34 | =head1 AUTHOR 35 | 36 | Copyright Mark Fowler Emark@twoshortplanks.comE 2002. 37 | 38 | This program is free software; you can redistribute it 39 | and/or modify it under the same terms as Perl itself. 40 | 41 | =head1 BUGS 42 | 43 | This module will have no effect unless Term::ANSIColor is installed. 44 | 45 | =head1 SEE ALSO 46 | 47 | L, L 48 | 49 | =cut 50 | 51 | 1; 52 | -------------------------------------------------------------------------------- /README.cisco: -------------------------------------------------------------------------------- 1 | Method 1 ------------------------------------------------------ 2 | 3 | The following config will allow the Linux machine (10.1.1.2) to read 4 | the IP address from the DHCP interface on the Cisco router (eth0) as 5 | user ddclient. Since ddclient is configured with a priv level of 1 it 6 | cannot do anything except look at the routers stats, ip addresses, 7 | etc. This should be pretty harmless even if ddclient's password were 8 | to be discovered. 9 | 10 | This has been tested with Cisco IOS 12.1(5)T5 running on a Cisco 2621 11 | router. 12 | 13 | Cisco Router Config (Assuming eth0 is DHCP interface) 14 | ----------------------------------------------------- 15 | user ddclient password password 16 | user ddclient priv 1 17 | ip http auth local 18 | ip http access-class 99 19 | ip http port 1021 20 | ip http server 21 | access-list 99 permit host 10.1.1.2 22 | 23 | DDClient Config 24 | --------------------------------------------------- 25 | use=cisco, fw=10.1.1.1, if=eth0, fw-login=ddclient, fw-password=password 26 | 27 | 28 | Method 2 ------------------------------------------------------ 29 | 30 | use=fw 31 | fw=192.168.1.1/exec/show/interfaces/CR 32 | fw-skip=FastEthernet0/0 33 | fw-login=ddclient 34 | fw-password=xxxxxxxx 35 | -------------------------------------------------------------------------------- /t/geturl_response.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 3 | eval { require 'ddclient'; } or BAIL_OUT($@); 4 | 5 | # Fake curl. Use the printf utility, which can process escapes. This allows Perl to drive the fake 6 | # curl with plain ASCII and get arbitrary bytes back, avoiding problems caused by any encoding that 7 | # might be done by Perl (e.g., "use open ':encoding(UTF-8)';"). 8 | my @fakecurl = ('sh', '-c', 'printf %b "$1"', '--'); 9 | 10 | my @test_cases = ( 11 | { 12 | desc => 'binary body', 13 | # Body is UTF-8 encoded ✨ (U+2728 Sparkles) followed by a 0xff byte (invalid UTF-8). 14 | printf => join('\r\n', ('HTTP/1.1 200 OK', '', '\0342\0234\0250\0377')), 15 | # The raw bytes should come through as equally valued codepoints. They must not be decoded. 16 | want => "HTTP/1.1 200 OK\n\n\xe2\x9c\xa8\xff", 17 | }, 18 | ); 19 | 20 | for my $tc (@test_cases) { 21 | @ddclient::curl = (@fakecurl, $tc->{printf}); 22 | $ddclient::curl if 0; # suppress spurious warning "Name used only once: possible typo" 23 | my $got = ddclient::geturl(url => 'http://ignored'); 24 | is($got, $tc->{want}, $tc->{desc}); 25 | } 26 | 27 | done_testing(); 28 | -------------------------------------------------------------------------------- /t/lib/Test/Builder/TodoDiag.pm: -------------------------------------------------------------------------------- 1 | package Test::Builder::TodoDiag; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) } 8 | 9 | sub diagnostics { 0 } 10 | 11 | sub facet_data { 12 | my $self = shift; 13 | my $out = $self->SUPER::facet_data(); 14 | $out->{info}->[0]->{debug} = 0; 15 | return $out; 16 | } 17 | 18 | 1; 19 | 20 | __END__ 21 | 22 | =pod 23 | 24 | =encoding UTF-8 25 | 26 | =head1 NAME 27 | 28 | Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag 29 | 30 | =head1 DESCRIPTION 31 | 32 | This is used to encapsulate diag messages created inside TODO. 33 | 34 | =head1 SYNOPSIS 35 | 36 | You do not need to use this directly. 37 | 38 | =head1 SOURCE 39 | 40 | The source code repository for Test2 can be found at 41 | F. 42 | 43 | =head1 MAINTAINERS 44 | 45 | =over 4 46 | 47 | =item Chad Granum Eexodist@cpan.orgE 48 | 49 | =back 50 | 51 | =head1 AUTHORS 52 | 53 | =over 4 54 | 55 | =item Chad Granum Eexodist@cpan.orgE 56 | 57 | =back 58 | 59 | =head1 COPYRIGHT 60 | 61 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 62 | 63 | This program is free software; you can redistribute it and/or 64 | modify it under the same terms as Perl itself. 65 | 66 | See F 67 | 68 | =cut 69 | -------------------------------------------------------------------------------- /sample-etc_ppp_ip-up.local: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | ###################################################################### 3 | ## 4 | ## On my host, pppd invokes this script with args: 5 | ## /etc/ppp/ip-up.local ppp0 /dev/pts/1 115200 192.168.2.1 192.168.2.3 6 | ## 7 | ## From the manual page for my pppd, these aguments are: 8 | ## scriptname interface-name tty-device speed local-IP-address remote-IP-address ipparam 9 | ## 10 | ## Some people have reported that their pppd returns their 11 | ## local-IP-address as $3. If that's also the case for you, 12 | ## you may need to change the $4 below to $3. This may not 13 | ## be necessary if your pppd also passes the local-ip-address 14 | ## in the environment as either PPP_LOCAL or IPLOCAL. 15 | ## 16 | ###################################################################### 17 | PATH=/usr/bin:${PATH} 18 | IP= 19 | IP=${IP:-$PPP_LOCAL} 20 | IP=${IP:-$IPLOCAL} 21 | IP=${IP:-$4} 22 | 23 | IFACE= 24 | IFACE=${IFACE:-$PPP_IFACE} 25 | IFACE=${IFACE:-$1} 26 | 27 | ## update the DNS server unless the IP address is a private address 28 | ## that may be used as an internal LAN address (or PPtP tunnel). 29 | 30 | logger -t ddclient $0 $* 31 | case "$IP" in 32 | 10.*) ;; 33 | 172.1[6-9].* | 172.2[0-9].* | 172.3[0-1].*) ;; 34 | 192.168.*) ;; 35 | "") logger -t ddclient No local IP given so cannot update 36 | ;; 37 | *) ( 38 | sleep 5 39 | ddclient -daemon=0 -syslog -use=if -if=$IFACE >/dev/null 2>&1 40 | ) & 41 | ;; 42 | esac 43 | -------------------------------------------------------------------------------- /t/use_cmd.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 4 | 5 | local $ddclient::globals{debug} = 1; 6 | local $ddclient::globals{verbose} = 1; 7 | 8 | my @test_cases; 9 | for my $ipv ('4', '6') { 10 | my $ip = $ipv eq '4' ? '192.0.2.1' : '2001:db8::1'; 11 | for my $use ('use', "usev$ipv") { 12 | my @cmds = (); 13 | push(@cmds, 'cmd') if $use eq 'use' || $ipv eq '6'; 14 | push(@cmds, "cmdv$ipv") if $use ne 'use'; 15 | for my $cmd (@cmds) { 16 | my $cmdarg = "echo '$ip'"; 17 | push( 18 | @test_cases, 19 | { 20 | desc => "$use=$cmd $cmd=\"$cmdarg\"", 21 | cfg => {$use => $cmd, $cmd => $cmdarg}, 22 | want => $ip, 23 | }, 24 | ); 25 | } 26 | } 27 | } 28 | 29 | for my $tc (@test_cases) { 30 | local $ddclient::_l = ddclient::pushlogctx($tc->{desc}); 31 | my $h = 'test-host'; 32 | local $ddclient::config{$h} = $tc->{cfg}; 33 | is(ddclient::get_ip(ddclient::strategy_inputs('use', $h)), $tc->{want}, $tc->{desc}) 34 | if $tc->{cfg}{use}; 35 | is(ddclient::get_ipv4(ddclient::strategy_inputs('usev4', $h)), $tc->{want}, $tc->{desc}) 36 | if $tc->{cfg}{usev4}; 37 | is(ddclient::get_ipv6(ddclient::strategy_inputs('usev6', $h)), $tc->{want}, $tc->{desc}) 38 | if $tc->{cfg}{usev6}; 39 | } 40 | 41 | done_testing(); 42 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Waiting.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Waiting; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 9 | use Test2::Util::HashBase; 10 | 11 | sub global { 1 }; 12 | 13 | sub summary { "IPC is waiting for children to finish..." } 14 | 15 | sub facet_data { 16 | my $self = shift; 17 | 18 | my $out = $self->common_facet_data; 19 | 20 | push @{$out->{info}} => { 21 | tag => 'INFO', 22 | debug => 0, 23 | details => $self->summary, 24 | }; 25 | 26 | return $out; 27 | } 28 | 29 | 1; 30 | 31 | __END__ 32 | 33 | =pod 34 | 35 | =encoding UTF-8 36 | 37 | =head1 NAME 38 | 39 | Test2::Event::Waiting - Tell all procs/threads it is time to be done 40 | 41 | =head1 DESCRIPTION 42 | 43 | This event has no data of its own. This event is sent out by the IPC system 44 | when the main process/thread is ready to end. 45 | 46 | =head1 SOURCE 47 | 48 | The source code repository for Test2 can be found at 49 | F. 50 | 51 | =head1 MAINTAINERS 52 | 53 | =over 4 54 | 55 | =item Chad Granum Eexodist@cpan.orgE 56 | 57 | =back 58 | 59 | =head1 AUTHORS 60 | 61 | =over 4 62 | 63 | =item Chad Granum Eexodist@cpan.orgE 64 | 65 | =back 66 | 67 | =head1 COPYRIGHT 68 | 69 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 70 | 71 | This program is free software; you can redistribute it and/or 72 | modify it under the same terms as Perl itself. 73 | 74 | See F 75 | 76 | =cut 77 | -------------------------------------------------------------------------------- /t/lib/Test/use/ok.pm: -------------------------------------------------------------------------------- 1 | package Test::use::ok; 2 | use 5.005; 3 | 4 | our $VERSION = '1.302175'; 5 | 6 | 7 | __END__ 8 | 9 | =head1 NAME 10 | 11 | Test::use::ok - Alternative to Test::More::use_ok 12 | 13 | =head1 SYNOPSIS 14 | 15 | use ok 'Some::Module'; 16 | 17 | =head1 DESCRIPTION 18 | 19 | According to the B documentation, it is recommended to run 20 | C inside a C block, so functions are exported at 21 | compile-time and prototypes are properly honored. 22 | 23 | That is, instead of writing this: 24 | 25 | use_ok( 'Some::Module' ); 26 | use_ok( 'Other::Module' ); 27 | 28 | One should write this: 29 | 30 | BEGIN { use_ok( 'Some::Module' ); } 31 | BEGIN { use_ok( 'Other::Module' ); } 32 | 33 | However, people often either forget to add C, or mistakenly group 34 | C with other tests in a single C block, which can create subtle 35 | differences in execution order. 36 | 37 | With this module, simply change all C in test scripts to C, 38 | and they will be executed at C time. The explicit space after C 39 | makes it clear that this is a single compile-time action. 40 | 41 | =head1 SEE ALSO 42 | 43 | L 44 | 45 | =head1 MAINTAINER 46 | 47 | =over 4 48 | 49 | =item Chad Granum Eexodist@cpan.orgE 50 | 51 | =back 52 | 53 | =encoding utf8 54 | 55 | =head1 CC0 1.0 Universal 56 | 57 | To the extent possible under law, 唐鳳 has waived all copyright and related 58 | or neighboring rights to L. 59 | 60 | This work is published from Taiwan. 61 | 62 | L 63 | 64 | =cut 65 | -------------------------------------------------------------------------------- /t/lib/Test/Tester/CaptureRunner.pm: -------------------------------------------------------------------------------- 1 | # $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $ 2 | use strict; 3 | 4 | package Test::Tester::CaptureRunner; 5 | 6 | our $VERSION = '1.302175'; 7 | 8 | 9 | use Test::Tester::Capture; 10 | require Exporter; 11 | 12 | sub new 13 | { 14 | my $pkg = shift; 15 | my $self = bless {}, $pkg; 16 | return $self; 17 | } 18 | 19 | sub run_tests 20 | { 21 | my $self = shift; 22 | 23 | my $test = shift; 24 | 25 | capture()->reset; 26 | 27 | $self->{StartLevel} = $Test::Builder::Level; 28 | &$test(); 29 | } 30 | 31 | sub get_results 32 | { 33 | my $self = shift; 34 | my @results = capture()->details; 35 | 36 | my $start = $self->{StartLevel}; 37 | foreach my $res (@results) 38 | { 39 | next if defined $res->{depth}; 40 | my $depth = $res->{_depth} - $res->{_level} - $start - 3; 41 | # print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n"; 42 | $res->{depth} = $depth; 43 | } 44 | 45 | return @results; 46 | } 47 | 48 | sub get_premature 49 | { 50 | return capture()->premature; 51 | } 52 | 53 | sub capture 54 | { 55 | return Test::Tester::Capture->new; 56 | } 57 | 58 | __END__ 59 | 60 | =head1 NAME 61 | 62 | Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder 63 | 64 | =head1 DESCRIPTION 65 | 66 | This stuff if needed to allow me to play with other ways of monitoring the 67 | test results. 68 | 69 | =head1 AUTHOR 70 | 71 | Copyright 2003 by Fergal Daly . 72 | 73 | =head1 LICENSE 74 | 75 | Under the same license as Perl itself 76 | 77 | See http://www.perl.com/perl/misc/Artistic.html 78 | 79 | =cut 80 | -------------------------------------------------------------------------------- /t/check_value.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use strict; 3 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 4 | eval { require 'ddclient'; } or BAIL_OUT($@); 5 | 6 | my @test_cases = ( 7 | { 8 | type => ddclient::T_FQDN(), 9 | input => 'example.com', 10 | want => 'example.com', 11 | }, 12 | { 13 | type => ddclient::T_FQDN(), 14 | input => 'example', 15 | want_invalid => 1, 16 | }, 17 | { 18 | type => ddclient::T_URL(), 19 | input => 'https://www.example.com', 20 | want => 'https://www.example.com', 21 | }, 22 | { 23 | type => ddclient::T_URL(), 24 | input => 'https://directnic.com/dns/gateway/ad133/', 25 | want => 'https://directnic.com/dns/gateway/ad133/', 26 | }, 27 | { 28 | type => ddclient::T_URL(), 29 | input => 'HTTPS://MixedCase.com/', 30 | want => 'HTTPS://MixedCase.com/', 31 | }, 32 | { 33 | type => ddclient::T_URL(), 34 | input => 'ftp://bad.protocol/', 35 | want_invalid => 1, 36 | }, 37 | { 38 | type => ddclient::T_URL(), 39 | input => 'bad-url', 40 | want_invalid => 1, 41 | }, 42 | ); 43 | for my $tc (@test_cases) { 44 | my $got; 45 | my $got_invalid = !(eval { 46 | $got = ddclient::check_value($tc->{input}, 47 | ddclient::setv($tc->{type}, 0, 0, undef, undef)); 48 | 1; 49 | }); 50 | is($got_invalid, !!$tc->{want_invalid}, "$tc->{type}: $tc->{input}: validity"); 51 | is($got, $tc->{want}, "$tc->{type}: $tc->{input}: normalization") if !$tc->{want_invalid}; 52 | } 53 | done_testing(); 54 | -------------------------------------------------------------------------------- /t/interval_expired.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 3 | eval { require 'ddclient'; } or BAIL_OUT($@); 4 | 5 | my $h = 't/interval_expired.pl'; 6 | 7 | my $default_now = 1000000000; 8 | 9 | my @test_cases = ( 10 | { 11 | interval => 'inf', 12 | want => 0, 13 | }, 14 | { 15 | now => 'inf', 16 | interval => 'inf', 17 | want => 0, 18 | }, 19 | { 20 | cache => '-inf', 21 | interval => 'inf', 22 | want => 0, 23 | }, 24 | { 25 | cache => undef, # Falsy cache value. 26 | interval => 'inf', 27 | want => 0, 28 | }, 29 | { 30 | now => 0, 31 | cache => 0, # Different kind of falsy cache value. 32 | interval => 'inf', 33 | want => 0, 34 | }, 35 | ); 36 | 37 | for my $tc (@test_cases) { 38 | $tc->{now} //= $default_now; 39 | # For convenience, $tc->{cache} is an offset from $tc->{now}, not an absolute time.. 40 | my $cachetime = $tc->{now} + $tc->{cache} if defined($tc->{cache}); 41 | $ddclient::config{$h} = {'interval' => $tc->{interval}}; 42 | %ddclient::config if 0; # suppress spurious warning "Name used only once: possible typo" 43 | $ddclient::cache{$h} = {'cached-time' => $cachetime} if defined($cachetime); 44 | %ddclient::cache if 0; # suppress spurious warning "Name used only once: possible typo" 45 | $ddclient::now = $tc->{now}; 46 | $ddclient::now if 0; # suppress spurious warning "Name used only once: possible typo" 47 | my $desc = "now=$tc->{now}, cache=${\($cachetime // 'undef')}, interval=$tc->{interval}"; 48 | is(ddclient::interval_expired($h, 'cached-time', 'interval'), $tc->{want}, $desc); 49 | } 50 | 51 | done_testing(); 52 | -------------------------------------------------------------------------------- /t/write_recap.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use File::Spec::Functions; 3 | use File::Temp; 4 | eval { require Test::MockModule; } or plan(skip_all => $@); 5 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 6 | eval { require 'ddclient'; } or BAIL_OUT($@); 7 | 8 | my $warning; 9 | 10 | my $module = Test::MockModule->new('ddclient'); 11 | # Note: 'mock' is used instead of 'redefine' because 'redefine' is not available in the versions of 12 | # Test::MockModule distributed with old Debian and Ubuntu releases. 13 | $module->mock('warning', sub { 14 | BAIL_OUT("warning already logged") if defined($warning); 15 | $warning = sprintf(shift, @_); 16 | }); 17 | my $tmpdir = File::Temp->newdir(); 18 | my $dir = $tmpdir->dirname(); 19 | diag("temporary directory: $dir"); 20 | 21 | sub tc { 22 | return { 23 | name => shift, 24 | f => shift, 25 | warning_regex => shift, 26 | }; 27 | } 28 | 29 | my @test_cases = ( 30 | tc("create cache file", catfile($dir, 'a', 'b', 'cachefile'), undef), 31 | tc("overwrite cache file", catfile($dir, 'a', 'b', 'cachefile'), undef), 32 | tc("bad directory", catfile($dir, 'a', 'b', 'cachefile', 'bad'), qr/Failed to create/i), 33 | tc("bad file", catfile($dir, 'a', 'b'), qr/Failed to create/i), 34 | ); 35 | 36 | for my $tc (@test_cases) { 37 | $warning = undef; 38 | ddclient::write_recap($tc->{f}); 39 | subtest $tc->{name} => sub { 40 | if (defined($tc->{warning_regex})) { 41 | like($warning, $tc->{warning_regex}, "expected warning message"); 42 | } else { 43 | ok(!defined($warning), "no warning"); 44 | ok(-f $tc->{f}, "cache file exists"); 45 | } 46 | }; 47 | } 48 | 49 | done_testing(); 50 | -------------------------------------------------------------------------------- /t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MIIEvwIBADANBgkqhkiG9w0BAQEFAASCBKkwggSlAgEAAoIBAQDnP5rW+E3DiWkf 3 | q5UAtCDrNnLhR7oM2CB2n3js8tQcLUdseaevzuj2kcHo8ndBOzdwNhPyWzBF63TQ 4 | 9DduINVaqt7833KyB7vaHGa3ciDPNF9V8CM2w58BVEVwZeUqswOxnnPcojLLAuBg 5 | iaX0mofiirxNgBuTwmHVEOvtbPygs6UiPAMCcuFxCIZCAzoNe24c87s9rajkwj98 6 | Cuu9wYkd8bztQ35HlODzF20Tlr6vdOUgJXGVxX8m0iik7r0S/gToi0baf+H8VMDc 7 | Ur5V4kklyiEJz+Lt6XAmJGIuiW4iLYwgPYP30bXhdBxducu21WCTBpYczLQKTgBq 8 | BNa6L+rHAgMBAAECggEBAMSWe+m4mVNb47R6x2cbush7N1pxAaedrKtrkv/Mx6lU 9 | jN2Y5oc9HStQakrApcUctFp+fqKQBw/JxTtGAkFrRDWaAYtz4iubC4W2k1PsgBvm 10 | aA3E4grSbsBQhd+xoAqWuNMs405zzT5sqZcoLZ8uJ8rdKouwFsGchFL/2bGz72gk 11 | 8smGqMdH4sQep3kJhJyWio47C7pC1qnG1xNmsfJ7+MkEL/+b95WsbNUTZHkAFzE8 12 | l5BBLILXR10EqGCAWiuz9WGffw7JASyrV1spojOmPBneBDhfLSgWjuv/0S1pUxVx 13 | iZWDlukHPUVQWaDWQxE9Uscup3hORRENTOIJpBsYWhECgYEA9qACG2oHCa+a3xj/ 14 | QMdWKWVZeMnKUDlpPhlyC9ue+K4NMBSzgG3K1qURX0xAvkPEApYKBh+rqvJqTMYk 15 | N5K+CfLaU53Weyko5v5xPj3aSnGVsYazkoxfZ31MbbIqn+JPoNjYafTo2SZJsaQ6 16 | Y416FMxlWf7eR4rZGr1iqptSWvUCgYEA8An2Qdk+NMGYrnL6xr+AKygm2ri1Mz7k 17 | XVr/jhkUxhBsvPumNQAVQaEuWAx6Mwgs+uzgJrsW8UCVAta/Jo+dWlCewqrpTsIh 18 | jJZjkP9H91oEA6GkUNy9JI6j3KRQ6I5rGNr8nJrJ4c9+yLZa85BTkTriHvZl5zZX 19 | SberAyPREUsCgYEAx9C4JFHxRc27Ispz9J4MlxmANjb37au2MxQWrLjRwhXypWQA 20 | UyuhTesLejSjuAPbiWTa1j9OrQAfU/itW0FPK2xRq7GUFtEwTIcWZSFj/TCt4dmL 21 | IE8O9SA1jiLuGgAYF+/Y13AQP++fgYfXrtTvdm5sJ1Ax87DxWZLbn/Kb9QkCgYEA 22 | xjgDwlbKVrh0A8LxMcSb64eJpl6XS40o+aqWlFpD3Fdd5CWPF/9Mjliys4UCODgN 23 | JN0NMQ6YIHsrUh/R098OmrEumSSX6zDGkZjy+Z7FaA5OeE04KopOKu0bha2vHovV 24 | Br53kj8EbVNyp/5mVvGdALX2Wokwl2E5baedMceW8scCgYAwhrNIV1I6f76EgXP6 25 | 3XU1B5c6VVk/Mlaid1Y7IrqPrhp1vcY2txZQ/NFEnvS1UMTvTskccgpIJJLd27D7 26 | CxDQGrXTfFOONZN6KzArGtX/m3PiTs6Mz3Zn8R5rJsCvda4kxEu0WV9KqZRSDGoM 27 | pAawXm36qael22agLPA2zeH9Gg== 28 | -----END PRIVATE KEY----- 29 | -------------------------------------------------------------------------------- /t/lib/Test2/Hub/Interceptor.pm: -------------------------------------------------------------------------------- 1 | package Test2::Hub::Interceptor; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | use Test2::Hub::Interceptor::Terminator(); 9 | 10 | BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } 11 | use Test2::Util::HashBase; 12 | 13 | sub init { 14 | my $self = shift; 15 | $self->SUPER::init(); 16 | $self->{+NESTED} = 0; 17 | } 18 | 19 | sub inherit { 20 | my $self = shift; 21 | my ($from, %params) = @_; 22 | 23 | $self->{+NESTED} = 0; 24 | 25 | if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) { 26 | my $ipc = $from->{+IPC}; 27 | $self->{+IPC} = $ipc; 28 | $ipc->add_hub($self->{+HID}); 29 | } 30 | } 31 | 32 | sub terminate { 33 | my $self = shift; 34 | my ($code) = @_; 35 | 36 | eval { 37 | no warnings 'exiting'; 38 | last T2_SUBTEST_WRAPPER; 39 | }; 40 | my $err = $@; 41 | 42 | # Fallback 43 | die bless(\$err, 'Test2::Hub::Interceptor::Terminator'); 44 | } 45 | 46 | 1; 47 | 48 | __END__ 49 | 50 | =pod 51 | 52 | =encoding UTF-8 53 | 54 | =head1 NAME 55 | 56 | Test2::Hub::Interceptor - Hub used by interceptor to grab results. 57 | 58 | =head1 SOURCE 59 | 60 | The source code repository for Test2 can be found at 61 | F. 62 | 63 | =head1 MAINTAINERS 64 | 65 | =over 4 66 | 67 | =item Chad Granum Eexodist@cpan.orgE 68 | 69 | =back 70 | 71 | =head1 AUTHORS 72 | 73 | =over 4 74 | 75 | =item Chad Granum Eexodist@cpan.orgE 76 | 77 | =back 78 | 79 | =head1 COPYRIGHT 80 | 81 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 82 | 83 | This program is free software; you can redistribute it and/or 84 | modify it under the same terms as Perl itself. 85 | 86 | See F 87 | 88 | =cut 89 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Note.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Note; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 9 | use Test2::Util::HashBase qw/message/; 10 | 11 | sub init { 12 | $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; 13 | } 14 | 15 | sub summary { $_[0]->{+MESSAGE} } 16 | 17 | sub facet_data { 18 | my $self = shift; 19 | 20 | my $out = $self->common_facet_data; 21 | 22 | $out->{info} = [ 23 | { 24 | tag => 'NOTE', 25 | debug => 0, 26 | details => $self->{+MESSAGE}, 27 | } 28 | ]; 29 | 30 | return $out; 31 | } 32 | 33 | 1; 34 | 35 | __END__ 36 | 37 | =pod 38 | 39 | =encoding UTF-8 40 | 41 | =head1 NAME 42 | 43 | Test2::Event::Note - Note event type 44 | 45 | =head1 DESCRIPTION 46 | 47 | Notes, typically rendered to STDOUT. 48 | 49 | =head1 SYNOPSIS 50 | 51 | use Test2::API qw/context/; 52 | use Test2::Event::Note; 53 | 54 | my $ctx = context(); 55 | my $event = $ctx->Note($message); 56 | 57 | =head1 ACCESSORS 58 | 59 | =over 4 60 | 61 | =item $note->message 62 | 63 | The message for the note. 64 | 65 | =back 66 | 67 | =head1 SOURCE 68 | 69 | The source code repository for Test2 can be found at 70 | F. 71 | 72 | =head1 MAINTAINERS 73 | 74 | =over 4 75 | 76 | =item Chad Granum Eexodist@cpan.orgE 77 | 78 | =back 79 | 80 | =head1 AUTHORS 81 | 82 | =over 4 83 | 84 | =item Chad Granum Eexodist@cpan.orgE 85 | 86 | =back 87 | 88 | =head1 COPYRIGHT 89 | 90 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 91 | 92 | This program is free software; you can redistribute it and/or 93 | modify it under the same terms as Perl itself. 94 | 95 | See F 96 | 97 | =cut 98 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/About.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::About; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 8 | use Test2::Util::HashBase qw{ -package -no_display -uuid -eid }; 9 | 10 | 1; 11 | 12 | __END__ 13 | 14 | =pod 15 | 16 | =encoding UTF-8 17 | 18 | =head1 NAME 19 | 20 | Test2::EventFacet::About - Facet with event details. 21 | 22 | =head1 DESCRIPTION 23 | 24 | This facet has information about the event, such as event package. 25 | 26 | =head1 FIELDS 27 | 28 | =over 4 29 | 30 | =item $string = $about->{details} 31 | 32 | =item $string = $about->details() 33 | 34 | Summary about the event. 35 | 36 | =item $package = $about->{package} 37 | 38 | =item $package = $about->package() 39 | 40 | Event package name. 41 | 42 | =item $bool = $about->{no_display} 43 | 44 | =item $bool = $about->no_display() 45 | 46 | True if the event should be skipped by formatters. 47 | 48 | =item $uuid = $about->{uuid} 49 | 50 | =item $uuid = $about->uuid() 51 | 52 | Will be set to a uuid if uuid tagging was enabled. 53 | 54 | =item $uuid = $about->{eid} 55 | 56 | =item $uuid = $about->eid() 57 | 58 | A unique (for the test job) identifier for the event. 59 | 60 | =back 61 | 62 | =head1 SOURCE 63 | 64 | The source code repository for Test2 can be found at 65 | F. 66 | 67 | =head1 MAINTAINERS 68 | 69 | =over 4 70 | 71 | =item Chad Granum Eexodist@cpan.orgE 72 | 73 | =back 74 | 75 | =head1 AUTHORS 76 | 77 | =over 4 78 | 79 | =item Chad Granum Eexodist@cpan.orgE 80 | 81 | =back 82 | 83 | =head1 COPYRIGHT 84 | 85 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 86 | 87 | This program is free software; you can redistribute it and/or 88 | modify it under the same terms as Perl itself. 89 | 90 | See F 91 | 92 | =cut 93 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | use Test2::Util::HashBase qw/-details/; 8 | use Carp qw/croak/; 9 | 10 | my $SUBLEN = length(__PACKAGE__ . '::'); 11 | sub facet_key { 12 | my $key = ref($_[0]) || $_[0]; 13 | substr($key, 0, $SUBLEN, ''); 14 | return lc($key); 15 | } 16 | 17 | sub is_list { 0 } 18 | 19 | sub clone { 20 | my $self = shift; 21 | my $type = ref($self); 22 | return bless {%$self, @_}, $type; 23 | } 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =pod 30 | 31 | =encoding UTF-8 32 | 33 | =head1 NAME 34 | 35 | Test2::EventFacet - Base class for all event facets. 36 | 37 | =head1 DESCRIPTION 38 | 39 | Base class for all event facets. 40 | 41 | =head1 METHODS 42 | 43 | =over 4 44 | 45 | =item $key = $facet_class->facet_key() 46 | 47 | This will return the key for the facet in the facet data hash. 48 | 49 | =item $bool = $facet_class->is_list() 50 | 51 | This will return true if the facet should be in a list instead of a single 52 | item. 53 | 54 | =item $clone = $facet->clone() 55 | 56 | =item $clone = $facet->clone(%replace) 57 | 58 | This will make a shallow clone of the facet. You may specify fields to override 59 | as arguments. 60 | 61 | =back 62 | 63 | =head1 SOURCE 64 | 65 | The source code repository for Test2 can be found at 66 | F. 67 | 68 | =head1 MAINTAINERS 69 | 70 | =over 4 71 | 72 | =item Chad Granum Eexodist@cpan.orgE 73 | 74 | =back 75 | 76 | =head1 AUTHORS 77 | 78 | =over 4 79 | 80 | =item Chad Granum Eexodist@cpan.orgE 81 | 82 | =back 83 | 84 | =head1 COPYRIGHT 85 | 86 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 87 | 88 | This program is free software; you can redistribute it and/or 89 | modify it under the same terms as Perl itself. 90 | 91 | See F 92 | 93 | =cut 94 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Diag.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Diag; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 9 | use Test2::Util::HashBase qw/message/; 10 | 11 | sub init { 12 | $_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE}; 13 | } 14 | 15 | sub summary { $_[0]->{+MESSAGE} } 16 | 17 | sub diagnostics { 1 } 18 | 19 | sub facet_data { 20 | my $self = shift; 21 | 22 | my $out = $self->common_facet_data; 23 | 24 | $out->{info} = [ 25 | { 26 | tag => 'DIAG', 27 | debug => 1, 28 | details => $self->{+MESSAGE}, 29 | } 30 | ]; 31 | 32 | return $out; 33 | } 34 | 35 | 1; 36 | 37 | __END__ 38 | 39 | =pod 40 | 41 | =encoding UTF-8 42 | 43 | =head1 NAME 44 | 45 | Test2::Event::Diag - Diag event type 46 | 47 | =head1 DESCRIPTION 48 | 49 | Diagnostics messages, typically rendered to STDERR. 50 | 51 | =head1 SYNOPSIS 52 | 53 | use Test2::API qw/context/; 54 | use Test2::Event::Diag; 55 | 56 | my $ctx = context(); 57 | my $event = $ctx->diag($message); 58 | 59 | =head1 ACCESSORS 60 | 61 | =over 4 62 | 63 | =item $diag->message 64 | 65 | The message for the diag. 66 | 67 | =back 68 | 69 | =head1 SOURCE 70 | 71 | The source code repository for Test2 can be found at 72 | F. 73 | 74 | =head1 MAINTAINERS 75 | 76 | =over 4 77 | 78 | =item Chad Granum Eexodist@cpan.orgE 79 | 80 | =back 81 | 82 | =head1 AUTHORS 83 | 84 | =over 4 85 | 86 | =item Chad Granum Eexodist@cpan.orgE 87 | 88 | =back 89 | 90 | =head1 COPYRIGHT 91 | 92 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 93 | 94 | This program is free software; you can redistribute it and/or 95 | modify it under the same terms as Perl itself. 96 | 97 | See F 98 | 99 | =cut 100 | -------------------------------------------------------------------------------- /.github/workflows/pr.yml: -------------------------------------------------------------------------------- 1 | name: Pull Request 2 | on: 3 | pull_request: 4 | types: 5 | - labeled 6 | - opened 7 | - reopened 8 | - synchronize 9 | - unlabeled 10 | 11 | jobs: 12 | linear-history: 13 | if: ${{ !contains(github.event.pull_request.labels.*.name, 'pr-permit-nonlinear') }} 14 | name: Linear History 15 | runs-on: ubuntu-latest 16 | steps: 17 | - uses: actions/checkout@v4 18 | with: 19 | fetch-depth: 0 20 | - name: No new merge commits 21 | run: | 22 | log() { printf %s\\n "$*" >&2; } 23 | error() { log "ERROR: $@"; } 24 | fatal() { error "$@"; exit 1; } 25 | try() { log "Running command $@"; "$@" || fatal "'$@' failed"; } 26 | out=$(try git rev-list -n 1 --merges '${{ github.event.pull_request.base.sha }}..${{ github.event.pull_request.head.sha }}') || exit 1 27 | [ -z "${out}" ] || { 28 | error "pull request includes a merge commit and does not have the 'pr-permit-nonlinear' label" 29 | git show "${out}" >&2 30 | exit 1 31 | } 32 | no-autosquash: 33 | if: ${{ !contains(github.event.pull_request.labels.*.name, 'pr-permit-autosquash') }} 34 | name: No --autosquash commits 35 | runs-on: ubuntu-latest 36 | steps: 37 | - uses: actions/checkout@v4 38 | with: 39 | fetch-depth: 0 40 | - name: 'No commits with messages starting with "fixup!", "squash!", or "amend!"' 41 | run: | 42 | log() { printf %s\\n "$*" >&2; } 43 | error() { log "ERROR: $@"; } 44 | fatal() { error "$@"; exit 1; } 45 | try() { log "Running command $@"; "$@" || fatal "'$@' failed"; } 46 | out=$(try git log --oneline '${{ github.event.pull_request.base.sha }}..${{ github.event.pull_request.head.sha }}') || exit 1 47 | ! grep -E '^[^ ]* (fixup|squash|amend)!' <{details} 37 | 38 | =item $string = $amnesty->details() 39 | 40 | Human readable explanation of why amnesty was granted. 41 | 42 | Example: I 43 | 44 | =item $short_string = $amnesty->{tag} 45 | 46 | =item $short_string = $amnesty->tag() 47 | 48 | Short string (usually 10 characters or less, not enforced, but may be truncated 49 | by renderers) categorizing the amnesty. 50 | 51 | =item $bool = $amnesty->{inherited} 52 | 53 | =item $bool = $amnesty->inherited() 54 | 55 | This will be true if the amnesty was granted to a parent event and inherited by 56 | this event, which is a child, such as an assertion within a subtest that is 57 | marked todo. 58 | 59 | =back 60 | 61 | =head1 SOURCE 62 | 63 | The source code repository for Test2 can be found at 64 | F. 65 | 66 | =head1 MAINTAINERS 67 | 68 | =over 4 69 | 70 | =item Chad Granum Eexodist@cpan.orgE 71 | 72 | =back 73 | 74 | =head1 AUTHORS 75 | 76 | =over 4 77 | 78 | =item Chad Granum Eexodist@cpan.orgE 79 | 80 | =back 81 | 82 | =head1 COPYRIGHT 83 | 84 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 85 | 86 | This program is free software; you can redistribute it and/or 87 | modify it under the same terms as Perl itself. 88 | 89 | See F 90 | 91 | =cut 92 | -------------------------------------------------------------------------------- /docs/ProviderGuidelines.md: -------------------------------------------------------------------------------- 1 | # Provider implementations 2 | 3 | Author: [@LenardHess](https://github.com/LenardHess/)\ 4 | Date: 2023-11-23 5 | 6 | This document is meant to detail the mechanisms that provider implementation shall use. It differentiates between new and legacy provider implementations. The former are adhering to the IPv6 support updates being done to ddclient, the legacy ones are from before that update. 7 | 8 | ## New provider Implementation 9 | 1. Grab the IP(s) from $config{$host}{'wantipv4'} and/or $config{$host}{'wantipv6'} 10 | 2. Optional: Query the provider for the current IP record(s). If they are already good, skip updating IP record(s) 11 | 3. Update the IP record(s). 12 | 4. If successful (or if the records were already good): 13 | - Set 'status-ipv4' and/or 'status-ipv6' to 'good' 14 | - Set 'ipv4' and/or 'ipv6' to the IP that has been set 15 | - Set 'mtime' to the current time 16 | 5. If not successful: 17 | - Set 'status-ipv4' and/or 'status-ipv6' to an error message 18 | - Set 'atime' to the current time 19 | 20 | The new provider implementation should not set 'status' nor 'ip'. They're part of the legacy infrastructure and ddclient will take care of setting them correctly. 21 | 22 | ## Legacy provider implementations 23 | 1. Grab the IP from $config{$host}{'wantip'} 24 | 2. Optional: Query the provider for the current IP record. If it is already good, skip updating IP record 25 | 3. Update the IP record. 26 | 4. If successful (or if the record was already good): 27 | - Set 'status' to 'good' 28 | - Set 'ip' to the IP that has been set 29 | - Set 'mtime' to the current time 30 | 5. If not successful: 31 | - Set 'status' to an error message 32 | - Set 'atime' to the current time 33 | 34 | # ToDo 35 | - Decide/Inquire whether services prefer querying the IP first. Then decide whether to make it mandatory. 36 | - Write guidelines on checking existing records (i.e. check TTL as well?). 37 | - Start a list of providers and their implementation state 38 | - Add more details to this document 39 | - Whether 'wantip*' ought to be deleted when read or not. 40 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Assert.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Assert; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 8 | use Test2::Util::HashBase qw{ -pass -no_debug -number }; 9 | 10 | 1; 11 | 12 | __END__ 13 | 14 | =pod 15 | 16 | =encoding UTF-8 17 | 18 | =head1 NAME 19 | 20 | Test2::EventFacet::Assert - Facet representing an assertion. 21 | 22 | =head1 DESCRIPTION 23 | 24 | The assertion facet is provided by any event representing an assertion that was 25 | made. 26 | 27 | =head1 FIELDS 28 | 29 | =over 4 30 | 31 | =item $string = $assert->{details} 32 | 33 | =item $string = $assert->details() 34 | 35 | Human readable description of the assertion. 36 | 37 | =item $bool = $assert->{pass} 38 | 39 | =item $bool = $assert->pass() 40 | 41 | True if the assertion passed. 42 | 43 | =item $bool = $assert->{no_debug} 44 | 45 | =item $bool = $assert->no_debug() 46 | 47 | Set this to true if you have provided custom diagnostics and do not want the 48 | defaults to be displayed. 49 | 50 | =item $int = $assert->{number} 51 | 52 | =item $int = $assert->number() 53 | 54 | (Optional) assertion number. This may be omitted or ignored. This is usually 55 | only useful when parsing/processing TAP. 56 | 57 | B: This is not set by the Test2 system, assertion number is not known 58 | until AFTER the assertion has been processed. This attribute is part of the 59 | spec only for harnesses. 60 | 61 | =back 62 | 63 | =head1 SOURCE 64 | 65 | The source code repository for Test2 can be found at 66 | F. 67 | 68 | =head1 MAINTAINERS 69 | 70 | =over 4 71 | 72 | =item Chad Granum Eexodist@cpan.orgE 73 | 74 | =back 75 | 76 | =head1 AUTHORS 77 | 78 | =over 4 79 | 80 | =item Chad Granum Eexodist@cpan.orgE 81 | 82 | =back 83 | 84 | =head1 COPYRIGHT 85 | 86 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 87 | 88 | This program is free software; you can redistribute it and/or 89 | modify it under the same terms as Perl itself. 90 | 91 | See F 92 | 93 | =cut 94 | -------------------------------------------------------------------------------- /t/version.pl.in: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use version; 3 | 4 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 5 | eval { require 'ddclient'; } or BAIL_OUT($@); 6 | 7 | ok(ddclient::parse_version($ddclient::VERSION), 8 | "module's Perl version string is in opinionated form"); 9 | 10 | my $n = qr/0|[1-9]\d{0,2}/; 11 | like($ddclient::version, qr/^$n\.$n\.$n(?:-alpha|-beta\.$n|-rc\.$n|\+r\.$n)?$/, 12 | "human-readable version is in opinionated form"); 13 | 14 | my @tcs = ( 15 | ['v1.0_0', '1-alpha'], 16 | ['v1.0.0_0', '1.0-alpha'], 17 | ['v1.2.3.0_0', '1.2.3-alpha'], 18 | ['v1.2.3.4.0_0', '1.2.3.4-alpha'], 19 | ['v1.0_1', '1-beta.1'], 20 | ['v1.0.0_1', '1.0-beta.1'], 21 | ['v1.2.3.0_1', '1.2.3-beta.1'], 22 | ['v1.2.3.4.0_1', '1.2.3.4-beta.1'], 23 | ['v1.2.3.0_899', '1.2.3-beta.899'], 24 | ['v1.0_901', '1-rc.1'], 25 | ['v1.0.0_901', '1.0-rc.1'], 26 | ['v1.2.3.0_901', '1.2.3-rc.1'], 27 | ['v1.2.3.4.0_901', '1.2.3.4-rc.1'], 28 | ['v1.2.3.0_998', '1.2.3-rc.98'], 29 | ['v1.999', '1'], 30 | ['v1.0.999', '1.0'], 31 | ['v1.2.3.999', '1.2.3'], 32 | ['v1.2.3.4.999', '1.2.3.4'], 33 | ['v1.999.1', '1+r.1'], 34 | ['v1.0.999.1', '1.0+r.1'], 35 | ['v1.2.3.999.1', '1.2.3+r.1'], 36 | ['v1.2.3.4.999.1', '1.2.3.4+r.1'], 37 | ['v1.2.3.999.999', '1.2.3+r.999'], 38 | [$ddclient::VERSION, $ddclient::version], 39 | ); 40 | 41 | subtest 'humanize_version' => sub { 42 | for my $tc (@tcs) { 43 | my ($pv, $want) = @$tc; 44 | is(ddclient::humanize_version($pv), $want, "$pv -> $want"); 45 | } 46 | }; 47 | 48 | subtest 'human-readable version can be translated back to Perl version' => sub { 49 | for my $tc (@tcs) { 50 | my ($want, $hv) = @$tc; 51 | my $pv = "v$hv"; 52 | $pv =~ s/^(?!.*-)(.*?)(?:\+r\.(\d+))?$/"$1.999" . (defined($2) ? ".$2" : "")/e; 53 | $pv =~ s/-alpha$/.0_0/; 54 | $pv =~ s/-beta\.(\d+)$/.0_$1/; 55 | $pv =~ s/-rc\.(\d+)$/'.0_' . (900 + $1)/e; 56 | is($pv, $want, "$hv -> $want"); 57 | } 58 | }; 59 | 60 | is($ddclient::version, '@PACKAGE_VERSION@', "version matches version in Autoconf"); 61 | 62 | done_testing(); 63 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Parent.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Parent; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | use Carp qw/confess/; 8 | 9 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 10 | use Test2::Util::HashBase qw{ -hid -children -buffered }; 11 | 12 | sub init { 13 | confess "Attribute 'hid' must be set" 14 | unless defined $_[0]->{+HID}; 15 | 16 | $_[0]->{+CHILDREN} ||= []; 17 | } 18 | 19 | 1; 20 | 21 | __END__ 22 | 23 | =pod 24 | 25 | =encoding UTF-8 26 | 27 | =head1 NAME 28 | 29 | Test2::EventFacet::Parent - Facet for events contains other events 30 | 31 | =head1 DESCRIPTION 32 | 33 | This facet is used when an event contains other events, such as a subtest. 34 | 35 | =head1 FIELDS 36 | 37 | =over 4 38 | 39 | =item $string = $parent->{details} 40 | 41 | =item $string = $parent->details() 42 | 43 | Human readable description of the event. 44 | 45 | =item $hid = $parent->{hid} 46 | 47 | =item $hid = $parent->hid() 48 | 49 | Hub ID of the hub that is represented in the parent-child relationship. 50 | 51 | =item $arrayref = $parent->{children} 52 | 53 | =item $arrayref = $parent->children() 54 | 55 | Arrayref containing the facet-data hashes of events nested under this one. 56 | 57 | I 58 | 59 | =item $bool = $parent->{buffered} 60 | 61 | =item $bool = $parent->buffered() 62 | 63 | True if the subtest is buffered (meaning the formatter has probably not seen 64 | them yet). 65 | 66 | =back 67 | 68 | =head1 SOURCE 69 | 70 | The source code repository for Test2 can be found at 71 | F. 72 | 73 | =head1 MAINTAINERS 74 | 75 | =over 4 76 | 77 | =item Chad Granum Eexodist@cpan.orgE 78 | 79 | =back 80 | 81 | =head1 AUTHORS 82 | 83 | =over 4 84 | 85 | =item Chad Granum Eexodist@cpan.orgE 86 | 87 | =back 88 | 89 | =head1 COPYRIGHT 90 | 91 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 92 | 93 | This program is free software; you can redistribute it and/or 94 | modify it under the same terms as Perl itself. 95 | 96 | See F 97 | 98 | =cut 99 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Encoding.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Encoding; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | use Carp qw/croak/; 8 | 9 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 10 | use Test2::Util::HashBase qw/encoding/; 11 | 12 | sub init { 13 | my $self = shift; 14 | defined $self->{+ENCODING} or croak "'encoding' is a required attribute"; 15 | } 16 | 17 | sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} } 18 | 19 | sub facet_data { 20 | my $self = shift; 21 | my $out = $self->common_facet_data; 22 | $out->{control}->{encoding} = $self->{+ENCODING}; 23 | $out->{about}->{details} = $self->summary; 24 | return $out; 25 | } 26 | 27 | 28 | 1; 29 | 30 | __END__ 31 | 32 | =pod 33 | 34 | =encoding UTF-8 35 | 36 | =head1 NAME 37 | 38 | Test2::Event::Encoding - Set the encoding for the output stream 39 | 40 | =head1 DESCRIPTION 41 | 42 | The encoding event is generated when a test file wants to specify the encoding 43 | to be used when formatting its output. This event is intended to be produced 44 | by formatter classes and used for interpreting test names, message contents, 45 | etc. 46 | 47 | =head1 SYNOPSIS 48 | 49 | use Test2::API qw/context/; 50 | use Test2::Event::Encoding; 51 | 52 | my $ctx = context(); 53 | my $event = $ctx->send_event('Encoding', encoding => 'UTF-8'); 54 | 55 | =head1 METHODS 56 | 57 | Inherits from L. Also defines: 58 | 59 | =over 4 60 | 61 | =item $encoding = $e->encoding 62 | 63 | The encoding being specified. 64 | 65 | =back 66 | 67 | =head1 SOURCE 68 | 69 | The source code repository for Test2 can be found at 70 | F. 71 | 72 | =head1 MAINTAINERS 73 | 74 | =over 4 75 | 76 | =item Chad Granum Eexodist@cpan.orgE 77 | 78 | =back 79 | 80 | =head1 AUTHORS 81 | 82 | =over 4 83 | 84 | =item Chad Granum Eexodist@cpan.orgE 85 | 86 | =back 87 | 88 | =head1 COPYRIGHT 89 | 90 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 91 | 92 | This program is free software; you can redistribute it and/or 93 | modify it under the same terms as Perl itself. 94 | 95 | See F 96 | 97 | =cut 98 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/TAP/Version.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::TAP::Version; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | use Carp qw/croak/; 8 | 9 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 10 | use Test2::Util::HashBase qw/version/; 11 | 12 | sub init { 13 | my $self = shift; 14 | defined $self->{+VERSION} or croak "'version' is a required attribute"; 15 | } 16 | 17 | sub summary { 'TAP version ' . $_[0]->{+VERSION} } 18 | 19 | sub facet_data { 20 | my $self = shift; 21 | 22 | my $out = $self->common_facet_data; 23 | 24 | $out->{about}->{details} = $self->summary; 25 | 26 | push @{$out->{info}} => { 27 | tag => 'INFO', 28 | debug => 0, 29 | details => $self->summary, 30 | }; 31 | 32 | return $out; 33 | } 34 | 35 | 1; 36 | 37 | __END__ 38 | 39 | =pod 40 | 41 | =encoding UTF-8 42 | 43 | =head1 NAME 44 | 45 | Test2::Event::TAP::Version - Event for TAP version. 46 | 47 | =head1 DESCRIPTION 48 | 49 | This event is used if a TAP formatter wishes to set a version. 50 | 51 | =head1 SYNOPSIS 52 | 53 | use Test2::API qw/context/; 54 | use Test2::Event::Encoding; 55 | 56 | my $ctx = context(); 57 | my $event = $ctx->send_event('TAP::Version', version => 42); 58 | 59 | =head1 METHODS 60 | 61 | Inherits from L. Also defines: 62 | 63 | =over 4 64 | 65 | =item $version = $e->version 66 | 67 | The TAP version being parsed. 68 | 69 | =back 70 | 71 | =head1 SOURCE 72 | 73 | The source code repository for Test2 can be found at 74 | F. 75 | 76 | =head1 MAINTAINERS 77 | 78 | =over 4 79 | 80 | =item Chad Granum Eexodist@cpan.orgE 81 | 82 | =back 83 | 84 | =head1 AUTHORS 85 | 86 | =over 4 87 | 88 | =item Chad Granum Eexodist@cpan.orgE 89 | 90 | =back 91 | 92 | =head1 COPYRIGHT 93 | 94 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 95 | 96 | This program is free software; you can redistribute it and/or 97 | modify it under the same terms as Perl itself. 98 | 99 | See F 100 | 101 | =cut 102 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Error.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Error; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | sub facet_key { 'errors' } 8 | sub is_list { 1 } 9 | 10 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 11 | use Test2::Util::HashBase qw{ -tag -fail }; 12 | 13 | 1; 14 | 15 | __END__ 16 | 17 | =pod 18 | 19 | =encoding UTF-8 20 | 21 | =head1 NAME 22 | 23 | Test2::EventFacet::Error - Facet for errors that need to be shown. 24 | 25 | =head1 DESCRIPTION 26 | 27 | This facet is used when an event needs to convey errors. 28 | 29 | =head1 NOTES 30 | 31 | This facet has the hash key C<'errors'>, and is a list of facets instead of a 32 | single item. 33 | 34 | =head1 FIELDS 35 | 36 | =over 4 37 | 38 | =item $string = $error->{details} 39 | 40 | =item $string = $error->details() 41 | 42 | Explanation of the error, or the error itself (such as an exception). In perl 43 | exceptions may be blessed objects, so this field may contain a blessed object. 44 | 45 | =item $short_string = $error->{tag} 46 | 47 | =item $short_string = $error->tag() 48 | 49 | Short tag to categorize the error. This is usually 10 characters or less, 50 | formatters may truncate longer tags. 51 | 52 | =item $bool = $error->{fail} 53 | 54 | =item $bool = $error->fail() 55 | 56 | Not all errors are fatal, some are displayed having already been handled. Set 57 | this to true if you want the error to cause the test to fail. Without this the 58 | error is simply a diagnostics message that has no effect on the overall 59 | pass/fail result. 60 | 61 | =back 62 | 63 | =head1 SOURCE 64 | 65 | The source code repository for Test2 can be found at 66 | F. 67 | 68 | =head1 MAINTAINERS 69 | 70 | =over 4 71 | 72 | =item Chad Granum Eexodist@cpan.orgE 73 | 74 | =back 75 | 76 | =head1 AUTHORS 77 | 78 | =over 4 79 | 80 | =item Chad Granum Eexodist@cpan.orgE 81 | 82 | =back 83 | 84 | =head1 COPYRIGHT 85 | 86 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 87 | 88 | This program is free software; you can redistribute it and/or 89 | modify it under the same terms as Perl itself. 90 | 91 | See F 92 | 93 | =cut 94 | -------------------------------------------------------------------------------- /t/header_ok.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 3 | eval { require 'ddclient'; } or BAIL_OUT($@); 4 | my $have_mock = eval { require Test::MockModule; }; 5 | 6 | my $failmsg; 7 | my $module; 8 | if ($have_mock) { 9 | $module = Test::MockModule->new('ddclient'); 10 | # Note: 'mock' is used instead of 'redefine' because 'redefine' is not available in the versions 11 | # of Test::MockModule distributed with old Debian and Ubuntu releases. 12 | $module->mock('failed', sub { $failmsg //= ''; $failmsg .= sprintf(shift, @_) . "\n"; }); 13 | } 14 | 15 | my @test_cases = ( 16 | { 17 | desc => 'malformed not OK', 18 | input => 'malformed', 19 | want => 0, 20 | wantmsg => qr/unexpected/, 21 | }, 22 | { 23 | desc => 'HTTP/1.1 200 OK', 24 | input => 'HTTP/1.1 200 OK', 25 | want => 1, 26 | }, 27 | { 28 | desc => 'HTTP/2 200 OK', 29 | input => 'HTTP/2 200 OK', 30 | want => 1, 31 | }, 32 | { 33 | desc => 'HTTP/3 200 OK', 34 | input => 'HTTP/3 200 OK', 35 | want => 1, 36 | }, 37 | { 38 | desc => '401 not OK, fallback message', 39 | input => 'HTTP/1.1 401 ', 40 | want => 0, 41 | wantmsg => qr/authentication failed/, 42 | }, 43 | { 44 | desc => '403 not OK, fallback message', 45 | input => 'HTTP/1.1 403 ', 46 | want => 0, 47 | wantmsg => qr/not authorized/, 48 | }, 49 | { 50 | desc => 'other 4xx not OK', 51 | input => 'HTTP/1.1 456 bad', 52 | want => 0, 53 | wantmsg => qr/bad/, 54 | }, 55 | { 56 | desc => 'only first line is logged on error', 57 | input => "HTTP/1.1 404 not found\n\nbody", 58 | want => 0, 59 | wantmsg => qr/(?!body)/, 60 | }, 61 | ); 62 | 63 | for my $tc (@test_cases) { 64 | subtest $tc->{desc} => sub { 65 | $failmsg = ''; 66 | is(ddclient::header_ok($tc->{input}), $tc->{want}, 'return value matches'); 67 | SKIP: { 68 | skip('Test::MockModule not available') if !$have_mock; 69 | like($failmsg, $tc->{wantmsg} // qr/^$/, 'fail message matches'); 70 | } 71 | }; 72 | } 73 | 74 | done_testing(); 75 | -------------------------------------------------------------------------------- /t/geturl_connectivity.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 4 | use ddclient::t::HTTPD; 5 | use ddclient::t::ip; 6 | 7 | httpd_required(); 8 | 9 | $ddclient::globals{'ssl_ca_file'} = $ca_file; 10 | 11 | for my $ipv ('4', '6') { 12 | for my $ssl (0, 1) { 13 | my $httpd = httpd($ipv, $ssl) or next; 14 | $httpd->run(sub { 15 | return [200, ['Content-Type' => 'application/octet-stream'], [$_[0]->as_string()]]; 16 | }); 17 | } 18 | } 19 | 20 | my @test_cases = ( 21 | {ipv6_opt => 0, server_ipv => '4', client_ipv => ''}, 22 | {ipv6_opt => 0, server_ipv => '4', client_ipv => '4'}, 23 | # IPv* client to a non-SSL IPv6 server is not expected to work unless opt('ipv6') is true 24 | {ipv6_opt => 0, server_ipv => '6', client_ipv => '6'}, 25 | 26 | # Fetch without ssl 27 | { server_ipv => '4', client_ipv => '' }, 28 | { server_ipv => '4', client_ipv => '4' }, 29 | { server_ipv => '6', client_ipv => '' }, 30 | { server_ipv => '6', client_ipv => '6' }, 31 | 32 | # Fetch with ssl 33 | { ssl => 1, server_ipv => '4', client_ipv => '' }, 34 | { ssl => 1, server_ipv => '4', client_ipv => '4' }, 35 | { ssl => 1, server_ipv => '6', client_ipv => '' }, 36 | { ssl => 1, server_ipv => '6', client_ipv => '6' }, 37 | ); 38 | 39 | for my $tc (@test_cases) { 40 | $tc->{ipv6_opt} //= 0; 41 | $tc->{ssl} //= 0; 42 | SKIP: { 43 | skip("IPv6 not supported on this system", 1) 44 | if $tc->{server_ipv} eq '6' && !$ipv6_supported; 45 | skip("HTTP::Daemon too old for IPv6 support", 1) 46 | if $tc->{server_ipv} eq '6' && !$httpd_ipv6_supported; 47 | skip("HTTP::Daemon::SSL not available", 1) if $tc->{ssl} && !$httpd_ssl_supported; 48 | my $uri = httpd($tc->{server_ipv}, $tc->{ssl})->endpoint(); 49 | my $name = sprintf("IPv%s client to %s%s", 50 | $tc->{client_ipv} || '*', $uri, $tc->{ipv6_opt} ? ' (-ipv6)' : ''); 51 | $ddclient::globals{'ipv6'} = $tc->{ipv6_opt}; 52 | my $got = ddclient::geturl(url => $uri, ipversion => $tc->{client_ipv}); 53 | isnt($got // '', '', $name); 54 | } 55 | } 56 | 57 | done_testing(); 58 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Bail.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Bail; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 9 | use Test2::Util::HashBase qw{reason buffered}; 10 | 11 | # Make sure the tests terminate 12 | sub terminate { 255 }; 13 | 14 | sub global { 1 }; 15 | 16 | sub causes_fail { 1 } 17 | 18 | sub summary { 19 | my $self = shift; 20 | return "Bail out! " . $self->{+REASON} 21 | if $self->{+REASON}; 22 | 23 | return "Bail out!"; 24 | } 25 | 26 | sub diagnostics { 1 } 27 | 28 | sub facet_data { 29 | my $self = shift; 30 | my $out = $self->common_facet_data; 31 | 32 | $out->{control} = { 33 | global => 1, 34 | halt => 1, 35 | details => $self->{+REASON}, 36 | terminate => 255, 37 | }; 38 | 39 | return $out; 40 | } 41 | 42 | 1; 43 | 44 | __END__ 45 | 46 | =pod 47 | 48 | =encoding UTF-8 49 | 50 | =head1 NAME 51 | 52 | Test2::Event::Bail - Bailout! 53 | 54 | =head1 DESCRIPTION 55 | 56 | The bailout event is generated when things go horribly wrong and you need to 57 | halt all testing in the current file. 58 | 59 | =head1 SYNOPSIS 60 | 61 | use Test2::API qw/context/; 62 | use Test2::Event::Bail; 63 | 64 | my $ctx = context(); 65 | my $event = $ctx->bail('Stuff is broken'); 66 | 67 | =head1 METHODS 68 | 69 | Inherits from L. Also defines: 70 | 71 | =over 4 72 | 73 | =item $reason = $e->reason 74 | 75 | The reason for the bailout. 76 | 77 | =back 78 | 79 | =head1 SOURCE 80 | 81 | The source code repository for Test2 can be found at 82 | F. 83 | 84 | =head1 MAINTAINERS 85 | 86 | =over 4 87 | 88 | =item Chad Granum Eexodist@cpan.orgE 89 | 90 | =back 91 | 92 | =head1 AUTHORS 93 | 94 | =over 4 95 | 96 | =item Chad Granum Eexodist@cpan.orgE 97 | 98 | =back 99 | 100 | =head1 COPYRIGHT 101 | 102 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 103 | 104 | This program is free software; you can redistribute it and/or 105 | modify it under the same terms as Perl itself. 106 | 107 | See F 108 | 109 | =cut 110 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Plan.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Plan; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 8 | use Test2::Util::HashBase qw{ -count -skip -none }; 9 | 10 | 1; 11 | 12 | __END__ 13 | 14 | =pod 15 | 16 | =encoding UTF-8 17 | 18 | =head1 NAME 19 | 20 | Test2::EventFacet::Plan - Facet for setting the plan 21 | 22 | =head1 DESCRIPTION 23 | 24 | Events use this facet when they need to set the plan. 25 | 26 | =head1 FIELDS 27 | 28 | =over 4 29 | 30 | =item $string = $plan->{details} 31 | 32 | =item $string = $plan->details() 33 | 34 | Human readable explanation for the plan being set. This is normally not 35 | rendered by most formatters except when the C field is also set. 36 | 37 | =item $positive_int = $plan->{count} 38 | 39 | =item $positive_int = $plan->count() 40 | 41 | Set the number of expected assertions. This should usually be set to C<0> when 42 | C or C are also set. 43 | 44 | =item $bool = $plan->{skip} 45 | 46 | =item $bool = $plan->skip() 47 | 48 | When true the entire test should be skipped. This is usually paired with an 49 | explanation in the C
field, and a C facet that has 50 | C set to C<0>. 51 | 52 | =item $bool = $plan->{none} 53 | 54 | =item $bool = $plan->none() 55 | 56 | This is mainly used by legacy L tests which set the plan to C, a construct that predates the much better C. 58 | 59 | If you are using this in non-legacy code you may need to reconsider the course 60 | of your life, maybe a hermitage would suite you? 61 | 62 | =back 63 | 64 | =head1 SOURCE 65 | 66 | The source code repository for Test2 can be found at 67 | F. 68 | 69 | =head1 MAINTAINERS 70 | 71 | =over 4 72 | 73 | =item Chad Granum Eexodist@cpan.orgE 74 | 75 | =back 76 | 77 | =head1 AUTHORS 78 | 79 | =over 4 80 | 81 | =item Chad Granum Eexodist@cpan.orgE 82 | 83 | =back 84 | 85 | =head1 COPYRIGHT 86 | 87 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 88 | 89 | This program is free software; you can redistribute it and/or 90 | modify it under the same terms as Perl itself. 91 | 92 | See F 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Exception.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Exception; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 9 | use Test2::Util::HashBase qw{error}; 10 | 11 | sub init { 12 | my $self = shift; 13 | $self->{+ERROR} = "$self->{+ERROR}"; 14 | } 15 | 16 | sub causes_fail { 1 } 17 | 18 | sub summary { 19 | my $self = shift; 20 | chomp(my $msg = "Exception: " . $self->{+ERROR}); 21 | return $msg; 22 | } 23 | 24 | sub diagnostics { 1 } 25 | 26 | sub facet_data { 27 | my $self = shift; 28 | my $out = $self->common_facet_data; 29 | 30 | $out->{errors} = [ 31 | { 32 | tag => 'ERROR', 33 | fail => 1, 34 | details => $self->{+ERROR}, 35 | } 36 | ]; 37 | 38 | return $out; 39 | } 40 | 41 | 42 | 1; 43 | 44 | __END__ 45 | 46 | =pod 47 | 48 | =encoding UTF-8 49 | 50 | =head1 NAME 51 | 52 | Test2::Event::Exception - Exception event 53 | 54 | =head1 DESCRIPTION 55 | 56 | An exception event will display to STDERR, and will prevent the overall test 57 | file from passing. 58 | 59 | =head1 SYNOPSIS 60 | 61 | use Test2::API qw/context/; 62 | use Test2::Event::Exception; 63 | 64 | my $ctx = context(); 65 | my $event = $ctx->send_event('Exception', error => 'Stuff is broken'); 66 | 67 | =head1 METHODS 68 | 69 | Inherits from L. Also defines: 70 | 71 | =over 4 72 | 73 | =item $reason = $e->error 74 | 75 | The reason for the exception. 76 | 77 | =back 78 | 79 | =head1 CAVEATS 80 | 81 | Be aware that all exceptions are stringified during construction. 82 | 83 | =head1 SOURCE 84 | 85 | The source code repository for Test2 can be found at 86 | F. 87 | 88 | =head1 MAINTAINERS 89 | 90 | =over 4 91 | 92 | =item Chad Granum Eexodist@cpan.orgE 93 | 94 | =back 95 | 96 | =head1 AUTHORS 97 | 98 | =over 4 99 | 100 | =item Chad Granum Eexodist@cpan.orgE 101 | 102 | =back 103 | 104 | =head1 COPYRIGHT 105 | 106 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 107 | 108 | This program is free software; you can redistribute it and/or 109 | modify it under the same terms as Perl itself. 110 | 111 | See F 112 | 113 | =cut 114 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Meta.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Meta; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 8 | use vars qw/$AUTOLOAD/; 9 | 10 | # replace set_details 11 | { 12 | no warnings 'redefine'; 13 | sub set_details { $_[0]->{'set_details'} } 14 | } 15 | 16 | sub can { 17 | my $self = shift; 18 | my ($name) = @_; 19 | 20 | my $existing = $self->SUPER::can($name); 21 | return $existing if $existing; 22 | 23 | # Only vivify when called on an instance, do not vivify for a class. There 24 | # are a lot of magic class methods used in things like serialization (or 25 | # the forks.pm module) which cause problems when vivified. 26 | return undef unless ref($self); 27 | 28 | my $sub = sub { $_[0]->{$name} }; 29 | { 30 | no strict 'refs'; 31 | *$name = $sub; 32 | } 33 | 34 | return $sub; 35 | } 36 | 37 | sub AUTOLOAD { 38 | my $name = $AUTOLOAD; 39 | $name =~ s/^.*:://g; 40 | my $sub = $_[0]->can($name); 41 | goto &$sub; 42 | } 43 | 44 | 1; 45 | 46 | __END__ 47 | 48 | =pod 49 | 50 | =encoding UTF-8 51 | 52 | =head1 NAME 53 | 54 | Test2::EventFacet::Meta - Facet for meta-data 55 | 56 | =head1 DESCRIPTION 57 | 58 | This facet can contain any random meta-data that has been attached to the 59 | event. 60 | 61 | =head1 METHODS AND FIELDS 62 | 63 | Any/all fields and accessors are autovivified into existence. There is no way 64 | to know what metadata may be added, so any is allowed. 65 | 66 | =over 4 67 | 68 | =item $anything = $meta->{anything} 69 | 70 | =item $anything = $meta->anything() 71 | 72 | =back 73 | 74 | =head1 SOURCE 75 | 76 | The source code repository for Test2 can be found at 77 | F. 78 | 79 | =head1 MAINTAINERS 80 | 81 | =over 4 82 | 83 | =item Chad Granum Eexodist@cpan.orgE 84 | 85 | =back 86 | 87 | =head1 AUTHORS 88 | 89 | =over 4 90 | 91 | =item Chad Granum Eexodist@cpan.orgE 92 | 93 | =back 94 | 95 | =head1 COPYRIGHT 96 | 97 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 98 | 99 | This program is free software; you can redistribute it and/or 100 | modify it under the same terms as Perl itself. 101 | 102 | See F 103 | 104 | =cut 105 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Hub.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Hub; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | sub is_list { 1 } 8 | sub facet_key { 'hubs' } 9 | 10 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 11 | use Test2::Util::HashBase qw{-pid -tid -hid -nested -buffered -uuid -ipc}; 12 | 13 | 1; 14 | 15 | __END__ 16 | 17 | =pod 18 | 19 | =encoding UTF-8 20 | 21 | =head1 NAME 22 | 23 | Test2::EventFacet::Hub - Facet for the hubs an event passes through. 24 | 25 | =head1 DESCRIPTION 26 | 27 | These are a record of the hubs an event passes through. Most recent hub is the 28 | first one in the list. 29 | 30 | =head1 FACET FIELDS 31 | 32 | =over 4 33 | 34 | =item $string = $trace->{details} 35 | 36 | =item $string = $trace->details() 37 | 38 | The hub class or subclass 39 | 40 | =item $int = $trace->{pid} 41 | 42 | =item $int = $trace->pid() 43 | 44 | PID of the hub this event was sent to. 45 | 46 | =item $int = $trace->{tid} 47 | 48 | =item $int = $trace->tid() 49 | 50 | The thread ID of the hub the event was sent to. 51 | 52 | =item $hid = $trace->{hid} 53 | 54 | =item $hid = $trace->hid() 55 | 56 | The ID of the hub that the event was send to. 57 | 58 | =item $huuid = $trace->{huuid} 59 | 60 | =item $huuid = $trace->huuid() 61 | 62 | The UUID of the hub that the event was sent to. 63 | 64 | =item $int = $trace->{nested} 65 | 66 | =item $int = $trace->nested() 67 | 68 | How deeply nested the hub was. 69 | 70 | =item $bool = $trace->{buffered} 71 | 72 | =item $bool = $trace->buffered() 73 | 74 | True if the event was buffered and not sent to the formatter independent of a 75 | parent (This should never be set when nested is C<0> or C). 76 | 77 | =back 78 | 79 | =head1 SOURCE 80 | 81 | The source code repository for Test2 can be found at 82 | F. 83 | 84 | =head1 MAINTAINERS 85 | 86 | =over 4 87 | 88 | =item Chad Granum Eexodist@cpan.orgE 89 | 90 | =back 91 | 92 | =head1 AUTHORS 93 | 94 | =over 4 95 | 96 | =item Chad Granum Eexodist@cpan.orgE 97 | 98 | =back 99 | 100 | =head1 COPYRIGHT 101 | 102 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 103 | 104 | This program is free software; you can redistribute it and/or 105 | modify it under the same terms as Perl itself. 106 | 107 | See F 108 | 109 | =cut 110 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Pass.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Pass; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | use Test2::EventFacet::Info; 8 | 9 | BEGIN { 10 | require Test2::Event; 11 | our @ISA = qw(Test2::Event); 12 | *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; 13 | } 14 | 15 | use Test2::Util::HashBase qw{ -name -info }; 16 | 17 | ############## 18 | # Old API 19 | sub summary { "pass" } 20 | sub increments_count { 1 } 21 | sub causes_fail { 0 } 22 | sub diagnostics { 0 } 23 | sub no_display { 0 } 24 | sub subtest_id { undef } 25 | sub terminate { () } 26 | sub global { () } 27 | sub sets_plan { () } 28 | 29 | ############## 30 | # New API 31 | 32 | sub add_info { 33 | my $self = shift; 34 | 35 | for my $in (@_) { 36 | $in = {%$in} if ref($in) ne 'ARRAY'; 37 | $in = Test2::EventFacet::Info->new($in); 38 | 39 | push @{$self->{+INFO}} => $in; 40 | } 41 | } 42 | 43 | sub facet_data { 44 | my $self = shift; 45 | 46 | my $out = $self->common_facet_data; 47 | 48 | $out->{about}->{details} = 'pass'; 49 | 50 | $out->{assert} = {pass => 1, details => $self->{+NAME}}; 51 | 52 | $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; 53 | 54 | return $out; 55 | } 56 | 57 | 1; 58 | 59 | __END__ 60 | 61 | =pod 62 | 63 | =encoding UTF-8 64 | 65 | =head1 NAME 66 | 67 | Test2::Event::Pass - Event for a simple passing assertion 68 | 69 | =head1 DESCRIPTION 70 | 71 | This is an optimal representation of a passing assertion. 72 | 73 | =head1 SYNOPSIS 74 | 75 | use Test2::API qw/context/; 76 | 77 | sub pass { 78 | my ($name) = @_; 79 | my $ctx = context(); 80 | $ctx->pass($name); 81 | $ctx->release; 82 | } 83 | 84 | =head1 SOURCE 85 | 86 | The source code repository for Test2 can be found at 87 | F. 88 | 89 | =head1 MAINTAINERS 90 | 91 | =over 4 92 | 93 | =item Chad Granum Eexodist@cpan.orgE 94 | 95 | =back 96 | 97 | =head1 AUTHORS 98 | 99 | =over 4 100 | 101 | =item Chad Granum Eexodist@cpan.orgE 102 | 103 | =back 104 | 105 | =head1 COPYRIGHT 106 | 107 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 108 | 109 | This program is free software; you can redistribute it and/or 110 | modify it under the same terms as Perl itself. 111 | 112 | See F 113 | 114 | =cut 115 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Control.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Control; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 8 | use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase }; 9 | 10 | 1; 11 | 12 | __END__ 13 | 14 | =pod 15 | 16 | =encoding UTF-8 17 | 18 | =head1 NAME 19 | 20 | Test2::EventFacet::Control - Facet for hub actions and behaviors. 21 | 22 | =head1 DESCRIPTION 23 | 24 | This facet is used when the event needs to give instructions to the Test2 25 | internals. 26 | 27 | =head1 FIELDS 28 | 29 | =over 4 30 | 31 | =item $string = $control->{details} 32 | 33 | =item $string = $control->details() 34 | 35 | Human readable explanation for the special behavior. 36 | 37 | =item $bool = $control->{global} 38 | 39 | =item $bool = $control->global() 40 | 41 | True if the event is global in nature and should be seen by all hubs. 42 | 43 | =item $exit = $control->{terminate} 44 | 45 | =item $exit = $control->terminate() 46 | 47 | Defined if the test should immediately exit, the value is the exit code and may 48 | be C<0>. 49 | 50 | =item $bool = $control->{halt} 51 | 52 | =item $bool = $control->halt() 53 | 54 | True if all testing should be halted immediately. 55 | 56 | =item $bool = $control->{has_callback} 57 | 58 | =item $bool = $control->has_callback() 59 | 60 | True if the C method on the event should be called. 61 | 62 | =item $encoding = $control->{encoding} 63 | 64 | =item $encoding = $control->encoding() 65 | 66 | This can be used to change the encoding from this event onward. 67 | 68 | =item $phase = $control->{phase} 69 | 70 | =item $phase = $control->phase() 71 | 72 | Used to signal that a phase change has occurred. Currently only the perl END 73 | phase is signaled. 74 | 75 | =back 76 | 77 | =head1 SOURCE 78 | 79 | The source code repository for Test2 can be found at 80 | F. 81 | 82 | =head1 MAINTAINERS 83 | 84 | =over 4 85 | 86 | =item Chad Granum Eexodist@cpan.orgE 87 | 88 | =back 89 | 90 | =head1 AUTHORS 91 | 92 | =over 4 93 | 94 | =item Chad Granum Eexodist@cpan.orgE 95 | 96 | =back 97 | 98 | =head1 COPYRIGHT 99 | 100 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 101 | 102 | This program is free software; you can redistribute it and/or 103 | modify it under the same terms as Perl itself. 104 | 105 | See F 106 | 107 | =cut 108 | -------------------------------------------------------------------------------- /.github/workflows/scripts/dist-tarball-check: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | pecho() { printf %s\\n "$*"; } 4 | log() { pecho "$@"; } 5 | warning() { log "::warning::$@"; } 6 | error() { log "::error::$@"; } 7 | fatal() { error "$@"; exit 1; } 8 | try() { "$@" || fatal "'$@' failed"; } 9 | 10 | # actions/checkout@v2 only makes a clone if Git is v2.18 or later, and this 11 | # test requires a clone. 12 | git_ver=$(try dpkg-query -f '${Version}' -W git) || exit 1 13 | dpkg --compare-versions "${git_ver}" ge '1:2.18~' || { 14 | warning "This test requires Git v2.18 or later" 15 | exit 0 16 | } 17 | 18 | dist_tarball=$(ls ddclient-*.tar.gz) \ 19 | || fatal "'make dist' must be run before this test" 20 | 21 | tmpdir=$(try mktemp -d) || exit 1 22 | # newer git versions are particular about file ownership which can be ignored here 23 | git config --global --add safe.directory /__w/ddclient/ddclient || true 24 | 25 | log "Copying contents of Git repository..." 26 | try git archive --format=tar --prefix=git-repo/ HEAD \ 27 | | try tar -C "${tmpdir}" -xv || exit 1 28 | ( 29 | try cd "${tmpdir}"/git-repo 30 | # Delete files checked into Git that shouldn't be in the distribution 31 | # tarball. 32 | try rm -rf \ 33 | .envrc \ 34 | .github \ 35 | .gitignore \ 36 | docs/ipv6-design-doc.md \ 37 | docs/ProviderGuidelines.md \ 38 | shell.nix \ 39 | ; 40 | # TODO: Delete this next line once support for Automake 1.11 is dropped and 41 | # tap-driver.sh is removed from the Git repository. It is deleted here to 42 | # avoid a spurious diff. 43 | try rm -f build-aux/tap-driver.sh 44 | ) || exit 1 45 | 46 | log "Extracting distribution tarball..." 47 | try tar -C "${tmpdir}" -xvzf "${dist_tarball}" 48 | try mv "${tmpdir}/${dist_tarball%.tar.gz}" "${tmpdir}"/dist-tarball 49 | ( 50 | try cd "${tmpdir}"/dist-tarball 51 | # Delete generated files 52 | try rm -rf \ 53 | Makefile.in \ 54 | aclocal.m4 \ 55 | build-aux/install-sh \ 56 | build-aux/missing \ 57 | build-aux/tap-driver.sh \ 58 | configure \ 59 | ; 60 | ) || exit 1 61 | 62 | log "Comparing Git repository with distribution tarball..." 63 | cd "${tmpdir}" 64 | diff -qNr git-repo dist-tarball >/dev/null || { 65 | error "Unexpected diff between the repo and the distribution tarball." 66 | error "You may need to add a file to EXTRA_DIST in Makefile.am." 67 | error "Diff output:" 68 | diff -uNr git-repo dist-tarball \ 69 | | while IFS= read -r line; do error "${line}"; done 70 | exit 1 71 | } 72 | log "No difference" 73 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Render.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Render; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | sub is_list { 1 } 8 | 9 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 10 | use Test2::Util::HashBase qw{ -tag -facet -mode }; 11 | 12 | 1; 13 | 14 | __END__ 15 | 16 | =pod 17 | 18 | =encoding UTF-8 19 | 20 | =head1 NAME 21 | 22 | Test2::EventFacet::Render - Facet that dictates how to render an event. 23 | 24 | =head1 DESCRIPTION 25 | 26 | This facet is used to dictate how the event should be rendered by the standard 27 | test2 rendering tools. If this facet is present then ONLY what is specified by 28 | it will be rendered. It is assumed that anything important or note-worthy will 29 | be present here, no other facets will be considered for rendering/display. 30 | 31 | This facet is a list type, you can add as many items as needed. 32 | 33 | =head1 FIELDS 34 | 35 | =over 4 36 | 37 | =item $string = $render->[#]->{details} 38 | 39 | =item $string = $render->[#]->details() 40 | 41 | Human readable text for display. 42 | 43 | =item $string = $render->[#]->{tag} 44 | 45 | =item $string = $render->[#]->tag() 46 | 47 | Tag that should prefix/identify the main text. 48 | 49 | =item $string = $render->[#]->{facet} 50 | 51 | =item $string = $render->[#]->facet() 52 | 53 | Optional, if the display text was generated from another facet this should 54 | state what facet it was. 55 | 56 | =item $mode = $render->[#]->{mode} 57 | 58 | =item $mode = $render->[#]->mode() 59 | 60 | =over 4 61 | 62 | =item calculated 63 | 64 | Calculated means the facet was generated from another facet. Calculated facets 65 | may be cleared and regenerated whenever the event state changes. 66 | 67 | =item replace 68 | 69 | Replace means the facet is intended to replace the normal rendering of the 70 | event. 71 | 72 | =back 73 | 74 | =back 75 | 76 | =head1 SOURCE 77 | 78 | The source code repository for Test2 can be found at 79 | F. 80 | 81 | =head1 MAINTAINERS 82 | 83 | =over 4 84 | 85 | =item Chad Granum Eexodist@cpan.orgE 86 | 87 | =back 88 | 89 | =head1 AUTHORS 90 | 91 | =over 4 92 | 93 | =item Chad Granum Eexodist@cpan.orgE 94 | 95 | =back 96 | 97 | =head1 COPYRIGHT 98 | 99 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 100 | 101 | This program is free software; you can redistribute it and/or 102 | modify it under the same terms as Perl itself. 103 | 104 | See F 105 | 106 | =cut 107 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Fail.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Fail; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | use Test2::EventFacet::Info; 8 | 9 | BEGIN { 10 | require Test2::Event; 11 | our @ISA = qw(Test2::Event); 12 | *META_KEY = \&Test2::Util::ExternalMeta::META_KEY; 13 | } 14 | 15 | use Test2::Util::HashBase qw{ -name -info }; 16 | 17 | ############# 18 | # Old API 19 | sub summary { "fail" } 20 | sub increments_count { 1 } 21 | sub diagnostics { 0 } 22 | sub no_display { 0 } 23 | sub subtest_id { undef } 24 | sub terminate { () } 25 | sub global { () } 26 | sub sets_plan { () } 27 | 28 | sub causes_fail { 29 | my $self = shift; 30 | return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}}; 31 | return 1; 32 | } 33 | 34 | ############# 35 | # New API 36 | 37 | sub add_info { 38 | my $self = shift; 39 | 40 | for my $in (@_) { 41 | $in = {%$in} if ref($in) ne 'ARRAY'; 42 | $in = Test2::EventFacet::Info->new($in); 43 | 44 | push @{$self->{+INFO}} => $in; 45 | } 46 | } 47 | 48 | sub facet_data { 49 | my $self = shift; 50 | my $out = $self->common_facet_data; 51 | 52 | $out->{about}->{details} = 'fail'; 53 | 54 | $out->{assert} = {pass => 0, details => $self->{+NAME}}; 55 | 56 | $out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO}; 57 | 58 | return $out; 59 | } 60 | 61 | 1; 62 | 63 | __END__ 64 | 65 | =pod 66 | 67 | =encoding UTF-8 68 | 69 | =head1 NAME 70 | 71 | Test2::Event::Fail - Event for a simple failed assertion 72 | 73 | =head1 DESCRIPTION 74 | 75 | This is an optimal representation of a failed assertion. 76 | 77 | =head1 SYNOPSIS 78 | 79 | use Test2::API qw/context/; 80 | 81 | sub fail { 82 | my ($name) = @_; 83 | my $ctx = context(); 84 | $ctx->fail($name); 85 | $ctx->release; 86 | } 87 | 88 | =head1 SOURCE 89 | 90 | The source code repository for Test2 can be found at 91 | F. 92 | 93 | =head1 MAINTAINERS 94 | 95 | =over 4 96 | 97 | =item Chad Granum Eexodist@cpan.orgE 98 | 99 | =back 100 | 101 | =head1 AUTHORS 102 | 103 | =over 4 104 | 105 | =item Chad Granum Eexodist@cpan.orgE 106 | 107 | =back 108 | 109 | =head1 COPYRIGHT 110 | 111 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 112 | 113 | This program is free software; you can redistribute it and/or 114 | modify it under the same terms as Perl itself. 115 | 116 | See F 117 | 118 | =cut 119 | -------------------------------------------------------------------------------- /t/lib/Test/Builder/Formatter.pm: -------------------------------------------------------------------------------- 1 | package Test::Builder::Formatter; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) } 8 | 9 | use Test2::Util::HashBase qw/no_header no_diag/; 10 | 11 | BEGIN { 12 | *OUT_STD = Test2::Formatter::TAP->can('OUT_STD'); 13 | *OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR'); 14 | 15 | my $todo = OUT_ERR() + 1; 16 | *OUT_TODO = sub() { $todo }; 17 | } 18 | 19 | sub init { 20 | my $self = shift; 21 | $self->SUPER::init(@_); 22 | $self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD]; 23 | } 24 | 25 | sub plan_tap { 26 | my ($self, $f) = @_; 27 | 28 | return if $self->{+NO_HEADER}; 29 | return $self->SUPER::plan_tap($f); 30 | } 31 | 32 | sub debug_tap { 33 | my ($self, $f, $num) = @_; 34 | return if $self->{+NO_DIAG}; 35 | my @out = $self->SUPER::debug_tap($f, $num); 36 | $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} 37 | && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; 38 | return @out; 39 | } 40 | 41 | sub info_tap { 42 | my ($self, $f) = @_; 43 | return if $self->{+NO_DIAG}; 44 | my @out = $self->SUPER::info_tap($f); 45 | $self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package} 46 | && $f->{about}->{package} eq 'Test::Builder::TodoDiag'; 47 | return @out; 48 | } 49 | 50 | sub redirect { 51 | my ($self, $out) = @_; 52 | $_->[0] = OUT_TODO for @$out; 53 | } 54 | 55 | sub no_subtest_space { 1 } 56 | 57 | 1; 58 | 59 | __END__ 60 | 61 | =pod 62 | 63 | =encoding UTF-8 64 | 65 | =head1 NAME 66 | 67 | Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP 68 | 69 | =head1 DESCRIPTION 70 | 71 | This is what takes events and turns them into TAP. 72 | 73 | =head1 SYNOPSIS 74 | 75 | use Test::Builder; # Loads Test::Builder::Formatter for you 76 | 77 | =head1 SOURCE 78 | 79 | The source code repository for Test2 can be found at 80 | F. 81 | 82 | =head1 MAINTAINERS 83 | 84 | =over 4 85 | 86 | =item Chad Granum Eexodist@cpan.orgE 87 | 88 | =back 89 | 90 | =head1 AUTHORS 91 | 92 | =over 4 93 | 94 | =item Chad Granum Eexodist@cpan.orgE 95 | 96 | =back 97 | 98 | =head1 COPYRIGHT 99 | 100 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 101 | 102 | This program is free software; you can redistribute it and/or 103 | modify it under the same terms as Perl itself. 104 | 105 | See F 106 | 107 | =cut 108 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Skip.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Skip; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } 9 | use Test2::Util::HashBase qw{reason}; 10 | 11 | sub init { 12 | my $self = shift; 13 | $self->SUPER::init; 14 | $self->{+EFFECTIVE_PASS} = 1; 15 | } 16 | 17 | sub causes_fail { 0 } 18 | 19 | sub summary { 20 | my $self = shift; 21 | my $out = $self->SUPER::summary(@_); 22 | 23 | if (my $reason = $self->reason) { 24 | $out .= " (SKIP: $reason)"; 25 | } 26 | else { 27 | $out .= " (SKIP)"; 28 | } 29 | 30 | return $out; 31 | } 32 | 33 | sub extra_amnesty { 34 | my $self = shift; 35 | 36 | my @out; 37 | 38 | push @out => { 39 | tag => 'TODO', 40 | details => $self->{+TODO}, 41 | } if defined $self->{+TODO}; 42 | 43 | push @out => { 44 | tag => 'skip', 45 | details => $self->{+REASON}, 46 | inherited => 0, 47 | }; 48 | 49 | return @out; 50 | } 51 | 52 | 1; 53 | 54 | __END__ 55 | 56 | =pod 57 | 58 | =encoding UTF-8 59 | 60 | =head1 NAME 61 | 62 | Test2::Event::Skip - Skip event type 63 | 64 | =head1 DESCRIPTION 65 | 66 | Skip events bump test counts just like L events, but 67 | they can never fail. 68 | 69 | =head1 SYNOPSIS 70 | 71 | use Test2::API qw/context/; 72 | use Test2::Event::Skip; 73 | 74 | my $ctx = context(); 75 | my $event = $ctx->skip($name, $reason); 76 | 77 | or: 78 | 79 | my $ctx = context(); 80 | my $event = $ctx->send_event( 81 | 'Skip', 82 | name => $name, 83 | reason => $reason, 84 | ); 85 | 86 | =head1 ACCESSORS 87 | 88 | =over 4 89 | 90 | =item $reason = $e->reason 91 | 92 | The original true/false value of whatever was passed into the event (but 93 | reduced down to 1 or 0). 94 | 95 | =back 96 | 97 | =head1 SOURCE 98 | 99 | The source code repository for Test2 can be found at 100 | F. 101 | 102 | =head1 MAINTAINERS 103 | 104 | =over 4 105 | 106 | =item Chad Granum Eexodist@cpan.orgE 107 | 108 | =back 109 | 110 | =head1 AUTHORS 111 | 112 | =over 4 113 | 114 | =item Chad Granum Eexodist@cpan.orgE 115 | 116 | =back 117 | 118 | =head1 COPYRIGHT 119 | 120 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 121 | 122 | This program is free software; you can redistribute it and/or 123 | modify it under the same terms as Perl itself. 124 | 125 | See F 126 | 127 | =cut 128 | -------------------------------------------------------------------------------- /t/lib/Devel/Autoflush.pm: -------------------------------------------------------------------------------- 1 | package Devel::Autoflush; 2 | # ABSTRACT: Set autoflush from the command line 3 | our $VERSION = '0.06'; # VERSION 4 | 5 | my $kwalitee_nocritic = << 'END'; 6 | # can't use strict as older stricts load Carp and we can't allow side effects 7 | use strict; 8 | END 9 | 10 | my $old = select STDOUT; 11 | $|++; 12 | select STDERR; 13 | $|++; 14 | select $old; 15 | 16 | 1; 17 | 18 | __END__ 19 | 20 | =pod 21 | 22 | =encoding UTF-8 23 | 24 | =head1 NAME 25 | 26 | Devel::Autoflush - Set autoflush from the command line 27 | 28 | =head1 VERSION 29 | 30 | version 0.06 31 | 32 | =head1 SYNOPSIS 33 | 34 | perl -MDevel::Autoflush Makefile.PL 35 | 36 | =head1 DESCRIPTION 37 | 38 | This module is a hack to set autoflush for STDOUT and STDERR from the command 39 | line or from C for code that needs it but doesn't have it. 40 | 41 | This often happens when prompting: 42 | 43 | # guess.pl 44 | print "Guess a number: "; 45 | my $n = ; 46 | 47 | As long as the output is going to a terminal, the prompt is flushed when STDIN 48 | is read. However, if the output is being piped, the print statement will 49 | not automatically be flushed, no prompt will be seen and the program will 50 | silently appear to hang while waiting for input. This might happen with 'tee': 51 | 52 | $ perl guess.pl | tee capture.out 53 | 54 | Use Devel::Autoflush to work around this: 55 | 56 | $ perl -MDevel::Autoflush guess.pl | tee capture.out 57 | 58 | Or set it in C: 59 | 60 | $ export PERL5OPT=-MDevel::Autoflush 61 | $ perl guess.pl | tee capture.out 62 | 63 | = SEE ALSO 64 | 65 | =over 4 66 | 67 | =item * 68 | 69 | L -- same idea but STDOUT only and 70 | 71 | only available as part of the full CPANPLUS distribution 72 | 73 | =back 74 | 75 | =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan 76 | 77 | =head1 SUPPORT 78 | 79 | =head2 Bugs / Feature Requests 80 | 81 | Please report any bugs or feature requests through the issue tracker 82 | at L. 83 | You will be notified automatically of any progress on your issue. 84 | 85 | =head2 Source Code 86 | 87 | This is open source software. The code repository is available for 88 | public review and contribution under the terms of the license. 89 | 90 | L 91 | 92 | git clone https://github.com/dagolden/Devel-Autoflush.git 93 | 94 | =head1 AUTHOR 95 | 96 | David Golden 97 | 98 | =head1 COPYRIGHT AND LICENSE 99 | 100 | This software is Copyright (c) 2014 by David Golden. 101 | 102 | This is free software, licensed under: 103 | 104 | The Apache License, Version 2.0, January 2004 105 | 106 | =cut 107 | -------------------------------------------------------------------------------- /t/is-and-extract-ipv4.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use B qw(perlstring); 3 | 4 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 5 | eval { require 'ddclient'; } or BAIL_OUT($@); 6 | 7 | 8 | my @valid_ipv4 = ( 9 | "192.168.1.1", 10 | "0.0.0.0", 11 | "000.000.000.000", 12 | "255.255.255.255", 13 | "10.0.0.0", 14 | ); 15 | 16 | my @invalid_ipv4 = ( 17 | undef, 18 | "", 19 | "192.168.1", 20 | "0.0.0", 21 | "000.000", 22 | "256.256.256.256", 23 | ".10.0.0.0", 24 | ); 25 | 26 | 27 | subtest "is_ipv4() with valid addresses" => sub { 28 | foreach my $ip (@valid_ipv4) { 29 | ok(ddclient::is_ipv4($ip), "is_ipv4('$ip')"); 30 | } 31 | }; 32 | 33 | subtest "is_ipv4() with invalid addresses" => sub { 34 | foreach my $ip (@invalid_ipv4) { 35 | ok(!ddclient::is_ipv4($ip), sprintf("!is_ipv4(%s)", defined($ip) ? "'$ip'" : 'undef')); 36 | } 37 | }; 38 | 39 | subtest "is_ipv4() with char adjacent to valid address" => sub { 40 | foreach my $ch (split(//, '/.,:z @$#&%!^*()_-+'), "\n") { 41 | subtest perlstring($ch) => sub { 42 | foreach my $ip (@valid_ipv4) { 43 | subtest $ip => sub { 44 | my $test = $ch . $ip; # insert at front 45 | ok(!ddclient::is_ipv4($test), "!is_ipv4('$test')"); 46 | $test = $ip . $ch; # add at end 47 | ok(!ddclient::is_ipv4($test), "!is_ipv4('$test')"); 48 | $test = $ch . $ip . $ch; # wrap front and end 49 | ok(!ddclient::is_ipv4($test), "!is_ipv4('$test')"); 50 | }; 51 | } 52 | }; 53 | } 54 | }; 55 | 56 | subtest "extract_ipv4()" => sub { 57 | my @test_cases = ( 58 | {name => "undef", text => undef, want => undef}, 59 | {name => "empty", text => "", want => undef}, 60 | {name => "invalid", text => "1.2.3.256", want => undef}, 61 | {name => "two addrs", text => "1.1.1.1\n2.2.2.2", want => "1.1.1.1"}, 62 | {name => "host+port", text => "1.2.3.4:123", want => "1.2.3.4"}, 63 | {name => "zero pad", text => "001.002.003.004", want => "1.2.3.4"}, 64 | ); 65 | foreach my $tc (@test_cases) { 66 | is(ddclient::extract_ipv4($tc->{text}), $tc->{want}, $tc->{name}); 67 | } 68 | }; 69 | 70 | subtest "extract_ipv4() of valid addr with adjacent non-word char" => sub { 71 | foreach my $wb (split(//, '/, @$#&%!^*()_-+:'), "\n") { 72 | subtest perlstring($wb) => sub { 73 | my $test = ""; 74 | foreach my $ip (@valid_ipv4) { 75 | $test = "foo" . $wb . $ip . $wb . "bar"; # wrap front and end 76 | $ip =~ s/\b0+\B//g; ## remove embedded leading zeros for testing 77 | is(ddclient::extract_ipv4($test), $ip, perlstring($test)); 78 | } 79 | }; 80 | } 81 | }; 82 | 83 | done_testing(); 84 | -------------------------------------------------------------------------------- /t/is-and-extract-ipv6-global.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use ddclient::t; 3 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 4 | eval { require 'ddclient'; } or BAIL_OUT($@); 5 | 6 | subtest "is_ipv6_global() with valid but non-globally-routable addresses" => sub { 7 | foreach my $ip ( 8 | # The entirety of ::/16 is assumed to never contain globally routable addresses 9 | "::", 10 | "::1", 11 | "0:ffff:ffff:ffff:ffff:ffff:ffff:ffff", 12 | # fc00::/7 unique local addresses (ULA) 13 | "fc00::", 14 | "fdff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", 15 | # fe80::/10 link-local unicast addresses 16 | "fe80::", 17 | "febf:ffff:ffff:ffff:ffff:ffff:ffff:ffff", 18 | # ff00::/8 multicast addresses 19 | "ff00::", 20 | "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", 21 | # Case insensitivity of the negative lookahead 22 | "FF00::", 23 | ) { 24 | ok(!ddclient::is_ipv6_global($ip), "!is_ipv6_global('$ip')"); 25 | } 26 | }; 27 | 28 | subtest "is_ipv6_global() with valid, globally routable addresses" => sub { 29 | foreach my $ip ( 30 | "1::", # just after ::/16 assumed non-global block 31 | "fbff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", # just before fc00::/7 ULA block 32 | "fe00::", # just after fc00::/7 ULA block 33 | "fe7f:ffff:ffff:ffff:ffff:ffff:ffff:ffff", # just before fe80::/10 link-local block 34 | "fec0::", # just after fe80::/10 link-local block 35 | "feff:ffff:ffff:ffff:ffff:ffff:ffff:ffff", # just before ff00::/8 multicast block 36 | ) { 37 | ok(ddclient::is_ipv6_global($ip), "is_ipv6_global('$ip')"); 38 | } 39 | }; 40 | 41 | subtest "extract_ipv6_global()" => sub { 42 | my @test_cases = ( 43 | {name => "undef", text => undef, want => undef}, 44 | {name => "empty", text => "", want => undef}, 45 | {name => "only non-global", text => "foo fe80:: bar", want => undef}, 46 | {name => "single global", text => "foo 2000:: bar", want => "2000::"}, 47 | {name => "multiple globals", text => "2000:: 3000::", want => "2000::"}, 48 | {name => "global before non-global", text => "2000:: fe80::", want => "2000::"}, 49 | {name => "non-global before global", text => "fe80:: 2000::", want => "2000::"}, 50 | {name => "zero pad", text => "2001::0001", want => "2001::1"}, 51 | ); 52 | foreach my $tc (@test_cases) { 53 | is(ddclient::extract_ipv6_global($tc->{text}), $tc->{want}, $tc->{name}); 54 | } 55 | }; 56 | 57 | subtest "interface config samples" => sub { 58 | for my $sample (@ddclient::t::interface_samples) { 59 | if (defined($sample->{want_extract_ipv6_global})) { 60 | my $got = ddclient::extract_ipv6_global($sample->{text}); 61 | is($got, $sample->{want_extract_ipv6_global}, $sample->{name}); 62 | } 63 | } 64 | }; 65 | 66 | done_testing(); 67 | -------------------------------------------------------------------------------- /t/get_ip_from_if.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 4 | use ddclient::t; 5 | 6 | subtest "get_default_interface tests" => sub { 7 | for my $sample (@ddclient::t::routing_samples) { 8 | if (defined($sample->{want_ipv4_if})) { 9 | my $interface = ddclient::get_default_interface(4, $sample->{text}); 10 | is($interface, $sample->{want_ipv4_if}, $sample->{name}); 11 | } 12 | if (defined($sample->{want_ipv6_if})) { 13 | my $interface = ddclient::get_default_interface(6, $sample->{text}); 14 | is($interface, $sample->{want_ipv6_if}, $sample->{name}); 15 | } 16 | } 17 | }; 18 | 19 | subtest "get_ip_from_interface tests" => sub { 20 | for my $sample (@ddclient::t::interface_samples) { 21 | # interface name is undef as we are passing in test data 22 | if (defined($sample->{want_ipv4_from_if})) { 23 | my $ip = ddclient::get_ip_from_interface(undef, 4, undef, $sample->{text}, $sample->{MacOS}); 24 | is($ip, $sample->{want_ipv4_from_if}, $sample->{name}); 25 | } 26 | if (defined($sample->{want_ipv6gua_from_if})) { 27 | my $ip = ddclient::get_ip_from_interface(undef, 6, 'gua', $sample->{text}, $sample->{MacOS}); 28 | is($ip, $sample->{want_ipv6gua_from_if}, $sample->{name}); 29 | } 30 | if (defined($sample->{want_ipv6ula_from_if})) { 31 | my $ip = ddclient::get_ip_from_interface(undef, 6, 'ula', $sample->{text}, $sample->{MacOS}); 32 | is($ip, $sample->{want_ipv6ula_from_if}, $sample->{name}); 33 | } 34 | } 35 | }; 36 | 37 | subtest "Get default interface and IP for test system (IPv4)" => sub { 38 | my $interface = ddclient::get_default_interface(4); 39 | plan(skip_all => 'no IPv4 interface') if !$interface; 40 | isnt($interface, "lo", "Check for loopback 'lo'"); 41 | isnt($interface, "lo0", "Check for loopback 'lo0'"); 42 | my $ip1 = ddclient::get_ip_from_interface("default", 4); 43 | my $ip2 = ddclient::get_ip_from_interface($interface, 4); 44 | is($ip1, $ip2, "Check IPv4 from default interface"); 45 | SKIP: { 46 | skip('default interface does not have an appropriate IPv4 addresses') if !$ip1; 47 | ok(ddclient::is_ipv4($ip1), "Valid IPv4 from get_ip_from_interface($interface)"); 48 | } 49 | }; 50 | 51 | subtest "Get default interface and IP for test system (IPv6)" => sub { 52 | my $interface = ddclient::get_default_interface(6); 53 | plan(skip_all => 'no IPv6 interface') if !$interface; 54 | isnt($interface, "lo", "Check for loopback 'lo'"); 55 | isnt($interface, "lo0", "Check for loopback 'lo0'"); 56 | my $ip1 = ddclient::get_ip_from_interface("default", 6); 57 | my $ip2 = ddclient::get_ip_from_interface($interface, 6); 58 | is($ip1, $ip2, "Check IPv6 from default interface"); 59 | SKIP: { 60 | skip('default interface does not have an appropriate IPv6 addresses') if !$ip1; 61 | ok(ddclient::is_ipv6($ip1), "Valid IPv6 from get_ip_from_interface($interface)"); 62 | } 63 | }; 64 | 65 | done_testing(); 66 | -------------------------------------------------------------------------------- /t/lib/Test2/Hub/Subtest.pm: -------------------------------------------------------------------------------- 1 | package Test2::Hub::Subtest; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) } 8 | use Test2::Util::HashBase qw/nested exit_code manual_skip_all/; 9 | use Test2::Util qw/get_tid/; 10 | 11 | sub is_subtest { 1 } 12 | 13 | sub inherit { 14 | my $self = shift; 15 | my ($from) = @_; 16 | 17 | $self->SUPER::inherit($from); 18 | 19 | $self->{+NESTED} = $from->nested + 1; 20 | } 21 | 22 | { 23 | # Legacy 24 | no warnings 'once'; 25 | *ID = \&Test2::Hub::HID; 26 | *id = \&Test2::Hub::hid; 27 | *set_id = \&Test2::Hub::set_hid; 28 | } 29 | 30 | sub send { 31 | my $self = shift; 32 | my ($e) = @_; 33 | 34 | my $out = $self->SUPER::send($e); 35 | 36 | return $out if $self->{+MANUAL_SKIP_ALL}; 37 | 38 | my $f = $e->facet_data; 39 | 40 | my $plan = $f->{plan} or return $out; 41 | return $out unless $plan->{skip}; 42 | 43 | my $trace = $f->{trace} or die "Missing Trace!"; 44 | return $out unless $trace->{pid} != $self->pid 45 | || $trace->{tid} != $self->tid; 46 | 47 | no warnings 'exiting'; 48 | last T2_SUBTEST_WRAPPER; 49 | } 50 | 51 | sub terminate { 52 | my $self = shift; 53 | my ($code, $e, $f) = @_; 54 | $self->set_exit_code($code); 55 | 56 | return if $self->{+MANUAL_SKIP_ALL}; 57 | 58 | $f ||= $e->facet_data; 59 | 60 | if(my $plan = $f->{plan}) { 61 | my $trace = $f->{trace} or die "Missing Trace!"; 62 | return if $plan->{skip} 63 | && ($trace->{pid} != $$ || $trace->{tid} != get_tid); 64 | } 65 | 66 | no warnings 'exiting'; 67 | last T2_SUBTEST_WRAPPER; 68 | } 69 | 70 | 1; 71 | 72 | __END__ 73 | 74 | =pod 75 | 76 | =encoding UTF-8 77 | 78 | =head1 NAME 79 | 80 | Test2::Hub::Subtest - Hub used by subtests 81 | 82 | =head1 DESCRIPTION 83 | 84 | Subtests make use of this hub to route events. 85 | 86 | =head1 TOGGLES 87 | 88 | =over 4 89 | 90 | =item $bool = $hub->manual_skip_all 91 | 92 | =item $hub->set_manual_skip_all($bool) 93 | 94 | The default is false. 95 | 96 | Normally a skip-all plan event will cause a subtest to stop executing. This is 97 | accomplished via C to a label inside the subtest code. Most of the 98 | time this is perfectly fine. There are times however where this flow control 99 | causes bad things to happen. 100 | 101 | This toggle lets you turn off the abort logic for the hub. When this is toggled 102 | to true B are responsible for ensuring no additional events are generated. 103 | 104 | =back 105 | 106 | =head1 SOURCE 107 | 108 | The source code repository for Test2 can be found at 109 | F. 110 | 111 | =head1 MAINTAINERS 112 | 113 | =over 4 114 | 115 | =item Chad Granum Eexodist@cpan.orgE 116 | 117 | =back 118 | 119 | =head1 AUTHORS 120 | 121 | =over 4 122 | 123 | =item Chad Granum Eexodist@cpan.orgE 124 | 125 | =back 126 | 127 | =head1 COPYRIGHT 128 | 129 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 130 | 131 | This program is free software; you can redistribute it and/or 132 | modify it under the same terms as Perl itself. 133 | 134 | See F 135 | 136 | =cut 137 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Info/Table.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Info::Table; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | use Carp qw/confess/; 8 | 9 | use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string}; 10 | 11 | sub init { 12 | my $self = shift; 13 | 14 | confess "Table may not be empty" unless ref($self->{+ROWS}) eq 'ARRAY' && @{$self->{+ROWS}}; 15 | 16 | $self->{+AS_STRING} ||= ''; 17 | } 18 | 19 | sub as_hash { my $out = +{%{$_[0]}}; delete $out->{as_string}; $out } 20 | 21 | sub info_args { 22 | my $self = shift; 23 | 24 | my $hash = $self->as_hash; 25 | my $desc = $self->as_string; 26 | 27 | return (table => $hash, details => $desc); 28 | } 29 | 30 | 1; 31 | 32 | __END__ 33 | 34 | =pod 35 | 36 | =encoding UTF-8 37 | 38 | =head1 NAME 39 | 40 | Test2::EventFacet::Info::Table - Intermediary representation of a table. 41 | 42 | =head1 DESCRIPTION 43 | 44 | Intermediary representation of a table for use in specialized 45 | L methods which generate L facets. 46 | 47 | =head1 SYNOPSIS 48 | 49 | use Test2::EventFacet::Info::Table; 50 | use Test2::API qw/context/; 51 | 52 | sub my_tool { 53 | my $ctx = context(); 54 | 55 | ... 56 | 57 | $ctx->fail( 58 | $name, 59 | "failure diag message", 60 | Test2::EventFacet::Info::Table->new( 61 | # Required 62 | rows => [['a', 'b'], ['c', 'd'], ...], 63 | 64 | # Strongly Recommended 65 | as_string => "... string to print when table cannot be rendered ...", 66 | 67 | # Optional 68 | header => ['col1', 'col2'], 69 | collapse => $bool, 70 | no_collapse => ['col1', ...], 71 | ), 72 | ); 73 | 74 | ... 75 | 76 | $ctx->release; 77 | } 78 | 79 | my_tool(); 80 | 81 | =head1 ATTRIBUTES 82 | 83 | =over 4 84 | 85 | =item $header_aref = $t->header() 86 | 87 | =item $rows_aref = $t->rows() 88 | 89 | =item $bool = $t->collapse() 90 | 91 | =item $aref = $t->no_collapse() 92 | 93 | The above are all directly tied to the table hashref structure described in 94 | L. 95 | 96 | =item $str = $t->as_string() 97 | 98 | This returns the string form of the table if it was set, otherwise it returns 99 | the string C<< "
" >>. 100 | 101 | =item $href = $t->as_hash() 102 | 103 | This returns the data structure used for tables by L. 104 | 105 | =item %args = $t->info_args() 106 | 107 | This returns the arguments that should be used to construct the proper 108 | L structure. 109 | 110 | return (table => $t->as_hash(), details => $t->as_string()); 111 | 112 | =back 113 | 114 | =head1 SOURCE 115 | 116 | The source code repository for Test2 can be found at 117 | F. 118 | 119 | =head1 MAINTAINERS 120 | 121 | =over 4 122 | 123 | =item Chad Granum Eexodist@cpan.orgE 124 | 125 | =back 126 | 127 | =head1 AUTHORS 128 | 129 | =over 4 130 | 131 | =item Chad Granum Eexodist@cpan.orgE 132 | 133 | =back 134 | 135 | =head1 COPYRIGHT 136 | 137 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 138 | 139 | This program is free software; you can redistribute it and/or 140 | modify it under the same terms as Perl itself. 141 | 142 | See F 143 | 144 | =cut 145 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Ok.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Ok; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 9 | use Test2::Util::HashBase qw{ 10 | pass effective_pass name todo 11 | }; 12 | 13 | sub init { 14 | my $self = shift; 15 | 16 | # Do not store objects here, only true or false 17 | $self->{+PASS} = $self->{+PASS} ? 1 : 0; 18 | $self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0); 19 | } 20 | 21 | { 22 | no warnings 'redefine'; 23 | sub set_todo { 24 | my $self = shift; 25 | my ($todo) = @_; 26 | $self->{+TODO} = $todo; 27 | $self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS}; 28 | } 29 | } 30 | 31 | sub increments_count { 1 }; 32 | 33 | sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} } 34 | 35 | sub summary { 36 | my $self = shift; 37 | 38 | my $name = $self->{+NAME} || "Nameless Assertion"; 39 | 40 | my $todo = $self->{+TODO}; 41 | if ($todo) { 42 | $name .= " (TODO: $todo)"; 43 | } 44 | elsif (defined $todo) { 45 | $name .= " (TODO)" 46 | } 47 | 48 | return $name; 49 | } 50 | 51 | sub extra_amnesty { 52 | my $self = shift; 53 | return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS}); 54 | return { 55 | tag => 'TODO', 56 | details => $self->{+TODO}, 57 | }; 58 | } 59 | 60 | sub facet_data { 61 | my $self = shift; 62 | 63 | my $out = $self->common_facet_data; 64 | 65 | $out->{assert} = { 66 | no_debug => 1, # Legacy behavior 67 | pass => $self->{+PASS}, 68 | details => $self->{+NAME}, 69 | }; 70 | 71 | if (my @exra_amnesty = $self->extra_amnesty) { 72 | unshift @{$out->{amnesty}} => @exra_amnesty; 73 | } 74 | 75 | return $out; 76 | } 77 | 78 | 1; 79 | 80 | __END__ 81 | 82 | =pod 83 | 84 | =encoding UTF-8 85 | 86 | =head1 NAME 87 | 88 | Test2::Event::Ok - Ok event type 89 | 90 | =head1 DESCRIPTION 91 | 92 | Ok events are generated whenever you run a test that produces a result. 93 | Examples are C, and C. 94 | 95 | =head1 SYNOPSIS 96 | 97 | use Test2::API qw/context/; 98 | use Test2::Event::Ok; 99 | 100 | my $ctx = context(); 101 | my $event = $ctx->ok($bool, $name, \@diag); 102 | 103 | or: 104 | 105 | my $ctx = context(); 106 | my $event = $ctx->send_event( 107 | 'Ok', 108 | pass => $bool, 109 | name => $name, 110 | ); 111 | 112 | =head1 ACCESSORS 113 | 114 | =over 4 115 | 116 | =item $rb = $e->pass 117 | 118 | The original true/false value of whatever was passed into the event (but 119 | reduced down to 1 or 0). 120 | 121 | =item $name = $e->name 122 | 123 | Name of the test. 124 | 125 | =item $b = $e->effective_pass 126 | 127 | This is the true/false value of the test after TODO and similar modifiers are 128 | taken into account. 129 | 130 | =back 131 | 132 | =head1 SOURCE 133 | 134 | The source code repository for Test2 can be found at 135 | F. 136 | 137 | =head1 MAINTAINERS 138 | 139 | =over 4 140 | 141 | =item Chad Granum Eexodist@cpan.orgE 142 | 143 | =back 144 | 145 | =head1 AUTHORS 146 | 147 | =over 4 148 | 149 | =item Chad Granum Eexodist@cpan.orgE 150 | 151 | =back 152 | 153 | =head1 COPYRIGHT 154 | 155 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 156 | 157 | This program is free software; you can redistribute it and/or 158 | modify it under the same terms as Perl itself. 159 | 160 | See F 161 | 162 | =cut 163 | -------------------------------------------------------------------------------- /t/lib/Test2/EventFacet/Info.pm: -------------------------------------------------------------------------------- 1 | package Test2::EventFacet::Info; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | sub is_list { 1 } 8 | 9 | BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) } 10 | use Test2::Util::HashBase qw{-tag -debug -important -table}; 11 | 12 | 1; 13 | 14 | __END__ 15 | 16 | =pod 17 | 18 | =encoding UTF-8 19 | 20 | =head1 NAME 21 | 22 | Test2::EventFacet::Info - Facet for information a developer might care about. 23 | 24 | =head1 DESCRIPTION 25 | 26 | This facet represents messages intended for humans that will help them either 27 | understand a result, or diagnose a failure. 28 | 29 | =head1 NOTES 30 | 31 | This facet appears in a list instead of being a single item. 32 | 33 | =head1 FIELDS 34 | 35 | =over 4 36 | 37 | =item $string_or_structure = $info->{details} 38 | 39 | =item $string_or_structure = $info->details() 40 | 41 | Human readable string or data structure, this is the information to display. 42 | Formatters are free to render the structures however they please. This may 43 | contain a blessed object. 44 | 45 | If the C
attribute (see below) is set then a renderer may choose to 46 | display the table instead of the details. 47 | 48 | =item $structure = $info->{table} 49 | 50 | =item $structure = $info->table() 51 | 52 | If the data the C facet needs to convey can be represented as a table 53 | then the data may be placed in this attribute in a more raw form for better 54 | display. The data must also be represented in the C
attribute for 55 | renderers which do not support rendering tables directly. 56 | 57 | The table structure: 58 | 59 | my %table = { 60 | header => [ 'column 1 header', 'column 2 header', ... ], # Optional 61 | 62 | rows => [ 63 | ['row 1 column 1', 'row 1, column 2', ... ], 64 | ['row 2 column 1', 'row 2, column 2', ... ], 65 | ... 66 | ], 67 | 68 | # Allow the renderer to hide empty columns when true, Optional 69 | collapse => $BOOL, 70 | 71 | # List by name or number columns that should never be collapsed 72 | no_collapse => \@LIST, 73 | } 74 | 75 | =item $short_string = $info->{tag} 76 | 77 | =item $short_string = $info->tag() 78 | 79 | Short tag to categorize the info. This is usually 10 characters or less, 80 | formatters may truncate longer tags. 81 | 82 | =item $bool = $info->{debug} 83 | 84 | =item $bool = $info->debug() 85 | 86 | Set this to true if the message is critical, or explains a failure. This is 87 | info that should be displayed by formatters even in less-verbose modes. 88 | 89 | When false the information is not considered critical and may not be rendered 90 | in less-verbose modes. 91 | 92 | =item $bool = $info->{important} 93 | 94 | =item $bool = $info->important 95 | 96 | This should be set for non debug messages that are still important enough to 97 | show when a formatter is in quiet mode. A formatter should send these to STDOUT 98 | not STDERR, but should show them even in non-verbose mode. 99 | 100 | =back 101 | 102 | =head1 SOURCE 103 | 104 | The source code repository for Test2 can be found at 105 | F. 106 | 107 | =head1 MAINTAINERS 108 | 109 | =over 4 110 | 111 | =item Chad Granum Eexodist@cpan.orgE 112 | 113 | =back 114 | 115 | =head1 AUTHORS 116 | 117 | =over 4 118 | 119 | =item Chad Granum Eexodist@cpan.orgE 120 | 121 | =back 122 | 123 | =head1 COPYRIGHT 124 | 125 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 126 | 127 | This program is free software; you can redistribute it and/or 128 | modify it under the same terms as Perl itself. 129 | 130 | See F 131 | 132 | =cut 133 | -------------------------------------------------------------------------------- /t/use_web.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 4 | use ddclient::t::HTTPD; 5 | use ddclient::t::ip; 6 | 7 | httpd_required(); 8 | 9 | my $builtinweb = 't/use_web.pl builtinweb'; 10 | my $h = 't/use_web.pl hostname'; 11 | 12 | my $headers = [ 13 | @$textplain, 14 | 'this-ipv4-should-be-ignored' => 'skip skip2 192.0.2.255', 15 | 'this-ipv6-should-be-ignored' => 'skip skip2 2001:db8::ff', 16 | ]; 17 | httpd('4')->run(sub { return [200, $headers, ['192.0.2.1 skip 192.0.2.2 skip2 192.0.2.3']]; }); 18 | httpd('6')->run(sub { return [200, $headers, ['2001:db8::1 skip 2001:db8::2 skip2 2001:db8::3']]; }) 19 | if httpd('6'); 20 | my %ep = ( 21 | '4' => httpd('4')->endpoint(), 22 | '6' => httpd('6') ? httpd('6')->endpoint() : undef, 23 | ); 24 | 25 | my @test_cases; 26 | for my $ipv ('4', '6') { 27 | my $ipv4 = $ipv eq '4'; 28 | for my $sfx ('', "v$ipv") { 29 | push( 30 | @test_cases, 31 | { 32 | desc => "use$sfx=web$sfx web$sfx= IPv$ipv", 33 | ipv6 => !$ipv4, 34 | cfg => {"use$sfx" => "web$sfx", "web$sfx" => $ep{$ipv}}, 35 | want => $ipv4 ? '192.0.2.1' : '2001:db8::1', 36 | }, 37 | { 38 | desc => "use$sfx=web$sfx web$sfx= web$sfx-skip=skip IPv$ipv", 39 | ipv6 => !$ipv4, 40 | cfg => {"use$sfx" => "web$sfx", "web$sfx" => $ep{$ipv}, "web$sfx-skip" => 'skip'}, 41 | # Note that "skip" should skip past the first "skip" and not past "skip2". 42 | want => $ipv4 ? '192.0.2.2' : '2001:db8::2', 43 | }, 44 | { 45 | desc => "use$sfx=web$sfx web$sfx= IPv$ipv", 46 | ipv6 => !$ipv4, 47 | cfg => {"use$sfx" => "web$sfx", "web$sfx" => $builtinweb}, 48 | biw => {url => $ep{$ipv}}, 49 | want => $ipv4 ? '192.0.2.1' : '2001:db8::1', 50 | }, 51 | { 52 | desc => "use$sfx=web$sfx web$sfx= IPv$ipv", 53 | ipv6 => !$ipv4, 54 | cfg => {"use$sfx" => "web$sfx", "web$sfx" => $builtinweb}, 55 | biw => {url => $ep{$ipv}, skip => 'skip'}, 56 | # Note that "skip" should skip past the first "skip" and not past "skip2". 57 | want => $ipv4 ? '192.0.2.2' : '2001:db8::2', 58 | }, 59 | { 60 | desc => "use$sfx=web$sfx web$sfx= web$sfx-skip=skip2 IPv$ipv", 61 | ipv6 => !$ipv4, 62 | cfg => {"use$sfx" => "web$sfx", "web$sfx" => $builtinweb, "web$sfx-skip" => 'skip2'}, 63 | biw => {url => $ep{$ipv}, skip => 'skip'}, 64 | want => $ipv4 ? '192.0.2.3' : '2001:db8::3', 65 | }, 66 | ); 67 | } 68 | } 69 | 70 | for my $tc (@test_cases) { 71 | local $ddclient::builtinweb{$builtinweb} = $tc->{biw}; 72 | $ddclient::builtinweb if 0; 73 | local $ddclient::config{$h} = $tc->{cfg}; 74 | $ddclient::config if 0; 75 | SKIP: { 76 | skip("IPv6 not supported on this system", 1) if $tc->{ipv6} && !$ipv6_supported; 77 | skip("HTTP::Daemon too old for IPv6 support", 1) if $tc->{ipv6} && !$httpd_ipv6_supported; 78 | is(ddclient::get_ip(ddclient::strategy_inputs('use', $h)), $tc->{want}, $tc->{desc}) 79 | if $tc->{cfg}{use}; 80 | is(ddclient::get_ipv4(ddclient::strategy_inputs('usev4', $h)), $tc->{want}, $tc->{desc}) 81 | if $tc->{cfg}{usev4}; 82 | is(ddclient::get_ipv6(ddclient::strategy_inputs('usev6', $h)), $tc->{want}, $tc->{desc}) 83 | if $tc->{cfg}{usev6}; 84 | } 85 | } 86 | 87 | done_testing(); 88 | -------------------------------------------------------------------------------- /t/parse_assignments.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use Data::Dumper; 3 | 4 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 5 | eval { require 'ddclient'; } or BAIL_OUT($@); 6 | 7 | $Data::Dumper::Sortkeys = 1; 8 | 9 | sub tc { 10 | return { 11 | name => shift, 12 | input => shift, 13 | want_vars => shift, 14 | want_rest => shift, 15 | }; 16 | } 17 | 18 | my @test_cases = ( 19 | tc('no assignments', "", {}, ""), 20 | tc('one assignment', "a=1", { a => '1' }, ""), 21 | tc('empty value', "a=", { a => '' }, ""), 22 | tc('sep: comma', "a=1,b=2", { a => '1', b => '2' }, ""), 23 | tc('sep: space', "a=1 b=2", { a => '1', b => '2' }, ""), 24 | tc('sep: comma space', "a=1, b=2", { a => '1', b => '2' }, ""), 25 | tc('sep: space comma', "a=1 ,b=2", { a => '1', b => '2' }, ""), 26 | tc('sep: space comma space', "a=1 , b=2", { a => '1', b => '2' }, ""), 27 | tc('leading space', " a=1", { a => '1' }, ""), 28 | tc('trailing space', "a=1 ", { a => '1' }, ""), 29 | tc('leading comma', ",a=1", { a => '1' }, ""), 30 | tc('trailing comma', "a=1,", { a => '1' }, ""), 31 | tc('empty assignment', "a=1,,b=2", { a => '1', b => '2' }, ""), 32 | tc('rest', "a", {}, "a"), 33 | tc('rest leading space', " x", {}, "x"), 34 | tc('rest trailing space', "x ", {}, "x "), 35 | tc('rest leading comma', ",x", {}, "x"), 36 | tc('rest trailing comma', "x,", {}, "x,"), 37 | tc('assign space rest', "a=1 x", { a => '1' }, "x"), 38 | tc('assign comma rest', "a=1,x", { a => '1' }, "x"), 39 | tc('assign comma space rest', "a=1, x", { a => '1' }, "x"), 40 | tc('assign space comma rest', "a=1 ,x", { a => '1' }, "x"), 41 | tc('single quoting', "a='\", '", { a => '", ' }, ""), 42 | tc('double quoting', "a=\"', \"", { a => "', " }, ""), 43 | tc('mixed quoting', "a=1\"2\"'3'4", { a => "1234" }, ""), 44 | tc('unquoted escaped backslash', "a=\\\\", { a => "\\" }, ""), 45 | tc('squoted escaped squote', "a='\\''", { a => "'" }, ""), 46 | tc('dquoted escaped dquote', "a=\"\\\"\"", { a => '"' }, ""), 47 | tc('env: empty', "a_env=", {}, ""), 48 | tc('env: unset', "a_env=UNSET", {}, ""), 49 | tc('env: set', "a_env=TEST", { a => 'val' }, ""), 50 | tc('env: single quoted', "a_env='TEST'", { a => 'val' }, ""), 51 | tc('newline: quoted value', "a='1\n2'", { a => "1\n2" }, ""), 52 | tc('newline: escaped value', "a=1\\\n2", { a => "1\n2" }, ""), 53 | tc('newline: between vars', "a=1 \n b=2", { a => '1' }, "\n b=2"), 54 | tc('newline: terminating', "a=1 \n", { a => '1' }, "\n"), 55 | ); 56 | 57 | delete($ENV{''}); 58 | delete($ENV{UNSET}); 59 | $ENV{TEST} = 'val'; 60 | 61 | for my $tc (@test_cases) { 62 | my ($got_rest, %got_vars) = ddclient::parse_assignments($tc->{input}); 63 | subtest $tc->{name} => sub { 64 | is(Dumper(\%got_vars), Dumper($tc->{want_vars}), "vars"); 65 | is($got_rest, $tc->{want_rest}, "rest"); 66 | } 67 | } 68 | 69 | done_testing(); 70 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: 3 | push: 4 | pull_request: 5 | 6 | jobs: 7 | test-debian-like: 8 | strategy: 9 | fail-fast: false 10 | matrix: 11 | image: 12 | - ubuntu:latest 13 | - ubuntu:20.04 14 | - debian:testing 15 | - debian:stable 16 | - debian:oldstable 17 | runs-on: ubuntu-latest 18 | container: 19 | image: ${{ matrix.image }} 20 | steps: 21 | - name: install dependencies 22 | run: | 23 | apt-get update && 24 | DEBIAN_FRONTEND=noninteractive apt-get install -y --no-install-recommends \ 25 | automake \ 26 | ca-certificates \ 27 | git \ 28 | curl \ 29 | libhttp-daemon-perl \ 30 | libhttp-daemon-ssl-perl \ 31 | libplack-perl \ 32 | libtest-mockmodule-perl \ 33 | libtest-tcp-perl \ 34 | libtest-warnings-perl \ 35 | liburi-perl \ 36 | libwww-perl \ 37 | net-tools \ 38 | make \ 39 | ; 40 | - uses: actions/checkout@v4 41 | - name: autogen 42 | run: ./autogen 43 | - name: configure 44 | run: ./configure 45 | - name: check 46 | run: make VERBOSE=1 AM_COLOR_TESTS=always check 47 | - name: distcheck 48 | run: make VERBOSE=1 AM_COLOR_TESTS=always distcheck 49 | - name: distribution tarball is complete 50 | run: ./.github/workflows/scripts/dist-tarball-check 51 | - if: ${{ matrix.image == 'debian:testing' }} 52 | uses: actions/upload-artifact@v4 53 | with: 54 | name: distribution-tarball 55 | path: ddclient-*.tar.gz 56 | 57 | test-fedora-like: 58 | strategy: 59 | fail-fast: false 60 | matrix: 61 | image: 62 | - fedora:39 63 | - fedora:latest 64 | - fedora:rawhide 65 | - almalinux:8 66 | - almalinux:latest 67 | runs-on: ubuntu-latest 68 | container: 69 | image: ${{ matrix.image }} 70 | steps: 71 | - uses: actions/checkout@v4 72 | - name: enable repositories (AlmaLinux 8) 73 | if: ${{ matrix.image == 'almalinux:8' }} 74 | run: | 75 | dnf --refresh install -y 'dnf-command(config-manager)' epel-release && 76 | dnf config-manager --set-enabled powertools 77 | - name: enable repositories (AlmaLinux latest) 78 | if: ${{ matrix.image == 'almalinux:latest' }} 79 | run: | 80 | dnf --refresh install -y 'dnf-command(config-manager)' epel-release && 81 | dnf config-manager --set-enabled crb 82 | - name: install dependencies 83 | # The --skip-broken argument works around missing packages. (They're 84 | # only used for testing, so it's OK to not install them.) 85 | run: | 86 | dnf --refresh install --skip-broken -y \ 87 | automake \ 88 | findutils \ 89 | iproute \ 90 | make \ 91 | curl \ 92 | perl \ 93 | perl-HTTP-Daemon \ 94 | perl-HTTP-Daemon-SSL \ 95 | perl-IO-Socket-INET6 \ 96 | perl-Plack \ 97 | perl-Test-MockModule \ 98 | perl-Test-TCP \ 99 | perl-Test-Warnings \ 100 | perl-core \ 101 | perl-libwww-perl \ 102 | net-tools \ 103 | ; 104 | - name: autogen 105 | run: ./autogen 106 | - name: configure 107 | run: ./configure 108 | - name: check 109 | run: make VERBOSE=1 AM_COLOR_TESTS=always check 110 | - name: distcheck 111 | run: make VERBOSE=1 AM_COLOR_TESTS=always distcheck 112 | -------------------------------------------------------------------------------- /t/variable_defaults.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 4 | use re qw(is_regexp); 5 | 6 | my %variable_collections = ( 7 | map({ ($_ => $ddclient::cfgvars{$_}) } grep($_ ne 'merged', keys(%ddclient::cfgvars))), 8 | map({ ("protocol=$_" => $ddclient::protocols{$_}{cfgvars}); } keys(%ddclient::protocols)), 9 | ); 10 | my %seen; 11 | my @test_cases = ( 12 | map({ 13 | my $vcn = $_; 14 | my $vc = $variable_collections{$_}; 15 | map({ 16 | my $def = $vc->{$_}; 17 | my $seen = exists($seen{$def}); 18 | $seen{$def} = undef; 19 | ({desc => "$vcn $_", def => $vc->{$_}}) x !$seen; 20 | } sort(keys(%$vc))); 21 | } sort(keys(%variable_collections))), 22 | ); 23 | for my $tc (@test_cases) { 24 | if ($tc->{def}{required}) { 25 | is($tc->{def}{default}, undef, "'$tc->{desc}' (required) has no default"); 26 | } else { 27 | # Preserve all existing variables in $cfgvars{merged} so that variables with dynamic 28 | # defaults can reference them. 29 | local %ddclient::cfgvars = (merged => { 30 | %{$ddclient::cfgvars{merged}}, 31 | 'var for test' => $tc->{def}, 32 | }); 33 | # Variables with dynamic defaults will need their own unit tests, but we can still check the 34 | # clean-slate hostless default. 35 | local %ddclient::config; 36 | local %ddclient::opt; 37 | local %ddclient::globals; 38 | my $norm; 39 | my $default = ddclient::default('var for test'); 40 | diag("'$tc->{desc}' default: " . ($default // '')); 41 | is($default, $tc->{def}{default}, "'$tc->{desc}' default() return value matches default") 42 | if ref($tc->{def}{default}) ne 'CODE'; 43 | my $valid = eval { $norm = ddclient::check_value($default, $tc->{def}); 1; } or diag($@); 44 | ok($valid, "'$tc->{desc}' (optional) has a valid default"); 45 | is($norm, $default, "'$tc->{desc}' default normalizes to itself") if $valid; 46 | } 47 | } 48 | 49 | my @use_test_cases = ( 50 | { 51 | desc => 'clean slate hostless default', 52 | want => 'ip', 53 | }, 54 | { 55 | desc => 'usage string', 56 | host => '', 57 | want => qr/disabled.*ip|ip.*disabled/, 58 | }, 59 | { 60 | desc => 'usev4 disables use by default', 61 | host => 'host', 62 | cfg => {usev4 => 'webv4'}, 63 | want => 'disabled', 64 | }, 65 | { 66 | desc => 'usev6 disables use by default', 67 | host => 'host', 68 | cfg => {usev4 => 'webv4'}, 69 | want => 'disabled', 70 | }, 71 | { 72 | desc => 'explicitly setting use re-enables it', 73 | host => 'host', 74 | cfg => {use => 'web', usev4 => 'webv4'}, 75 | want => 'web', 76 | }, 77 | ); 78 | for my $tc (@use_test_cases) { 79 | my $desc = "'use' dynamic default: $tc->{desc}"; 80 | local %ddclient::protocols = (protocol => ddclient::Protocol->new()); 81 | local %ddclient::cfgvars = (merged => { 82 | 'protocol' => $ddclient::cfgvars{'merged'}{'protocol'}, 83 | 'use' => $ddclient::cfgvars{'protocol-common-defaults'}{'use'}, 84 | 'usev4' => $ddclient::cfgvars{'merged'}{'usev4'}, 85 | 'usev6' => $ddclient::cfgvars{'merged'}{'usev6'}, 86 | }); 87 | local %ddclient::config = (host => {protocol => 'protocol', %{$tc->{cfg} // {}}}); 88 | local %ddclient::opt; 89 | local %ddclient::globals; 90 | 91 | my $got = ddclient::opt('use', $tc->{host}); 92 | 93 | if (is_regexp($tc->{want})) { 94 | like($got, $tc->{want}, $desc); 95 | } else { 96 | is($got, $tc->{want}, $desc); 97 | } 98 | } 99 | 100 | done_testing(); 101 | -------------------------------------------------------------------------------- /t/group_hosts_by.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 3 | eval { require 'ddclient'; } or BAIL_OUT($@); 4 | eval { require Data::Dumper; } or skip($@, 1); 5 | Data::Dumper->import(); 6 | 7 | my $h1 = 'h1'; 8 | my $h2 = 'h2'; 9 | my $h3 = 'h3'; 10 | 11 | $ddclient::config{$h1} = { 12 | common => 'common', 13 | h1h2 => 'h1 and h2', 14 | unique => 'h1', 15 | falsy => 0, 16 | maybeunset => 'unique', 17 | }; 18 | $ddclient::config{$h2} = { 19 | common => 'common', 20 | h1h2 => 'h1 and h2', 21 | unique => 'h2', 22 | falsy => '', 23 | maybeunset => undef, # should not be grouped with unset 24 | }; 25 | $ddclient::config{$h3} = { 26 | common => 'common', 27 | h1h2 => 'unique', 28 | unique => 'h3', 29 | falsy => undef, 30 | # maybeunset is intentionally not set 31 | }; 32 | 33 | my @test_cases = ( 34 | { 35 | desc => 'empty attribute set yields single group with all hosts', 36 | groupby => [qw()], 37 | want => [{cfg => {}, hosts => [$h1, $h2, $h3]}], 38 | }, 39 | { 40 | desc => 'common attribute yields single group with all hosts', 41 | groupby => [qw(common)], 42 | want => [{cfg => {common => 'common'}, hosts => [$h1, $h2, $h3]}], 43 | }, 44 | { 45 | desc => 'subset share a value', 46 | groupby => [qw(h1h2)], 47 | want => [ 48 | {cfg => {h1h2 => 'h1 and h2'}, hosts => [$h1, $h2]}, 49 | {cfg => {h1h2 => 'unique'}, hosts => [$h3]}, 50 | ], 51 | }, 52 | { 53 | desc => 'all unique', 54 | groupby => [qw(unique)], 55 | want => [ 56 | {cfg => {unique => 'h1'}, hosts => [$h1]}, 57 | {cfg => {unique => 'h2'}, hosts => [$h2]}, 58 | {cfg => {unique => 'h3'}, hosts => [$h3]}, 59 | ], 60 | }, 61 | { 62 | desc => 'combination', 63 | groupby => [qw(common h1h2)], 64 | want => [ 65 | {cfg => {common => 'common', h1h2 => 'h1 and h2'}, hosts => [$h1, $h2]}, 66 | {cfg => {common => 'common', h1h2 => 'unique'}, hosts => [$h3]}, 67 | ], 68 | }, 69 | { 70 | desc => 'falsy values', 71 | groupby => [qw(falsy)], 72 | want => [ 73 | {cfg => {falsy => 0}, hosts => [$h1]}, 74 | {cfg => {falsy => ''}, hosts => [$h2]}, 75 | # undef intentionally becomes unset because undef always means "fall back to global or 76 | # default". 77 | {cfg => {}, hosts => [$h3]}, 78 | ], 79 | }, 80 | { 81 | desc => 'set, unset, undef', 82 | groupby => [qw(maybeunset)], 83 | want => [ 84 | {cfg => {maybeunset => 'unique'}, hosts => [$h1]}, 85 | # undef intentionally becomes unset because undef always means "fall back to global or 86 | # default". 87 | {cfg => {}, hosts => [$h2, $h3]}, 88 | ], 89 | }, 90 | { 91 | desc => 'missing attribute', 92 | groupby => [qw(thisdoesnotexist)], 93 | want => [{cfg => {}, hosts => [$h1, $h2, $h3]}], 94 | }, 95 | ); 96 | 97 | for my $tc (@test_cases) { 98 | my @got = ddclient::group_hosts_by([$h1, $h2, $h3], @{$tc->{groupby}}); 99 | # @got is used as a set of sets. Sort everything to make comparison easier. 100 | $_->{hosts} = [sort(@{$_->{hosts}})] for @got; 101 | @got = sort({ 102 | for (my $i = 0; $i < @{$a->{hosts}} && $i < @{$b->{hosts}}; ++$i) { 103 | my $x = $a->{hosts}[$i] cmp $b->{hosts}[$i]; 104 | return $x if $x != 0; 105 | } 106 | return @{$a->{hosts}} <=> @{$b->{hosts}}; 107 | } @got); 108 | is_deeply(\@got, $tc->{want}, $tc->{desc}) 109 | or diag(Data::Dumper->new([\@got, $tc->{want}], 110 | [qw(got want)])->Sortkeys(1)->Useqq(1)->Dump()); 111 | } 112 | 113 | done_testing(); 114 | -------------------------------------------------------------------------------- /t/lib/Test2/IPC.pm: -------------------------------------------------------------------------------- 1 | package Test2::IPC; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | use Test2::API::Instance; 9 | use Test2::Util qw/get_tid/; 10 | use Test2::API qw{ 11 | test2_in_preload 12 | test2_init_done 13 | test2_ipc 14 | test2_has_ipc 15 | test2_ipc_enable_polling 16 | test2_pid 17 | test2_stack 18 | test2_tid 19 | context 20 | }; 21 | 22 | # Make sure stuff is finalized before anyone tried to fork or start a new thread. 23 | { 24 | # Avoid warnings if things are loaded at run-time 25 | no warnings 'void'; 26 | INIT { 27 | use warnings 'void'; 28 | context()->release() unless test2_in_preload(); 29 | } 30 | } 31 | 32 | use Carp qw/confess/; 33 | 34 | our @EXPORT_OK = qw/cull/; 35 | BEGIN { require Exporter; our @ISA = qw(Exporter) } 36 | 37 | sub unimport { Test2::API::test2_ipc_disable() } 38 | 39 | sub import { 40 | goto &Exporter::import if test2_has_ipc || !test2_init_done(); 41 | 42 | confess "IPC is disabled" if Test2::API::test2_ipc_disabled(); 43 | confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$; 44 | confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid(); 45 | 46 | Test2::API::_set_ipc(_make_ipc()); 47 | apply_ipc(test2_stack()); 48 | 49 | goto &Exporter::import; 50 | } 51 | 52 | sub _make_ipc { 53 | # Find a driver 54 | my ($driver) = Test2::API::test2_ipc_drivers(); 55 | unless ($driver) { 56 | require Test2::IPC::Driver::Files; 57 | $driver = 'Test2::IPC::Driver::Files'; 58 | } 59 | 60 | return $driver->new(); 61 | } 62 | 63 | sub apply_ipc { 64 | my $stack = shift; 65 | 66 | my ($root) = @$stack; 67 | 68 | return unless $root; 69 | 70 | confess "Cannot add IPC in a child process" if $root->pid != $$; 71 | confess "Cannot add IPC in a child thread" if $root->tid != get_tid(); 72 | 73 | my $ipc = $root->ipc || test2_ipc() || _make_ipc(); 74 | 75 | # Add the IPC to all hubs 76 | for my $hub (@$stack) { 77 | my $has = $hub->ipc; 78 | confess "IPC Mismatch!" if $has && $has != $ipc; 79 | next if $has; 80 | $hub->set_ipc($ipc); 81 | $ipc->add_hub($hub->hid); 82 | } 83 | 84 | test2_ipc_enable_polling(); 85 | 86 | return $ipc; 87 | } 88 | 89 | sub cull { 90 | my $ctx = context(); 91 | $ctx->hub->cull; 92 | $ctx->release; 93 | } 94 | 95 | 1; 96 | 97 | __END__ 98 | 99 | =pod 100 | 101 | =encoding UTF-8 102 | 103 | =head1 NAME 104 | 105 | Test2::IPC - Turn on IPC for threading or forking support. 106 | 107 | =head1 SYNOPSIS 108 | 109 | You should C as early as possible in your test file. If you 110 | import this module after API initialization it will attempt to retrofit IPC 111 | onto the existing hubs. 112 | 113 | =head2 DISABLING IT 114 | 115 | You can use C to disable IPC for good. You can also use the 116 | T2_NO_IPC env var. 117 | 118 | =head1 EXPORTS 119 | 120 | All exports are optional. 121 | 122 | =over 4 123 | 124 | =item cull() 125 | 126 | Cull allows you to collect results from other processes or threads on demand. 127 | 128 | =back 129 | 130 | =head1 SOURCE 131 | 132 | The source code repository for Test2 can be found at 133 | F. 134 | 135 | =head1 MAINTAINERS 136 | 137 | =over 4 138 | 139 | =item Chad Granum Eexodist@cpan.orgE 140 | 141 | =back 142 | 143 | =head1 AUTHORS 144 | 145 | =over 4 146 | 147 | =item Chad Granum Eexodist@cpan.orgE 148 | 149 | =back 150 | 151 | =head1 COPYRIGHT 152 | 153 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 154 | 155 | This program is free software; you can redistribute it and/or 156 | modify it under the same terms as Perl itself. 157 | 158 | See F 159 | 160 | =cut 161 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Subtest.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Subtest; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) } 8 | use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid}; 9 | 10 | sub init { 11 | my $self = shift; 12 | $self->SUPER::init(); 13 | $self->{+SUBEVENTS} ||= []; 14 | if ($self->{+EFFECTIVE_PASS}) { 15 | $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; 16 | } 17 | } 18 | 19 | { 20 | no warnings 'redefine'; 21 | 22 | sub set_subevents { 23 | my $self = shift; 24 | my @subevents = @_; 25 | 26 | if ($self->{+EFFECTIVE_PASS}) { 27 | $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents; 28 | } 29 | 30 | $self->{+SUBEVENTS} = \@subevents; 31 | } 32 | 33 | sub set_effective_pass { 34 | my $self = shift; 35 | my ($pass) = @_; 36 | 37 | if ($pass) { 38 | $_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}; 39 | } 40 | elsif ($self->{+EFFECTIVE_PASS} && !$pass) { 41 | for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) { 42 | $_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo; 43 | } 44 | } 45 | 46 | $self->{+EFFECTIVE_PASS} = $pass; 47 | } 48 | } 49 | 50 | sub summary { 51 | my $self = shift; 52 | 53 | my $name = $self->{+NAME} || "Nameless Subtest"; 54 | 55 | my $todo = $self->{+TODO}; 56 | if ($todo) { 57 | $name .= " (TODO: $todo)"; 58 | } 59 | elsif (defined $todo) { 60 | $name .= " (TODO)"; 61 | } 62 | 63 | return $name; 64 | } 65 | 66 | sub facet_data { 67 | my $self = shift; 68 | 69 | my $out = $self->SUPER::facet_data(); 70 | 71 | $out->{parent} = { 72 | hid => $self->subtest_id, 73 | children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}], 74 | buffered => $self->{+BUFFERED}, 75 | }; 76 | 77 | return $out; 78 | } 79 | 80 | sub add_amnesty { 81 | my $self = shift; 82 | 83 | for my $am (@_) { 84 | $am = {%$am} if ref($am) ne 'ARRAY'; 85 | $am = Test2::EventFacet::Amnesty->new($am); 86 | 87 | push @{$self->{+AMNESTY}} => $am; 88 | 89 | for my $e (@{$self->{+SUBEVENTS}}) { 90 | $e->add_amnesty($am->clone(inherited => 1)); 91 | } 92 | } 93 | } 94 | 95 | 96 | 1; 97 | 98 | __END__ 99 | 100 | =pod 101 | 102 | =encoding UTF-8 103 | 104 | =head1 NAME 105 | 106 | Test2::Event::Subtest - Event for subtest types 107 | 108 | =head1 DESCRIPTION 109 | 110 | This class represents a subtest. This class is a subclass of 111 | L. 112 | 113 | =head1 ACCESSORS 114 | 115 | This class inherits from L. 116 | 117 | =over 4 118 | 119 | =item $arrayref = $e->subevents 120 | 121 | Returns the arrayref containing all the events from the subtest 122 | 123 | =item $bool = $e->buffered 124 | 125 | True if the subtest is buffered, that is all subevents render at once. If this 126 | is false it means all subevents render as they are produced. 127 | 128 | =back 129 | 130 | =head1 SOURCE 131 | 132 | The source code repository for Test2 can be found at 133 | F. 134 | 135 | =head1 MAINTAINERS 136 | 137 | =over 4 138 | 139 | =item Chad Granum Eexodist@cpan.orgE 140 | 141 | =back 142 | 143 | =head1 AUTHORS 144 | 145 | =over 4 146 | 147 | =item Chad Granum Eexodist@cpan.orgE 148 | 149 | =back 150 | 151 | =head1 COPYRIGHT 152 | 153 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 154 | 155 | This program is free software; you can redistribute it and/or 156 | modify it under the same terms as Perl itself. 157 | 158 | See F 159 | 160 | =cut 161 | -------------------------------------------------------------------------------- /t/read_recap.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | use File::Temp; 4 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 5 | 6 | local $ddclient::globals{debug} = 1; 7 | local $ddclient::globals{verbose} = 1; 8 | local %ddclient::protocols = ( 9 | protocol_a => ddclient::Protocol->new( 10 | recapvars => { 11 | host => ddclient::T_STRING(), 12 | var_a => ddclient::T_BOOL(), 13 | }, 14 | ), 15 | protocol_b => ddclient::Protocol->new( 16 | recapvars => { 17 | host => ddclient::T_STRING(), 18 | var_b => ddclient::T_NUMBER(), 19 | }, 20 | cfgvars => { 21 | var_b_non_recap => {type => ddclient::T_ANY()}, 22 | }, 23 | ), 24 | ); 25 | local %ddclient::cfgvars = (merged => {map({ %{$ddclient::protocols{$_}{cfgvars} // {}}; } 26 | sort(keys(%ddclient::protocols)))}); 27 | 28 | my @test_cases = ( 29 | { 30 | desc => "ok value", 31 | cachefile_lines => ["var_a=yes host_a"], 32 | want => {host_a => {host => 'host_a', var_a => 1}}, 33 | }, 34 | { 35 | desc => "unknown host", 36 | cachefile_lines => ["var_a=yes host_c"], 37 | want => {}, 38 | }, 39 | { 40 | desc => "unknown var", 41 | cachefile_lines => ["var_b=123 host_a"], 42 | want => {host_a => {host => 'host_a'}}, 43 | }, 44 | { 45 | desc => "invalid value", 46 | cachefile_lines => ["var_a=wat host_a"], 47 | want => {host_a => {host => 'host_a'}}, 48 | }, 49 | { 50 | desc => "multiple entries", 51 | cachefile_lines => [ 52 | "var_a=yes host_a", 53 | "var_b=123 host_b", 54 | ], 55 | want => { 56 | host_a => {host => 'host_a', var_a => 1}, 57 | host_b => {host => 'host_b', var_b => 123}, 58 | }, 59 | }, 60 | { 61 | desc => "non-recap vars are not loaded to %recap", 62 | cachefile_lines => ["var_b_non_recap=foo host_b"], 63 | want => {host_b => {host => 'host_b'}}, 64 | }, 65 | { 66 | desc => "non-recap vars are scrubbed from %recap", 67 | cachefile_lines => ["var_b_non_recap=foo host_b"], 68 | recap => {host_b => {host => 'host_b', var_b_non_recap => 'foo'}}, 69 | want => {host_b => {host => 'host_b'}}, 70 | }, 71 | { 72 | desc => "unknown hosts are scrubbed from %recap", 73 | cachefile_lines => ["host_a", "host_c"], 74 | recap => {host_a => {host => 'host_a'}, host_c => {host => 'host_c'}}, 75 | want => {host_a => {host => 'host_a'}}, 76 | }, 77 | ); 78 | 79 | for my $tc (@test_cases) { 80 | my $cachef = File::Temp->new(); 81 | print($cachef join('', map("$_\n", "## $ddclient::program-$ddclient::version", 82 | @{$tc->{cachefile_lines}}))); 83 | $cachef->close(); 84 | local $ddclient::globals{cache} = "$cachef"; 85 | local %ddclient::recap = %{$tc->{recap} // {}}; 86 | my %want_config = ( 87 | host_a => {protocol => 'protocol_a'}, 88 | host_b => {protocol => 'protocol_b'}, 89 | ); 90 | # Deep clone %want_config so we can check for changes. 91 | local %ddclient::config; 92 | $ddclient::config{$_} = {%{$want_config{$_}}} for keys(%want_config); 93 | 94 | ddclient::read_recap($cachef->filename()); 95 | 96 | TODO: { 97 | local $TODO = $tc->{want_TODO}; 98 | is_deeply(\%ddclient::recap, $tc->{want}, "$tc->{desc}: %recap") 99 | or diag(ddclient::repr(Values => [\%ddclient::recap, $tc->{want}], 100 | Names => ['*got', '*want'])); 101 | } 102 | is_deeply(\%ddclient::config, \%want_config, "$tc->{desc}: %config") 103 | or diag(ddclient::repr(Values => [\%ddclient::config, \%want_config], 104 | Names => ['*got', '*want'])); 105 | } 106 | 107 | done_testing(); 108 | -------------------------------------------------------------------------------- /t/ssl-validate.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 4 | use ddclient::t::HTTPD; 5 | use ddclient::t::ip; 6 | 7 | local $ddclient::globals{debug} = 1; 8 | local $ddclient::globals{verbose} = 1; 9 | 10 | httpd_required(); 11 | httpd_ssl_required(); 12 | 13 | httpd('4', 1)->run(sub { return [200, $textplain, ['127.0.0.1']]; }); 14 | httpd('6', 1)->run(sub { return [200, $textplain, ['::1']]; }) if httpd('6', 1); 15 | my $h = 't/ssl-validate.pl'; 16 | my %ep = ( 17 | '4' => httpd('4', 1)->endpoint(), 18 | '6' => httpd('6', 1) ? httpd('6', 1)->endpoint() : undef, 19 | ); 20 | 21 | my @test_cases = ( 22 | { 23 | desc => 'usev4=webv4 web-ssl-validate=no', 24 | cfg => {'usev4' => 'webv4', 'web-ssl-validate' => 0, 'webv4' => $ep{'4'}}, 25 | want => '127.0.0.1', 26 | }, 27 | { 28 | desc => 'usev4=webv4 web-ssl-validate=yes', 29 | cfg => {'usev4' => 'webv4', 'web-ssl-validate' => 1, 'webv4' => $ep{'4'}}, 30 | want => undef, 31 | }, 32 | { 33 | desc => 'usev6=webv6 web-ssl-validate=no', 34 | cfg => {'usev6' => 'webv6', 'web-ssl-validate' => 0, 'webv6' => $ep{'6'}}, 35 | ipv6 => 1, 36 | want => '::1', 37 | }, 38 | { 39 | desc => 'usev6=webv6 web-ssl-validate=yes', 40 | cfg => {'usev6' => 'webv6', 'web-ssl-validate' => 1, 'webv6' => $ep{'6'}}, 41 | ipv6 => 1, 42 | want => undef, 43 | }, 44 | { 45 | desc => 'usev4=cisco-asa fw-ssl-validate=no', 46 | cfg => {'usev4' => 'cisco-asa', 'fw-ssl-validate' => 0, 47 | # cisco-asa adds https:// to the URL. :-/ 48 | 'fwv4' => substr($ep{'4'}, length('https://'))}, 49 | want => '127.0.0.1', 50 | }, 51 | { 52 | desc => 'usev4=cisco-asa fw-ssl-validate=yes', 53 | cfg => {'usev4' => 'cisco-asa', 'fw-ssl-validate' => 1, 54 | # cisco-asa adds https:// to the URL. :-/ 55 | 'fwv4' => substr($ep{'4'}, length('https://'))}, 56 | want => undef, 57 | }, 58 | { 59 | desc => 'usev4=fwv4 fw-ssl-validate=no', 60 | cfg => {'usev4' => 'fwv4', 'fw-ssl-validate' => 0, 'fwv4' => $ep{'4'}}, 61 | want => '127.0.0.1', 62 | }, 63 | { 64 | desc => 'usev4=fwv4 fw-ssl-validate=yes', 65 | cfg => {'usev4' => 'fwv4', 'fw-ssl-validate' => 1, 'fwv4' => $ep{'4'}}, 66 | want => undef, 67 | }, 68 | ); 69 | 70 | for my $tc (@test_cases) { 71 | local $ddclient::_l = ddclient::pushlogctx($tc->{desc}); 72 | SKIP: { 73 | skip("IPv6 not supported on this system", 1) if $tc->{ipv6} && !$ipv6_supported; 74 | skip("HTTP::Daemon too old for IPv6 support", 1) if $tc->{ipv6} && !$httpd_ipv6_supported; 75 | # $ddclient::globals{'ssl_ca_file'} is intentionally NOT set to $ca_file so that we can 76 | # test what happens when certificate validation fails. However, if curl can't find any CA 77 | # certificates (which may be the case in some minimal test environments, such as Docker 78 | # images and Debian package builder chroots), it will immediately close the connection 79 | # after it sends the TLS client hello and before it receives the server hello (in Debian 80 | # sid as of 2025-01-08, anyway). This confuses IO::Socket::SSL (used by 81 | # Test::Fake::HTTPD), causing it to hang in the middle of the TLS handshake waiting for 82 | # input that will never arrive. To work around this, the CA certificate file is explicitly 83 | # set to an unrelated certificate so that curl has something to read. 84 | local $ddclient::globals{'ssl_ca_file'} = $other_ca_file; 85 | local $ddclient::config{$h} = $tc->{cfg}; 86 | %ddclient::config if 0; # suppress spurious warning "Name used only once: possible typo" 87 | is(ddclient::get_ipv4(ddclient::strategy_inputs('usev4', $h)), $tc->{want}, $tc->{desc}) 88 | if ($tc->{cfg}{usev4}); 89 | is(ddclient::get_ipv6(ddclient::strategy_inputs('usev6', $h)), $tc->{want}, $tc->{desc}) 90 | if ($tc->{cfg}{usev6}); 91 | } 92 | } 93 | 94 | done_testing(); 95 | -------------------------------------------------------------------------------- /t/lib/Test2/Event/Plan.pm: -------------------------------------------------------------------------------- 1 | package Test2::Event::Plan; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) } 9 | use Test2::Util::HashBase qw{max directive reason}; 10 | 11 | use Carp qw/confess/; 12 | 13 | my %ALLOWED = ( 14 | 'SKIP' => 1, 15 | 'NO PLAN' => 1, 16 | ); 17 | 18 | sub init { 19 | if ($_[0]->{+DIRECTIVE}) { 20 | $_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all'; 21 | $_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan'; 22 | 23 | confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive" 24 | unless $ALLOWED{$_[0]->{+DIRECTIVE}}; 25 | } 26 | else { 27 | confess "Cannot have a reason without a directive!" 28 | if defined $_[0]->{+REASON}; 29 | 30 | confess "No number of tests specified" 31 | unless defined $_[0]->{+MAX}; 32 | 33 | confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer" 34 | unless $_[0]->{+MAX} =~ m/^\d+$/; 35 | 36 | $_[0]->{+DIRECTIVE} = ''; 37 | } 38 | } 39 | 40 | sub sets_plan { 41 | my $self = shift; 42 | return ( 43 | $self->{+MAX}, 44 | $self->{+DIRECTIVE}, 45 | $self->{+REASON}, 46 | ); 47 | } 48 | 49 | sub terminate { 50 | my $self = shift; 51 | # On skip_all we want to terminate the hub 52 | return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP'; 53 | return undef; 54 | } 55 | 56 | sub summary { 57 | my $self = shift; 58 | my $max = $self->{+MAX}; 59 | my $directive = $self->{+DIRECTIVE}; 60 | my $reason = $self->{+REASON}; 61 | 62 | return "Plan is $max assertions" 63 | if $max || !$directive; 64 | 65 | return "Plan is '$directive', $reason" 66 | if $reason; 67 | 68 | return "Plan is '$directive'"; 69 | } 70 | 71 | sub facet_data { 72 | my $self = shift; 73 | 74 | my $out = $self->common_facet_data; 75 | 76 | $out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef 77 | unless defined $out->{control}->{terminate}; 78 | 79 | $out->{plan} = {count => $self->{+MAX}}; 80 | $out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON}; 81 | 82 | if (my $dir = $self->{+DIRECTIVE}) { 83 | $out->{plan}->{skip} = 1 if $dir eq 'SKIP'; 84 | $out->{plan}->{none} = 1 if $dir eq 'NO PLAN'; 85 | } 86 | 87 | return $out; 88 | } 89 | 90 | 91 | 1; 92 | 93 | __END__ 94 | 95 | =pod 96 | 97 | =encoding UTF-8 98 | 99 | =head1 NAME 100 | 101 | Test2::Event::Plan - The event of a plan 102 | 103 | =head1 DESCRIPTION 104 | 105 | Plan events are fired off whenever a plan is declared, done testing is called, 106 | or a subtext completes. 107 | 108 | =head1 SYNOPSIS 109 | 110 | use Test2::API qw/context/; 111 | use Test2::Event::Plan; 112 | 113 | my $ctx = context(); 114 | 115 | # Plan for 10 tests to run 116 | my $event = $ctx->plan(10); 117 | 118 | # Plan to skip all tests (will exit 0) 119 | $ctx->plan(0, skip_all => "These tests need to be skipped"); 120 | 121 | =head1 ACCESSORS 122 | 123 | =over 4 124 | 125 | =item $num = $plan->max 126 | 127 | Get the number of expected tests 128 | 129 | =item $dir = $plan->directive 130 | 131 | Get the directive (such as TODO, skip_all, or no_plan). 132 | 133 | =item $reason = $plan->reason 134 | 135 | Get the reason for the directive. 136 | 137 | =back 138 | 139 | =head1 SOURCE 140 | 141 | The source code repository for Test2 can be found at 142 | F. 143 | 144 | =head1 MAINTAINERS 145 | 146 | =over 4 147 | 148 | =item Chad Granum Eexodist@cpan.orgE 149 | 150 | =back 151 | 152 | =head1 AUTHORS 153 | 154 | =over 4 155 | 156 | =item Chad Granum Eexodist@cpan.orgE 157 | 158 | =back 159 | 160 | =head1 COPYRIGHT 161 | 162 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 163 | 164 | This program is free software; you can redistribute it and/or 165 | modify it under the same terms as Perl itself. 166 | 167 | See F 168 | 169 | =cut 170 | -------------------------------------------------------------------------------- /t/lib/ddclient/Test/Fake/HTTPD/other-ca-cert.pem: -------------------------------------------------------------------------------- 1 | Certificate: 2 | Data: 3 | Version: 3 (0x2) 4 | Serial Number: 5 | 6c:bf:34:52:19:4d:c9:29:2b:a6:8b:41:59:aa:c6:c5:1f:a2:bb:10 6 | Signature Algorithm: sha256WithRSAEncryption 7 | Issuer: CN=Root Certification Authority 8 | Validity 9 | Not Before: Jan 8 08:24:32 2025 GMT 10 | Not After : Jan 9 08:24:32 2125 GMT 11 | Subject: CN=Root Certification Authority 12 | Subject Public Key Info: 13 | Public Key Algorithm: rsaEncryption 14 | Public-Key: (2048 bit) 15 | Modulus: 16 | 00:c3:3d:19:6b:72:0a:9e:87:c0:28:a1:ff:d0:08: 17 | 21:55:52:71:92:f2:98:36:75:fc:95:b4:0c:5e:c9: 18 | 98:b3:3c:a1:ee:cf:91:6f:07:bf:82:c9:d5:51:c0: 19 | eb:f8:46:17:41:52:1d:c6:89:ec:63:dd:5c:30:87: 20 | a7:b5:0d:dd:ae:bf:46:fd:de:1a:be:1d:69:83:0d: 21 | fb:d9:5a:33:0b:8d:5f:63:76:fc:a8:b1:54:37:1e: 22 | 0b:12:44:93:90:39:1c:48:ee:f0:f2:12:fe:dc:fb: 23 | 58:a5:76:3b:e8:e8:94:44:1e:9d:03:22:5f:21:6a: 24 | 17:66:d1:4a:bf:12:d7:3c:15:76:11:76:09:ab:bf: 25 | 21:ef:0c:a5:a9:e0:08:99:63:19:26:e4:d8:5d:c2: 26 | 40:8b:98:e6:5d:df:b3:8c:63:e2:01:7c:5e:fb:55: 27 | 39:a8:67:78:80:d2:6b:61:b2:e2:2e:93:c0:9d:91: 28 | 0e:a1:79:4f:fc:38:94:ff:6f:65:18:8f:3e:0b:8c: 29 | 1f:cd:48:d7:46:5a:a2:76:d6:e0:bd:3c:aa:3d:44: 30 | 9e:50:e6:fd:e1:12:1a:ee:a1:9a:69:48:60:63:da: 31 | 41:ae:a7:3d:36:1b:95:fb:b7:f1:0d:60:cd:2f:e3: 32 | b1:1f:b1:db:b4:98:a6:62:87:de:54:80:d1:45:43: 33 | 5b:25 34 | Exponent: 65537 (0x10001) 35 | X509v3 extensions: 36 | X509v3 Subject Key Identifier: 37 | E1:7C:D3:C3:9E:C7:F5:2C:DA:7C:D7:85:78:91:BA:26:88:61:F9:D4 38 | X509v3 Authority Key Identifier: 39 | E1:7C:D3:C3:9E:C7:F5:2C:DA:7C:D7:85:78:91:BA:26:88:61:F9:D4 40 | X509v3 Basic Constraints: critical 41 | CA:TRUE 42 | X509v3 Key Usage: critical 43 | Certificate Sign, CRL Sign 44 | Signature Algorithm: sha256WithRSAEncryption 45 | Signature Value: 46 | 9d:dc:49:c6:14:13:19:38:d9:14:b5:70:f0:3b:01:8e:d7:32: 47 | a7:69:f0:21:68:ec:ad:8c:ee:53:7d:16:64:7d:3e:c2:d2:ac: 48 | 5a:54:17:55:84:43:1e:46:1d:42:01:fb:89:e0:db:ec:e8:f0: 49 | 3c:22:82:54:1d:38:12:21:45:3c:37:44:3b:2e:c9:4d:ed:8d: 50 | 6e:46:f5:a5:cc:ba:39:61:ab:df:cf:1f:d2:c9:40:e2:db:3f: 51 | 05:ea:83:14:93:5f:0e:3d:33:be:98:04:80:87:25:3a:6c:ff: 52 | 8e:87:6a:32:ed:1e:ec:54:90:9b:2a:6e:12:05:6a:9d:15:48: 53 | 3c:ea:c6:9e:ab:71:58:1e:34:95:3f:9b:9e:e3:e5:4b:fb:9e: 54 | 32:f2:d6:59:bf:8d:09:d6:e4:9e:9e:47:b9:d6:78:5f:f3:0c: 55 | 98:ab:56:f0:18:5d:63:8e:83:ee:c1:f2:84:da:0e:64:af:1c: 56 | 18:ff:b3:f9:15:0b:02:50:77:d1:0b:6e:ba:61:bc:9e:c3:37: 57 | 63:91:26:e8:ce:77:9a:47:8f:ef:38:8f:9c:7f:f1:ab:7b:65: 58 | a5:96:b6:92:2e:c7:d3:c3:7a:54:0d:d6:76:f5:d6:88:13:3b: 59 | 17:e2:02:4e:3b:4d:10:95:0a:bb:47:e9:48:25:76:1d:7b:19: 60 | 5c:6f:b8:a1 61 | -----BEGIN CERTIFICATE----- 62 | MIIDQTCCAimgAwIBAgIUbL80UhlNySkrpotBWarGxR+iuxAwDQYJKoZIhvcNAQEL 63 | BQAwJzElMCMGA1UEAwwcUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAgFw0y 64 | NTAxMDgwODI0MzJaGA8yMTI1MDEwOTA4MjQzMlowJzElMCMGA1UEAwwcUm9vdCBD 65 | ZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC 66 | AQoCggEBAMM9GWtyCp6HwCih/9AIIVVScZLymDZ1/JW0DF7JmLM8oe7PkW8Hv4LJ 67 | 1VHA6/hGF0FSHcaJ7GPdXDCHp7UN3a6/Rv3eGr4daYMN+9laMwuNX2N2/KixVDce 68 | CxJEk5A5HEju8PIS/tz7WKV2O+jolEQenQMiXyFqF2bRSr8S1zwVdhF2Cau/Ie8M 69 | pangCJljGSbk2F3CQIuY5l3fs4xj4gF8XvtVOahneIDSa2Gy4i6TwJ2RDqF5T/w4 70 | lP9vZRiPPguMH81I10ZaonbW4L08qj1EnlDm/eESGu6hmmlIYGPaQa6nPTYblfu3 71 | 8Q1gzS/jsR+x27SYpmKH3lSA0UVDWyUCAwEAAaNjMGEwHQYDVR0OBBYEFOF808Oe 72 | x/Us2nzXhXiRuiaIYfnUMB8GA1UdIwQYMBaAFOF808Oex/Us2nzXhXiRuiaIYfnU 73 | MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMA0GCSqGSIb3DQEBCwUA 74 | A4IBAQCd3EnGFBMZONkUtXDwOwGO1zKnafAhaOytjO5TfRZkfT7C0qxaVBdVhEMe 75 | Rh1CAfuJ4Nvs6PA8IoJUHTgSIUU8N0Q7LslN7Y1uRvWlzLo5Yavfzx/SyUDi2z8F 76 | 6oMUk18OPTO+mASAhyU6bP+Oh2oy7R7sVJCbKm4SBWqdFUg86saeq3FYHjSVP5ue 77 | 4+VL+54y8tZZv40J1uSenke51nhf8wyYq1bwGF1jjoPuwfKE2g5krxwY/7P5FQsC 78 | UHfRC266YbyewzdjkSbozneaR4/vOI+cf/Gre2WllraSLsfTw3pUDdZ29daIEzsX 79 | 4gJOO00QlQq7R+lIJXYdexlcb7ih 80 | -----END CERTIFICATE----- 81 | -------------------------------------------------------------------------------- /t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem: -------------------------------------------------------------------------------- 1 | Certificate: 2 | Data: 3 | Version: 3 (0x2) 4 | Serial Number: 5 | 11:82:5d:80:30:4c:a9:6d:ed:68:88:10:c8:90:4d:08:50:3c:4c:b0 6 | Signature Algorithm: sha256WithRSAEncryption 7 | Issuer: CN=Root Certification Authority 8 | Validity 9 | Not Before: Jul 3 19:47:44 2020 GMT 10 | Not After : Jul 4 19:47:44 2120 GMT 11 | Subject: CN=Root Certification Authority 12 | Subject Public Key Info: 13 | Public Key Algorithm: rsaEncryption 14 | RSA Public-Key: (2048 bit) 15 | Modulus: 16 | 00:c5:f2:d9:a9:48:a2:06:dc:89:7d:e8:ab:2e:1f: 17 | 70:ea:da:82:46:45:4e:42:38:6e:8d:a6:3e:28:84: 18 | f1:25:c0:ea:25:af:61:ca:87:38:a5:7b:3f:d0:3a: 19 | 57:82:c7:eb:f1:b5:b4:70:0e:71:69:22:5f:ae:49: 20 | d3:51:df:19:97:bf:00:c3:de:99:3a:4d:f3:6d:4a: 21 | bf:73:7e:b1:aa:72:40:b1:0d:fc:d4:af:11:f5:a9: 22 | 7e:c3:36:7a:ac:25:86:a4:3e:7a:fe:3f:0f:22:f7: 23 | d6:87:15:ba:33:c1:36:c3:79:4d:79:b3:ca:a5:2d: 24 | 15:9a:63:ad:38:32:99:74:76:d7:72:7e:2f:69:ff: 25 | 7b:b0:f6:79:ad:da:2d:9f:51:4e:d9:70:15:9c:83: 26 | e9:10:8c:ec:7f:39:27:5d:b9:6e:86:c9:93:54:6b: 27 | aa:82:12:82:b0:32:36:c5:94:6c:48:bb:3f:c6:af: 28 | ef:1c:e1:0c:18:e6:0c:4c:bf:58:67:5b:1a:cd:15: 29 | 62:37:40:40:5f:1d:76:e2:24:01:28:65:cc:ed:3f: 30 | e1:f1:08:79:94:12:13:4c:4c:e2:a4:53:b8:fe:78: 31 | 7f:07:00:cd:c1:3a:7b:0e:f4:35:ce:83:c7:f3:ce: 32 | 71:9d:1f:7b:88:66:bc:b6:39:5e:26:28:e5:ef:5a: 33 | 0d:05 34 | Exponent: 65537 (0x10001) 35 | X509v3 extensions: 36 | X509v3 Subject Key Identifier: 37 | 21:E8:DE:B6:D8:64:01:72:02:C5:1C:CA:16:0C:D9:05:1A:14:A1:0C 38 | X509v3 Authority Key Identifier: 39 | keyid:21:E8:DE:B6:D8:64:01:72:02:C5:1C:CA:16:0C:D9:05:1A:14:A1:0C 40 | 41 | X509v3 Basic Constraints: critical 42 | CA:TRUE 43 | X509v3 Key Usage: critical 44 | Certificate Sign, CRL Sign 45 | Signature Algorithm: sha256WithRSAEncryption 46 | 9d:4c:17:84:f3:83:90:97:a7:df:e5:af:53:ac:d7:75:94:c4: 47 | a0:29:fa:d7:8f:a6:f8:fa:4b:d6:5e:d2:6e:8d:6d:46:89:1f: 48 | 7b:30:2c:2d:d3:3b:b6:64:1d:ec:ad:60:c1:96:4b:9a:bc:f9: 49 | d0:5d:af:a1:73:f7:03:99:8a:e2:59:47:48:1c:8f:7a:99:97: 50 | 20:78:e2:16:16:e4:c3:c9:82:4e:25:58:23:75:c9:9c:71:67: 51 | 8e:c4:79:e1:b9:ac:d9:c2:51:41:3d:a6:bf:07:0b:4b:14:8c: 52 | ca:42:0f:c3:b7:71:c0:fb:3e:5e:de:2b:e5:7f:92:52:50:12: 53 | 4f:63:a5:fa:3b:63:59:fa:37:3f:42:f4:ec:13:a0:c7:5d:0c: 54 | 9c:cd:6b:32:96:e7:44:da:5f:8c:cf:c7:51:eb:81:3b:cc:e8: 55 | 39:41:0c:a1:bb:8f:3a:f8:b1:ee:2b:97:f4:13:c9:a8:9c:1c: 56 | 2f:2f:51:57:e4:0c:4e:2b:29:7f:5e:12:72:63:8c:bb:40:2c: 57 | 97:14:bf:1e:7a:66:bc:64:af:78:80:64:19:37:ca:7a:f3:de: 58 | 15:e6:23:1d:d0:90:7d:e6:5f:21:88:23:c5:23:ca:f2:29:00: 59 | 1d:9a:7a:58:37:6d:a9:9e:ab:24:b1:c6:c5:3b:46:11:a7:53: 60 | 80:ef:aa:9c 61 | -----BEGIN CERTIFICATE----- 62 | MIIDQTCCAimgAwIBAgIUEYJdgDBMqW3taIgQyJBNCFA8TLAwDQYJKoZIhvcNAQEL 63 | BQAwJzElMCMGA1UEAwwcUm9vdCBDZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTAgFw0y 64 | MDA3MDMxOTQ3NDRaGA8yMTIwMDcwNDE5NDc0NFowJzElMCMGA1UEAwwcUm9vdCBD 65 | ZXJ0aWZpY2F0aW9uIEF1dGhvcml0eTCCASIwDQYJKoZIhvcNAQEBBQADggEPADCC 66 | AQoCggEBAMXy2alIogbciX3oqy4fcOragkZFTkI4bo2mPiiE8SXA6iWvYcqHOKV7 67 | P9A6V4LH6/G1tHAOcWkiX65J01HfGZe/AMPemTpN821Kv3N+sapyQLEN/NSvEfWp 68 | fsM2eqwlhqQ+ev4/DyL31ocVujPBNsN5TXmzyqUtFZpjrTgymXR213J+L2n/e7D2 69 | ea3aLZ9RTtlwFZyD6RCM7H85J125bobJk1RrqoISgrAyNsWUbEi7P8av7xzhDBjm 70 | DEy/WGdbGs0VYjdAQF8dduIkAShlzO0/4fEIeZQSE0xM4qRTuP54fwcAzcE6ew70 71 | Nc6Dx/POcZ0fe4hmvLY5XiYo5e9aDQUCAwEAAaNjMGEwHQYDVR0OBBYEFCHo3rbY 72 | ZAFyAsUcyhYM2QUaFKEMMB8GA1UdIwQYMBaAFCHo3rbYZAFyAsUcyhYM2QUaFKEM 73 | MA8GA1UdEwEB/wQFMAMBAf8wDgYDVR0PAQH/BAQDAgEGMA0GCSqGSIb3DQEBCwUA 74 | A4IBAQCdTBeE84OQl6ff5a9TrNd1lMSgKfrXj6b4+kvWXtJujW1GiR97MCwt0zu2 75 | ZB3srWDBlkuavPnQXa+hc/cDmYriWUdIHI96mZcgeOIWFuTDyYJOJVgjdcmccWeO 76 | xHnhuazZwlFBPaa/BwtLFIzKQg/Dt3HA+z5e3ivlf5JSUBJPY6X6O2NZ+jc/QvTs 77 | E6DHXQyczWsyludE2l+Mz8dR64E7zOg5QQyhu486+LHuK5f0E8monBwvL1FX5AxO 78 | Kyl/XhJyY4y7QCyXFL8eema8ZK94gGQZN8p6894V5iMd0JB95l8hiCPFI8ryKQAd 79 | mnpYN22pnqskscbFO0YRp1OA76qc 80 | -----END CERTIFICATE----- 81 | -------------------------------------------------------------------------------- /t/lib/Test2/Util/ExternalMeta.pm: -------------------------------------------------------------------------------- 1 | package Test2::Util::ExternalMeta; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | use Carp qw/croak/; 9 | 10 | sub META_KEY() { '_meta' } 11 | 12 | our @EXPORT = qw/meta set_meta get_meta delete_meta/; 13 | BEGIN { require Exporter; our @ISA = qw(Exporter) } 14 | 15 | sub set_meta { 16 | my $self = shift; 17 | my ($key, $value) = @_; 18 | 19 | validate_key($key); 20 | 21 | $self->{+META_KEY} ||= {}; 22 | $self->{+META_KEY}->{$key} = $value; 23 | } 24 | 25 | sub get_meta { 26 | my $self = shift; 27 | my ($key) = @_; 28 | 29 | validate_key($key); 30 | 31 | my $meta = $self->{+META_KEY} or return undef; 32 | return $meta->{$key}; 33 | } 34 | 35 | sub delete_meta { 36 | my $self = shift; 37 | my ($key) = @_; 38 | 39 | validate_key($key); 40 | 41 | my $meta = $self->{+META_KEY} or return undef; 42 | delete $meta->{$key}; 43 | } 44 | 45 | sub meta { 46 | my $self = shift; 47 | my ($key, $default) = @_; 48 | 49 | validate_key($key); 50 | 51 | my $meta = $self->{+META_KEY}; 52 | return undef unless $meta || defined($default); 53 | 54 | unless($meta) { 55 | $meta = {}; 56 | $self->{+META_KEY} = $meta; 57 | } 58 | 59 | $meta->{$key} = $default 60 | if defined($default) && !defined($meta->{$key}); 61 | 62 | return $meta->{$key}; 63 | } 64 | 65 | sub validate_key { 66 | my $key = shift; 67 | 68 | return if $key && !ref($key); 69 | 70 | my $render_key = defined($key) ? "'$key'" : 'undef'; 71 | croak "Invalid META key: $render_key, keys must be true, and may not be references"; 72 | } 73 | 74 | 1; 75 | 76 | __END__ 77 | 78 | =pod 79 | 80 | =encoding UTF-8 81 | 82 | =head1 NAME 83 | 84 | Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data 85 | to your instances. 86 | 87 | =head1 DESCRIPTION 88 | 89 | This package lets you define a clear, and consistent way to allow third party 90 | tools to attach meta-data to your instances. If your object consumes this 91 | package, and imports its methods, then third party meta-data has a safe place 92 | to live. 93 | 94 | =head1 SYNOPSIS 95 | 96 | package My::Object; 97 | use strict; 98 | use warnings; 99 | 100 | use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; 101 | 102 | ... 103 | 104 | Now to use it: 105 | 106 | my $inst = My::Object->new; 107 | 108 | $inst->set_meta(foo => 'bar'); 109 | my $val = $inst->get_meta('foo'); 110 | 111 | =head1 WHERE IS THE DATA STORED? 112 | 113 | This package assumes your instances are blessed hashrefs, it will not work if 114 | that is not true. It will store all meta-data in the C<_meta> key on your 115 | objects hash. If your object makes use of the C<_meta> key in its underlying 116 | hash, then there is a conflict and you cannot use this package. 117 | 118 | =head1 EXPORTS 119 | 120 | =over 4 121 | 122 | =item $val = $obj->meta($key) 123 | 124 | =item $val = $obj->meta($key, $default) 125 | 126 | This will get the value for a specified meta C<$key>. Normally this will return 127 | C when there is no value for the C<$key>, however you can specify a 128 | C<$default> value to set when no value is already set. 129 | 130 | =item $val = $obj->get_meta($key) 131 | 132 | This will get the value for a specified meta C<$key>. This does not have the 133 | C<$default> overhead that C does. 134 | 135 | =item $val = $obj->delete_meta($key) 136 | 137 | This will remove the value of a specified meta C<$key>. The old C<$val> will be 138 | returned. 139 | 140 | =item $obj->set_meta($key, $val) 141 | 142 | Set the value of a specified meta C<$key>. 143 | 144 | =back 145 | 146 | =head1 META-KEY RESTRICTIONS 147 | 148 | Meta keys must be defined, and must be true when used as a boolean. Keys may 149 | not be references. You are free to stringify a reference C<"$ref"> for use as a 150 | key, but this package will not stringify it for you. 151 | 152 | =head1 SOURCE 153 | 154 | The source code repository for Test2 can be found at 155 | F. 156 | 157 | =head1 MAINTAINERS 158 | 159 | =over 4 160 | 161 | =item Chad Granum Eexodist@cpan.orgE 162 | 163 | =back 164 | 165 | =head1 AUTHORS 166 | 167 | =over 4 168 | 169 | =item Chad Granum Eexodist@cpan.orgE 170 | 171 | =back 172 | 173 | =head1 COPYRIGHT 174 | 175 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 176 | 177 | This program is free software; you can redistribute it and/or 178 | modify it under the same terms as Perl itself. 179 | 180 | See F 181 | 182 | =cut 183 | -------------------------------------------------------------------------------- /t/lib/Test2/Formatter.pm: -------------------------------------------------------------------------------- 1 | package Test2::Formatter; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | my %ADDED; 9 | sub import { 10 | my $class = shift; 11 | return if $class eq __PACKAGE__; 12 | return if $ADDED{$class}++; 13 | require Test2::API; 14 | Test2::API::test2_formatter_add($class); 15 | } 16 | 17 | sub new_root { 18 | my $class = shift; 19 | return $class->new(@_); 20 | } 21 | 22 | sub supports_tables { 0 } 23 | 24 | sub hide_buffered { 1 } 25 | 26 | sub terminate { } 27 | 28 | sub finalize { } 29 | 30 | 1; 31 | 32 | __END__ 33 | 34 | =pod 35 | 36 | =encoding UTF-8 37 | 38 | =head1 NAME 39 | 40 | Test2::Formatter - Namespace for formatters. 41 | 42 | =head1 DESCRIPTION 43 | 44 | This is the namespace for formatters. This is an empty package. 45 | 46 | =head1 CREATING FORMATTERS 47 | 48 | A formatter is any package or object with a C method. 49 | 50 | package Test2::Formatter::Foo; 51 | use strict; 52 | use warnings; 53 | 54 | sub write { 55 | my $self_or_class = shift; 56 | my ($event, $assert_num) = @_; 57 | ... 58 | } 59 | 60 | sub hide_buffered { 1 } 61 | 62 | sub terminate { } 63 | 64 | sub finalize { } 65 | 66 | sub supports_tables { return $BOOL } 67 | 68 | sub new_root { 69 | my $class = shift; 70 | ... 71 | $class->new(@_); 72 | } 73 | 74 | 1; 75 | 76 | The C method is a method, so it either gets a class or instance. The two 77 | arguments are the C<$event> object it should record, and the C<$assert_num> 78 | which is the number of the current assertion (ok), or the last assertion if 79 | this event is not itself an assertion. The assertion number may be any integer 0 80 | or greater, and may be undefined in some cases. 81 | 82 | The C method must return a boolean. This is used to tell 83 | buffered subtests whether or not to send it events as they are being buffered. 84 | See L for more information. 85 | 86 | The C and C methods are optional methods called that you 87 | can implement if the format you're generating needs to handle these cases, for 88 | example if you are generating XML and need close open tags. 89 | 90 | The C method is called when an event's C method returns 91 | true, for example when a L has a C<'skip_all'> plan, or 92 | when a L event is sent. The C method is passed 93 | a single argument, the L object which triggered the terminate. 94 | 95 | The C method is always the last thing called on the formatter, I<< 96 | except when C is called for a Bail event >>. It is passed the 97 | following arguments: 98 | 99 | The C method should be true if the formatter supports directly 100 | rendering table data from the C facets. This is a newer feature and many 101 | older formatters may not support it. When not supported the formatter falls 102 | back to rendering C instead of the C
data. 103 | 104 | The C method is used when constructing a root formatter. The default 105 | is to just delegate to the regular C method, most formatters can ignore 106 | this. 107 | 108 | =over 4 109 | 110 | =item * The number of tests that were planned 111 | 112 | =item * The number of tests actually seen 113 | 114 | =item * The number of tests which failed 115 | 116 | =item * A boolean indicating whether or not the test suite passed 117 | 118 | =item * A boolean indicating whether or not this call is for a subtest 119 | 120 | =back 121 | 122 | The C method is called when C Initializes the root 123 | hub for the first time. Most formatters will simply have this call C<< 124 | $class->new >>, which is the default behavior. Some formatters however may want 125 | to take extra action during construction of the root formatter, this is where 126 | they can do that. 127 | 128 | =head1 SOURCE 129 | 130 | The source code repository for Test2 can be found at 131 | F. 132 | 133 | =head1 MAINTAINERS 134 | 135 | =over 4 136 | 137 | =item Chad Granum Eexodist@cpan.orgE 138 | 139 | =back 140 | 141 | =head1 AUTHORS 142 | 143 | =over 4 144 | 145 | =item Chad Granum Eexodist@cpan.orgE 146 | 147 | =back 148 | 149 | =head1 COPYRIGHT 150 | 151 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 152 | 153 | This program is free software; you can redistribute it and/or 154 | modify it under the same terms as Perl itself. 155 | 156 | See F 157 | 158 | =cut 159 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | AC_PREREQ([2.63]) 2 | # Get the version from ddclient.in so that the same version string 3 | # doesn't have to be maintained in two places. The m4_dquote macro is 4 | # used instead of quote characters to ensure that the command is only 5 | # run once. The command outputs quote characters to prevent 6 | # incidental expansion (the m4_esyscmd macro does not quote the 7 | # command output itself, so the command output is subject to 8 | # expansion). 9 | AC_INIT([ddclient], m4_dquote(m4_esyscmd([printf '[%s]' "$(./ddclient.in --version=short)"]))) 10 | # Needed because of the above invocation of ddclient.in. 11 | AC_SUBST([CONFIGURE_DEPENDENCIES], ['$(top_srcdir)/ddclient.in']) 12 | AC_CONFIG_SRCDIR([ddclient.in]) 13 | AC_CONFIG_AUX_DIR([build-aux]) 14 | AC_CONFIG_MACRO_DIR([build-aux/m4]) 15 | AC_REQUIRE_AUX_FILE([tap-driver.sh]) 16 | # If the automake dependency is bumped to v1.12 or newer, remove 17 | # build-aux/tap-driver.sh from the repository. Automake 1.12+ comes 18 | # with tap-driver.sh, and autoreconf will copy in the version 19 | # distributed with automake. (Automake 1.11 and older don't come with 20 | # tap-driver.sh, so build-aux/tap-driver.sh is checked in to keep the 21 | # above AC_REQUIRE_AUX_FILE line from causing configure to complain 22 | # about a mising file if the user has Automake 1.11.) 23 | AM_INIT_AUTOMAKE([1.11 -Wall -Werror foreign subdir-objects parallel-tests]) 24 | AM_SILENT_RULES 25 | 26 | m4_define([CONFDIR_DEFAULT], [${sysconfdir}/AC_PACKAGE_NAME]) 27 | AC_ARG_WITH( 28 | [confdir], 29 | [AS_HELP_STRING( 30 | [--with-confdir=DIR], 31 | m4_expand([[look for ddclient.conf in DIR @<:@default: ]CONFDIR_DEFAULT[@:>@]]))], 32 | [], 33 | # The single quotes are intentional; see: 34 | # https://www.gnu.org/software/automake/manual/html_node/Uniform.html 35 | [with_confdir='CONFDIR_DEFAULT']) 36 | AC_SUBST([confdir], [${with_confdir}]) 37 | 38 | AC_PROG_MKDIR_P 39 | 40 | # The Fedora Docker image doesn't come with the 'findutils' package. 41 | # 'find' is required for 'make distcheck', which the user might not 42 | # run. We could log a warning instead of erroring out, but: 43 | # * a warning is unlikely to be seen, 44 | # * 'make distcheck' doesn't yield a non-0 exit code if 'find' is 45 | # not available, 46 | # * 'find' is a core utility that should always be available, and 47 | # * we might use 'find' for other purposes in the future. 48 | AC_PATH_PROG([FIND], [find]) 49 | AS_IF([test -z "${FIND}"], [AC_MSG_ERROR(['find' utility not found])]) 50 | 51 | AC_ARG_WITH([curl], 52 | [AS_HELP_STRING([[--with-curl[=CURL]]], [use CURL as absolute path to curl executable])], 53 | [], 54 | [with_curl=yes]) 55 | AS_CASE([${with_curl}], 56 | [[yes]], [AC_PATH_PROG([CURL], [curl])], 57 | [[no]], [CURL=], 58 | [ 59 | AC_MSG_CHECKING([for curl]) 60 | CURL=${with_curl} 61 | AC_MSG_RESULT([${CURL}]) 62 | ]); 63 | AS_IF([test -z "${CURL}"], [AC_MSG_ERROR([curl not found])]) 64 | 65 | AX_WITH_PROG([PERL], perl) 66 | AX_PROG_PERL_VERSION([5.10.1], [], 67 | [AC_MSG_ERROR([Perl 5.10.1 or newer not found])]) 68 | AC_SUBST([PERL]) 69 | 70 | # Perl modules required to run ddclient. Note: CentOS, RHEL, and 71 | # Fedora put some core modules in separate packages, and the perl 72 | # package doesn't depend on all of them, so their availability can't 73 | # be assumed. 74 | m4_foreach_w([_m], [ 75 | Data::Dumper 76 | File::Basename 77 | File::Path 78 | File::Temp 79 | Getopt::Long 80 | Socket 81 | Sys::Hostname 82 | version=0.77 83 | ], [AX_PROG_PERL_MODULES([_m], [], 84 | [AC_MSG_ERROR([missing required Perl module _m])])]) 85 | 86 | # Perl modules required for tests. If these modules are not installed 87 | # then some tests will fail. Only prints a warning if not installed. 88 | m4_foreach_w([_m], [ 89 | B 90 | Exporter 91 | File::Spec::Functions 92 | File::Temp 93 | List::Util 94 | Scalar::Util 95 | re 96 | ], [AX_PROG_PERL_MODULES([_m], [], 97 | [AC_MSG_WARN([some tests will fail due to missing module _m])])]) 98 | 99 | # Optional Perl modules for tests. If these modules are not installed 100 | # then some tests will be skipped, but no tests should fail. Only 101 | # prints a warning if not installed. 102 | m4_foreach_w([_m], [ 103 | Carp 104 | HTTP::Daemon=6.12 105 | HTTP::Daemon::SSL 106 | HTTP::Message::PSGI 107 | HTTP::Request 108 | HTTP::Response 109 | JSON::PP 110 | Test::MockModule 111 | Test::TCP 112 | Test::Warnings 113 | Time::HiRes 114 | URI 115 | parent 116 | ], [AX_PROG_PERL_MODULES([_m], [], 117 | [AC_MSG_WARN([some tests may be skipped due to missing module _m])])]) 118 | 119 | AC_CONFIG_FILES([ 120 | Makefile 121 | t/version.pl 122 | ]) 123 | AC_OUTPUT 124 | -------------------------------------------------------------------------------- /t/lib/Test/Builder/Module.pm: -------------------------------------------------------------------------------- 1 | package Test::Builder::Module; 2 | 3 | use strict; 4 | 5 | use Test::Builder; 6 | 7 | require Exporter; 8 | our @ISA = qw(Exporter); 9 | 10 | our $VERSION = '1.302175'; 11 | 12 | 13 | =head1 NAME 14 | 15 | Test::Builder::Module - Base class for test modules 16 | 17 | =head1 SYNOPSIS 18 | 19 | # Emulates Test::Simple 20 | package Your::Module; 21 | 22 | my $CLASS = __PACKAGE__; 23 | 24 | use parent 'Test::Builder::Module'; 25 | @EXPORT = qw(ok); 26 | 27 | sub ok ($;$) { 28 | my $tb = $CLASS->builder; 29 | return $tb->ok(@_); 30 | } 31 | 32 | 1; 33 | 34 | 35 | =head1 DESCRIPTION 36 | 37 | This is a superclass for L-based modules. It provides a 38 | handful of common functionality and a method of getting at the underlying 39 | L object. 40 | 41 | 42 | =head2 Importing 43 | 44 | Test::Builder::Module is a subclass of L which means your 45 | module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc... 46 | all act normally. 47 | 48 | A few methods are provided to do the C<< use Your::Module tests => 23 >> part 49 | for you. 50 | 51 | =head3 import 52 | 53 | Test::Builder::Module provides an C method which acts in the 54 | same basic way as L's, setting the plan and controlling 55 | exporting of functions and variables. This allows your module to set 56 | the plan independent of L. 57 | 58 | All arguments passed to C are passed onto 59 | C<< Your::Module->builder->plan() >> with the exception of 60 | C<< import =>[qw(things to import)] >>. 61 | 62 | use Your::Module import => [qw(this that)], tests => 23; 63 | 64 | says to import the functions C and C as well as set the plan 65 | to be 23 tests. 66 | 67 | C also sets the C attribute of your builder to be 68 | the caller of the C function. 69 | 70 | Additional behaviors can be added to your C method by overriding 71 | C. 72 | 73 | =cut 74 | 75 | sub import { 76 | my($class) = shift; 77 | 78 | Test2::API::test2_load() unless Test2::API::test2_in_preload(); 79 | 80 | # Don't run all this when loading ourself. 81 | return 1 if $class eq 'Test::Builder::Module'; 82 | 83 | my $test = $class->builder; 84 | 85 | my $caller = caller; 86 | 87 | $test->exported_to($caller); 88 | 89 | $class->import_extra( \@_ ); 90 | my(@imports) = $class->_strip_imports( \@_ ); 91 | 92 | $test->plan(@_); 93 | 94 | local $Exporter::ExportLevel = $Exporter::ExportLevel + 1; 95 | $class->Exporter::import(@imports); 96 | } 97 | 98 | sub _strip_imports { 99 | my $class = shift; 100 | my $list = shift; 101 | 102 | my @imports = (); 103 | my @other = (); 104 | my $idx = 0; 105 | while( $idx <= $#{$list} ) { 106 | my $item = $list->[$idx]; 107 | 108 | if( defined $item and $item eq 'import' ) { 109 | push @imports, @{ $list->[ $idx + 1 ] }; 110 | $idx++; 111 | } 112 | else { 113 | push @other, $item; 114 | } 115 | 116 | $idx++; 117 | } 118 | 119 | @$list = @other; 120 | 121 | return @imports; 122 | } 123 | 124 | =head3 import_extra 125 | 126 | Your::Module->import_extra(\@import_args); 127 | 128 | C is called by C. It provides an opportunity for you 129 | to add behaviors to your module based on its import list. 130 | 131 | Any extra arguments which shouldn't be passed on to C should be 132 | stripped off by this method. 133 | 134 | See L for an example of its use. 135 | 136 | B This mechanism is I as it 137 | feels like a bit of an ugly hack in its current form. 138 | 139 | =cut 140 | 141 | sub import_extra { } 142 | 143 | =head2 Builder 144 | 145 | Test::Builder::Module provides some methods of getting at the underlying 146 | Test::Builder object. 147 | 148 | =head3 builder 149 | 150 | my $builder = Your::Class->builder; 151 | 152 | This method returns the L object associated with Your::Class. 153 | It is not a constructor so you can call it as often as you like. 154 | 155 | This is the preferred way to get the L object. You should 156 | I get it via C<< Test::Builder->new >> as was previously 157 | recommended. 158 | 159 | The object returned by C may change at runtime so you should 160 | call C inside each function rather than store it in a global. 161 | 162 | sub ok { 163 | my $builder = Your::Class->builder; 164 | 165 | return $builder->ok(@_); 166 | } 167 | 168 | 169 | =cut 170 | 171 | sub builder { 172 | return Test::Builder->new; 173 | } 174 | 175 | =head1 SEE ALSO 176 | 177 | L<< Test2::Manual::Tooling::TestBuilder >> describes the improved 178 | options for writing testing modules provided by L<< Test2 >>. 179 | 180 | =cut 181 | 182 | 1; 183 | -------------------------------------------------------------------------------- /t/skip.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | BEGIN { SKIP: { eval { require Test::Warnings; 1; } or skip($@, 1); } } 3 | BEGIN { eval { require 'ddclient'; } or BAIL_OUT($@); } 4 | use ddclient::t::HTTPD; 5 | use ddclient::t::ip; 6 | 7 | httpd_required(); 8 | 9 | httpd('4')->run( 10 | sub { return [200, ['Content-Type' => 'text/plain'], ['127.0.0.1 skip 127.0.0.2']]; }); 11 | httpd('6')->run( 12 | sub { return [200, ['Content-Type' => 'text/plain'], ['::1 skip ::2']]; }) 13 | if httpd('6'); 14 | 15 | my $builtinwebv4 = 't/skip.pl webv4'; 16 | my $builtinwebv6 = 't/skip.pl webv6'; 17 | my $builtinfw = 't/skip.pl fw'; 18 | 19 | $ddclient::builtinweb{$builtinwebv4} = {'url' => httpd('4')->endpoint(), 'skip' => 'skip'}; 20 | $ddclient::builtinweb{$builtinwebv6} = {'url' => httpd('6')->endpoint(), 'skip' => 'skip'} 21 | if httpd('6'); 22 | $ddclient::builtinfw{$builtinfw} = {name => 'test', skip => 'skip'}; 23 | %ddclient::builtinfw if 0; # suppress spurious warning "Name used only once: possible typo" 24 | %ddclient::ip_strategies = (%ddclient::ip_strategies, ddclient::builtinfw_strategy($builtinfw)); 25 | %ddclient::ipv4_strategies = 26 | (%ddclient::ipv4_strategies, ddclient::builtinfwv4_strategy($builtinfw)); 27 | %ddclient::ipv6_strategies = 28 | (%ddclient::ipv6_strategies, ddclient::builtinfwv6_strategy($builtinfw)); 29 | 30 | sub run_test_case { 31 | my %tc = @_; 32 | SKIP: { 33 | skip("IPv6 not supported on this system", 1) if $tc{ipv6} && !$ipv6_supported; 34 | skip("HTTP::Daemon too old for IPv6 support", 1) if $tc{ipv6} && !$httpd_ipv6_supported; 35 | my $h = 't/skip.pl'; 36 | $ddclient::config{$h} = $tc{cfg}; 37 | %ddclient::config if 0; # suppress spurious warning "Name used only once: possible typo" 38 | is(ddclient::get_ip(ddclient::strategy_inputs('use', $h)), $tc{want}, $tc{desc}) 39 | if ($tc{cfg}{use}); 40 | is(ddclient::get_ipv4(ddclient::strategy_inputs('usev4', $h)), $tc{want}, $tc{desc}) 41 | if ($tc{cfg}{usev4}); 42 | is(ddclient::get_ipv6(ddclient::strategy_inputs('usev6', $h)), $tc{want}, $tc{desc}) 43 | if ($tc{cfg}{usev6}); 44 | } 45 | } 46 | 47 | subtest "use=web web='$builtinwebv4'" => sub { 48 | run_test_case( 49 | desc => "web-skip='' cancels built-in skip", 50 | cfg => { 51 | 'use' => 'web', 52 | 'web' => $builtinwebv4, 53 | 'web-skip' => '', 54 | }, 55 | want => '127.0.0.1', 56 | ); 57 | run_test_case( 58 | desc => 'web-skip=undef uses built-in skip', 59 | cfg => { 60 | 'use' => 'web', 61 | 'web' => $builtinwebv4, 62 | 'web-skip' => undef, 63 | }, 64 | want => '127.0.0.2', 65 | ); 66 | }; 67 | subtest "usev4=webv4 webv4='$builtinwebv4'" => sub { 68 | run_test_case( 69 | desc => "webv4-skip='' cancels built-in skip", 70 | cfg => { 71 | 'usev4' => 'webv4', 72 | 'webv4' => $builtinwebv4, 73 | 'webv4-skip' => '', 74 | }, 75 | want => '127.0.0.1', 76 | ); 77 | run_test_case( 78 | desc => 'webv4-skip=undef uses built-in skip', 79 | cfg => { 80 | 'usev4' => 'webv4', 81 | 'webv4' => $builtinwebv4, 82 | 'webv4-skip' => undef, 83 | }, 84 | want => '127.0.0.2', 85 | ); 86 | }; 87 | subtest "usev6=webv6 webv6='$builtinwebv6'" => sub { 88 | run_test_case( 89 | desc => "webv6-skip='' cancels built-in skip", 90 | cfg => { 91 | 'usev6' => 'webv6', 92 | 'webv6' => $builtinwebv6, 93 | 'webv6-skip' => '', 94 | }, 95 | ipv6 => 1, 96 | want => '::1', 97 | ); 98 | run_test_case( 99 | desc => 'webv6-skip=undef uses built-in skip', 100 | cfg => { 101 | 'usev6' => 'webv6', 102 | 'webv6' => $builtinwebv6, 103 | 'webv6-skip' => undef, 104 | }, 105 | ipv6 => 1, 106 | want => '::2', 107 | ); 108 | }; 109 | subtest "use='$builtinfw'" => sub { 110 | run_test_case( 111 | desc => "fw-skip='' cancels built-in skip", 112 | cfg => { 113 | 'fw' => httpd('4')->endpoint(), 114 | 'fw-skip' => '', 115 | 'use' => $builtinfw, 116 | }, 117 | want => '127.0.0.1', 118 | ); 119 | run_test_case( 120 | desc => 'fw-skip=undef uses built-in skip', 121 | cfg => { 122 | 'fw' => httpd('4')->endpoint(), 123 | 'fw-skip' => undef, 124 | 'use' => $builtinfw, 125 | }, 126 | want => '127.0.0.2', 127 | ); 128 | }; 129 | subtest "usev4='$builtinfw'" => sub { 130 | run_test_case( 131 | desc => "fwv4-skip='' cancels built-in skip", 132 | cfg => { 133 | 'fwv4' => httpd('4')->endpoint(), 134 | 'fwv4-skip' => '', 135 | 'usev4' => $builtinfw, 136 | }, 137 | want => '127.0.0.1', 138 | ); 139 | run_test_case( 140 | desc => 'fwv4-skip=undef uses built-in skip', 141 | cfg => { 142 | 'fwv4' => httpd('4')->endpoint(), 143 | 'fwv4-skip' => undef, 144 | 'usev4' => $builtinfw, 145 | }, 146 | want => '127.0.0.2', 147 | ); 148 | }; 149 | 150 | done_testing(); 151 | -------------------------------------------------------------------------------- /Makefile.am: -------------------------------------------------------------------------------- 1 | ACLOCAL_AMFLAGS = -I build-aux/m4 2 | EXTRA_DIST = \ 3 | CONTRIBUTING.md \ 4 | COPYING \ 5 | COPYRIGHT \ 6 | ChangeLog.md \ 7 | README.cisco \ 8 | README.md \ 9 | autogen \ 10 | sample-ddclient-wrapper.sh \ 11 | sample-etc_cron.d_ddclient \ 12 | sample-etc_dhclient-exit-hooks \ 13 | sample-etc_dhcpc_dhcpcd-eth0.exe \ 14 | sample-etc_ppp_ip-up.local \ 15 | sample-etc_systemd.service \ 16 | sample-get-ip-from-fritzbox 17 | CLEANFILES = 18 | 19 | subst_files = ddclient ddclient.conf 20 | EXTRA_DIST += $(subst_files:=.in) 21 | CLEANFILES += $(subst_files) 22 | 23 | $(subst_files): Makefile 24 | rm -f '$@' '$@'.tmp 25 | in='$@'.in; \ 26 | test -f "$${in}" || in='$(srcdir)/'$${in}; \ 27 | sed \ 28 | -e 's|@PACKAGE_VERSION[@]|$(PACKAGE_VERSION)|g' \ 29 | -e '1 s|^#\!.*perl$$|#\!$(PERL)|g' \ 30 | -e 's|@localstatedir[@]|$(localstatedir)|g' \ 31 | -e 's|@confdir[@]|$(confdir)|g' \ 32 | -e 's|@runstatedir[@]|$(runstatedir)|g' \ 33 | -e 's|@CURL[@]|$(CURL)|g' \ 34 | "$${in}" >'$@'.tmp && \ 35 | { ! test -x "$${in}" || chmod +x '$@'.tmp; } 36 | mv '$@'.tmp '$@' 37 | 38 | ddclient: $(srcdir)/ddclient.in 39 | ddclient.conf: $(srcdir)/ddclient.conf.in 40 | 41 | bin_SCRIPTS = ddclient 42 | 43 | conf_DATA = ddclient.conf 44 | 45 | install-data-local: 46 | $(MKDIR_P) '$(DESTDIR)$(localstatedir)'/cache/ddclient 47 | 48 | AM_TESTS_ENVIRONMENT = \ 49 | abs_top_srcdir='$(abs_top_srcdir)'; export abs_top_srcdir; 50 | LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) \ 51 | $(top_srcdir)/build-aux/tap-driver.sh 52 | TEST_EXTENSIONS = .pl 53 | PL_LOG_DRIVER = $(LOG_DRIVER) 54 | PL_LOG_COMPILER = $(PERL) 55 | AM_PL_LOG_FLAGS = -Mstrict -w \ 56 | -I'$(abs_top_builddir)' \ 57 | -I'$(abs_top_srcdir)'/t/lib \ 58 | -MDevel::Autoflush 59 | handwritten_tests = \ 60 | t/builtinfw_query.pl \ 61 | t/check_value.pl \ 62 | t/get_ip_from_if.pl \ 63 | t/geturl_connectivity.pl \ 64 | t/geturl_response.pl \ 65 | t/group_hosts_by.pl \ 66 | t/header_ok.pl \ 67 | t/interval_expired.pl \ 68 | t/is-and-extract-ipv4.pl \ 69 | t/is-and-extract-ipv6.pl \ 70 | t/is-and-extract-ipv6-global.pl \ 71 | t/logmsg.pl \ 72 | t/parse_assignments.pl \ 73 | t/protocol_directnic.pl \ 74 | t/protocol_dnsexit2.pl \ 75 | t/protocol_dyndns2.pl \ 76 | t/read_recap.pl \ 77 | t/skip.pl \ 78 | t/ssl-validate.pl \ 79 | t/update_nics.pl \ 80 | t/use_cmd.pl \ 81 | t/use_web.pl \ 82 | t/variable_defaults.pl \ 83 | t/write_recap.pl 84 | generated_tests = \ 85 | t/version.pl 86 | TESTS = $(handwritten_tests) $(generated_tests) 87 | $(TESTS): ddclient 88 | EXTRA_DIST += $(handwritten_tests) \ 89 | .autom4te.cfg \ 90 | t/lib/Devel/Autoflush.pm \ 91 | t/lib/Test/Builder.pm \ 92 | t/lib/Test/Builder/Formatter.pm \ 93 | t/lib/Test/Builder/IO/Scalar.pm \ 94 | t/lib/Test/Builder/Module.pm \ 95 | t/lib/Test/Builder/Tester.pm \ 96 | t/lib/Test/Builder/Tester/Color.pm \ 97 | t/lib/Test/Builder/TodoDiag.pm \ 98 | t/lib/Test/More.pm \ 99 | t/lib/Test/Simple.pm \ 100 | t/lib/Test/Tester.pm \ 101 | t/lib/Test/Tester/Capture.pm \ 102 | t/lib/Test/Tester/CaptureRunner.pm \ 103 | t/lib/Test/Tester/Delegate.pm \ 104 | t/lib/Test/use/ok.pm \ 105 | t/lib/Test2.pm \ 106 | t/lib/Test2/API.pm \ 107 | t/lib/Test2/API/Breakage.pm \ 108 | t/lib/Test2/API/Context.pm \ 109 | t/lib/Test2/API/Instance.pm \ 110 | t/lib/Test2/API/Stack.pm \ 111 | t/lib/Test2/Event.pm \ 112 | t/lib/Test2/Event/Bail.pm \ 113 | t/lib/Test2/Event/Diag.pm \ 114 | t/lib/Test2/Event/Encoding.pm \ 115 | t/lib/Test2/Event/Exception.pm \ 116 | t/lib/Test2/Event/Fail.pm \ 117 | t/lib/Test2/Event/Generic.pm \ 118 | t/lib/Test2/Event/Note.pm \ 119 | t/lib/Test2/Event/Ok.pm \ 120 | t/lib/Test2/Event/Pass.pm \ 121 | t/lib/Test2/Event/Plan.pm \ 122 | t/lib/Test2/Event/Skip.pm \ 123 | t/lib/Test2/Event/Subtest.pm \ 124 | t/lib/Test2/Event/TAP/Version.pm \ 125 | t/lib/Test2/Event/V2.pm \ 126 | t/lib/Test2/Event/Waiting.pm \ 127 | t/lib/Test2/EventFacet.pm \ 128 | t/lib/Test2/EventFacet/About.pm \ 129 | t/lib/Test2/EventFacet/Amnesty.pm \ 130 | t/lib/Test2/EventFacet/Assert.pm \ 131 | t/lib/Test2/EventFacet/Control.pm \ 132 | t/lib/Test2/EventFacet/Error.pm \ 133 | t/lib/Test2/EventFacet/Hub.pm \ 134 | t/lib/Test2/EventFacet/Info.pm \ 135 | t/lib/Test2/EventFacet/Info/Table.pm \ 136 | t/lib/Test2/EventFacet/Meta.pm \ 137 | t/lib/Test2/EventFacet/Parent.pm \ 138 | t/lib/Test2/EventFacet/Plan.pm \ 139 | t/lib/Test2/EventFacet/Render.pm \ 140 | t/lib/Test2/EventFacet/Trace.pm \ 141 | t/lib/Test2/Formatter.pm \ 142 | t/lib/Test2/Formatter/TAP.pm \ 143 | t/lib/Test2/Hub.pm \ 144 | t/lib/Test2/Hub/Interceptor.pm \ 145 | t/lib/Test2/Hub/Interceptor/Terminator.pm \ 146 | t/lib/Test2/Hub/Subtest.pm \ 147 | t/lib/Test2/IPC.pm \ 148 | t/lib/Test2/IPC/Driver.pm \ 149 | t/lib/Test2/IPC/Driver/Files.pm \ 150 | t/lib/Test2/Tools/Tiny.pm \ 151 | t/lib/Test2/Util.pm \ 152 | t/lib/Test2/Util/ExternalMeta.pm \ 153 | t/lib/Test2/Util/Facets2Legacy.pm \ 154 | t/lib/Test2/Util/HashBase.pm \ 155 | t/lib/Test2/Util/Trace.pm \ 156 | t/lib/ddclient/Test/Fake/HTTPD.pm \ 157 | t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem \ 158 | t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem \ 159 | t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem \ 160 | t/lib/ddclient/Test/Fake/HTTPD/other-ca-cert.pem \ 161 | t/lib/ddclient/t.pm \ 162 | t/lib/ddclient/t/HTTPD.pm \ 163 | t/lib/ddclient/t/Logger.pm \ 164 | t/lib/ddclient/t/ip.pm \ 165 | t/lib/ok.pm 166 | -------------------------------------------------------------------------------- /t/lib/Test/Tester/Capture.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | 3 | package Test::Tester::Capture; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | use Test::Builder; 9 | 10 | use vars qw( @ISA ); 11 | @ISA = qw( Test::Builder ); 12 | 13 | # Make Test::Tester::Capture thread-safe for ithreads. 14 | BEGIN { 15 | use Config; 16 | *share = sub { 0 }; 17 | *lock = sub { 0 }; 18 | } 19 | 20 | my $Curr_Test = 0; share($Curr_Test); 21 | my @Test_Results = (); share(@Test_Results); 22 | my $Prem_Diag = {diag => ""}; share($Curr_Test); 23 | 24 | sub new 25 | { 26 | # Test::Tester::Capgture::new used to just return __PACKAGE__ 27 | # because Test::Builder::new enforced its singleton nature by 28 | # return __PACKAGE__. That has since changed, Test::Builder::new now 29 | # returns a blessed has and around version 0.78, Test::Builder::todo 30 | # started wanting to modify $self. To cope with this, we now return 31 | # a blessed hash. This is a short-term hack, the correct thing to do 32 | # is to detect which style of Test::Builder we're dealing with and 33 | # act appropriately. 34 | 35 | my $class = shift; 36 | return bless {}, $class; 37 | } 38 | 39 | sub ok { 40 | my($self, $test, $name) = @_; 41 | 42 | my $ctx = $self->ctx; 43 | 44 | # $test might contain an object which we don't want to accidentally 45 | # store, so we turn it into a boolean. 46 | $test = $test ? 1 : 0; 47 | 48 | lock $Curr_Test; 49 | $Curr_Test++; 50 | 51 | my($pack, $file, $line) = $self->caller; 52 | 53 | my $todo = $self->todo(); 54 | 55 | my $result = {}; 56 | share($result); 57 | 58 | unless( $test ) { 59 | @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); 60 | } 61 | else { 62 | @$result{ 'ok', 'actual_ok' } = ( 1, $test ); 63 | } 64 | 65 | if( defined $name ) { 66 | $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. 67 | $result->{name} = $name; 68 | } 69 | else { 70 | $result->{name} = ''; 71 | } 72 | 73 | if( $todo ) { 74 | my $what_todo = $todo; 75 | $result->{reason} = $what_todo; 76 | $result->{type} = 'todo'; 77 | } 78 | else { 79 | $result->{reason} = ''; 80 | $result->{type} = ''; 81 | } 82 | 83 | $Test_Results[$Curr_Test-1] = $result; 84 | 85 | unless( $test ) { 86 | my $msg = $todo ? "Failed (TODO)" : "Failed"; 87 | $result->{fail_diag} = (" $msg test ($file at line $line)\n"); 88 | } 89 | 90 | $result->{diag} = ""; 91 | $result->{_level} = $Test::Builder::Level; 92 | $result->{_depth} = Test::Tester::find_run_tests(); 93 | 94 | $ctx->release; 95 | 96 | return $test ? 1 : 0; 97 | } 98 | 99 | sub skip { 100 | my($self, $why) = @_; 101 | $why ||= ''; 102 | 103 | my $ctx = $self->ctx; 104 | 105 | lock($Curr_Test); 106 | $Curr_Test++; 107 | 108 | my %result; 109 | share(%result); 110 | %result = ( 111 | 'ok' => 1, 112 | actual_ok => 1, 113 | name => '', 114 | type => 'skip', 115 | reason => $why, 116 | diag => "", 117 | _level => $Test::Builder::Level, 118 | _depth => Test::Tester::find_run_tests(), 119 | ); 120 | $Test_Results[$Curr_Test-1] = \%result; 121 | 122 | $ctx->release; 123 | return 1; 124 | } 125 | 126 | sub todo_skip { 127 | my($self, $why) = @_; 128 | $why ||= ''; 129 | 130 | my $ctx = $self->ctx; 131 | 132 | lock($Curr_Test); 133 | $Curr_Test++; 134 | 135 | my %result; 136 | share(%result); 137 | %result = ( 138 | 'ok' => 1, 139 | actual_ok => 0, 140 | name => '', 141 | type => 'todo_skip', 142 | reason => $why, 143 | diag => "", 144 | _level => $Test::Builder::Level, 145 | _depth => Test::Tester::find_run_tests(), 146 | ); 147 | 148 | $Test_Results[$Curr_Test-1] = \%result; 149 | 150 | $ctx->release; 151 | return 1; 152 | } 153 | 154 | sub diag { 155 | my($self, @msgs) = @_; 156 | return unless @msgs; 157 | 158 | # Prevent printing headers when compiling (i.e. -c) 159 | return if $^C; 160 | 161 | my $ctx = $self->ctx; 162 | 163 | # Escape each line with a #. 164 | foreach (@msgs) { 165 | $_ = 'undef' unless defined; 166 | } 167 | 168 | push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; 169 | 170 | my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag; 171 | 172 | $result->{diag} .= join("", @msgs); 173 | 174 | $ctx->release; 175 | return 0; 176 | } 177 | 178 | sub details { 179 | return @Test_Results; 180 | } 181 | 182 | 183 | # Stub. Feel free to send me a patch to implement this. 184 | sub note { 185 | } 186 | 187 | sub explain { 188 | return Test::Builder::explain(@_); 189 | } 190 | 191 | sub premature 192 | { 193 | return $Prem_Diag->{diag}; 194 | } 195 | 196 | sub current_test 197 | { 198 | if (@_ > 1) 199 | { 200 | die "Don't try to change the test number!"; 201 | } 202 | else 203 | { 204 | return $Curr_Test; 205 | } 206 | } 207 | 208 | sub reset 209 | { 210 | $Curr_Test = 0; 211 | @Test_Results = (); 212 | $Prem_Diag = {diag => ""}; 213 | } 214 | 215 | 1; 216 | 217 | __END__ 218 | 219 | =head1 NAME 220 | 221 | Test::Tester::Capture - Help testing test modules built with Test::Builder 222 | 223 | =head1 DESCRIPTION 224 | 225 | This is a subclass of Test::Builder that overrides many of the methods so 226 | that they don't output anything. It also keeps track of its own set of test 227 | results so that you can use Test::Builder based modules to perform tests on 228 | other Test::Builder based modules. 229 | 230 | =head1 AUTHOR 231 | 232 | Most of the code here was lifted straight from Test::Builder and then had 233 | chunks removed by Fergal Daly . 234 | 235 | =head1 LICENSE 236 | 237 | Under the same license as Perl itself 238 | 239 | See http://www.perl.com/perl/misc/Artistic.html 240 | 241 | =cut 242 | -------------------------------------------------------------------------------- /t/lib/Test2/API/Breakage.pm: -------------------------------------------------------------------------------- 1 | package Test2::API::Breakage; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | use Test2::Util qw/pkg_to_file/; 9 | 10 | our @EXPORT_OK = qw{ 11 | upgrade_suggested 12 | upgrade_required 13 | known_broken 14 | }; 15 | BEGIN { require Exporter; our @ISA = qw(Exporter) } 16 | 17 | sub upgrade_suggested { 18 | return ( 19 | 'Test::Exception' => '0.42', 20 | 'Test::FITesque' => '0.04', 21 | 'Test::Module::Used' => '0.2.5', 22 | 'Test::Moose::More' => '0.025', 23 | ); 24 | } 25 | 26 | sub upgrade_required { 27 | return ( 28 | 'Test::Builder::Clutch' => '0.07', 29 | 'Test::Dist::VersionSync' => '1.1.4', 30 | 'Test::Modern' => '0.012', 31 | 'Test::SharedFork' => '0.34', 32 | 'Test::Alien' => '0.04', 33 | 'Test::UseAllModules' => '0.14', 34 | 'Test::More::Prefix' => '0.005', 35 | 36 | 'Test2::Tools::EventDumper' => 0.000007, 37 | 'Test2::Harness' => 0.000013, 38 | 39 | 'Test::DBIx::Class::Schema' => '1.0.9', 40 | 'Test::Clustericious::Cluster' => '0.30', 41 | ); 42 | } 43 | 44 | sub known_broken { 45 | return ( 46 | 'Net::BitTorrent' => '0.052', 47 | 'Test::Able' => '0.11', 48 | 'Test::Aggregate' => '0.373', 49 | 'Test::Flatten' => '0.11', 50 | 'Test::Group' => '0.20', 51 | 'Test::ParallelSubtest' => '0.05', 52 | 'Test::Pretty' => '0.32', 53 | 'Test::Wrapper' => '0.3.0', 54 | 55 | 'Log::Dispatch::Config::TestLog' => '0.02', 56 | ); 57 | } 58 | 59 | # Not reportable: 60 | # Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to. 61 | 62 | sub report { 63 | my $class = shift; 64 | my ($require) = @_; 65 | 66 | my %suggest = __PACKAGE__->upgrade_suggested(); 67 | my %required = __PACKAGE__->upgrade_required(); 68 | my %broken = __PACKAGE__->known_broken(); 69 | 70 | my @warn; 71 | for my $mod (keys %suggest) { 72 | my $file = pkg_to_file($mod); 73 | next unless $INC{$file} || ($require && eval { require $file; 1 }); 74 | my $want = $suggest{$mod}; 75 | next if eval { $mod->VERSION($want); 1 }; 76 | my $error = $@; 77 | chomp $error; 78 | push @warn => " * Module '$mod' is outdated, we recommed updating above $want. error was: '$error'; INC is $INC{$file}"; 79 | } 80 | 81 | for my $mod (keys %required) { 82 | my $file = pkg_to_file($mod); 83 | next unless $INC{$file} || ($require && eval { require $file; 1 }); 84 | my $want = $required{$mod}; 85 | next if eval { $mod->VERSION($want); 1 }; 86 | push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher."; 87 | } 88 | 89 | for my $mod (keys %broken) { 90 | my $file = pkg_to_file($mod); 91 | next unless $INC{$file} || ($require && eval { require $file; 1 }); 92 | my $tested = $broken{$mod}; 93 | push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION; 94 | } 95 | 96 | return @warn; 97 | } 98 | 99 | 1; 100 | 101 | __END__ 102 | 103 | 104 | =pod 105 | 106 | =encoding UTF-8 107 | 108 | =head1 NAME 109 | 110 | Test2::API::Breakage - What breaks at what version 111 | 112 | =head1 DESCRIPTION 113 | 114 | This module provides lists of modules that are broken, or have been broken in 115 | the past, when upgrading L to use L. 116 | 117 | =head1 FUNCTIONS 118 | 119 | These can be imported, or called as methods on the class. 120 | 121 | =over 4 122 | 123 | =item %mod_ver = upgrade_suggested() 124 | 125 | =item %mod_ver = Test2::API::Breakage->upgrade_suggested() 126 | 127 | This returns key/value pairs. The key is the module name, the value is the 128 | version number. If the installed version of the module is at or below the 129 | specified one then an upgrade would be a good idea, but not strictly necessary. 130 | 131 | =item %mod_ver = upgrade_required() 132 | 133 | =item %mod_ver = Test2::API::Breakage->upgrade_required() 134 | 135 | This returns key/value pairs. The key is the module name, the value is the 136 | version number. If the installed version of the module is at or below the 137 | specified one then an upgrade is required for the module to work properly. 138 | 139 | =item %mod_ver = known_broken() 140 | 141 | =item %mod_ver = Test2::API::Breakage->known_broken() 142 | 143 | This returns key/value pairs. The key is the module name, the value is the 144 | version number. If the installed version of the module is at or below the 145 | specified one then the module will not work. A newer version may work, but is 146 | not tested or verified. 147 | 148 | =back 149 | 150 | =head1 SOURCE 151 | 152 | The source code repository for Test2 can be found at 153 | F. 154 | 155 | =head1 MAINTAINERS 156 | 157 | =over 4 158 | 159 | =item Chad Granum Eexodist@cpan.orgE 160 | 161 | =back 162 | 163 | =head1 AUTHORS 164 | 165 | =over 4 166 | 167 | =item Chad Granum Eexodist@cpan.orgE 168 | 169 | =back 170 | 171 | =head1 COPYRIGHT 172 | 173 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 174 | 175 | This program is free software; you can redistribute it and/or 176 | modify it under the same terms as Perl itself. 177 | 178 | See F 179 | 180 | =cut 181 | -------------------------------------------------------------------------------- /t/logmsg.pl: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | SKIP: { eval { require Test::Warnings; } or skip($@, 1); } 3 | eval { require 'ddclient'; } or BAIL_OUT($@); 4 | 5 | my @test_cases = ( 6 | { 7 | desc => 'adds a newline', 8 | args => ['xyz'], 9 | want => "xyz\n", 10 | }, 11 | { 12 | desc => 'removes one trailing newline (before adding a newline)', 13 | args => ["xyz \n\t\n\n"], 14 | want => "xyz \n\t\n\n", 15 | }, 16 | { 17 | desc => 'accepts msg keyword parameter', 18 | args => [msg => 'xyz'], 19 | want => "xyz\n", 20 | }, 21 | { 22 | desc => 'msg keyword parameter trumps message parameter', 23 | args => [msg => 'kw', 'pos'], 24 | want => "kw\n", 25 | }, 26 | { 27 | desc => 'msg keyword parameter trumps message parameter', 28 | args => [msg => 'kw', 'pos'], 29 | want => "kw\n", 30 | }, 31 | { 32 | desc => 'email appends to email body', 33 | args => [email => 1, 'foo'], 34 | init_email => "preexisting message\n", 35 | want_email => "preexisting message\nfoo\n", 36 | want => "foo\n", 37 | }, 38 | { 39 | desc => 'single-line label', 40 | args => [label => 'LBL', 'foo'], 41 | want => "LBL: > foo\n", 42 | }, 43 | { 44 | desc => 'multi-line label', 45 | args => [label => 'LBL', "foo\nbar"], 46 | want => ("LBL: > foo\n" . 47 | "LBL: bar\n"), 48 | }, 49 | { 50 | desc => 'single-line long label', 51 | args => [label => 'VERY LONG LABEL', 'foo'], 52 | want => "VERY LONG LABEL: > foo\n", 53 | }, 54 | { 55 | desc => 'multi-line long label', 56 | args => [label => 'VERY LONG LABEL', "foo\nbar"], 57 | want => ("VERY LONG LABEL: > foo\n" . 58 | "VERY LONG LABEL: bar\n"), 59 | }, 60 | { 61 | desc => 'single line, no label, single context', 62 | args => ['foo'], 63 | ctxs => ['only context'], 64 | want => "[only context]> foo\n", 65 | }, 66 | { 67 | desc => 'single line, no label, two contexts', 68 | args => ['foo'], 69 | ctxs => ['context one', 'context two'], 70 | want => "[context one][context two]> foo\n", 71 | }, 72 | { 73 | desc => 'single line, label, two contexts', 74 | args => [label => 'LBL', 'foo'], 75 | ctxs => ['context one', 'context two'], 76 | want => "LBL: [context one][context two]> foo\n", 77 | }, 78 | { 79 | desc => 'multiple lines, label, two contexts', 80 | args => [label => 'LBL', "foo\nbar"], 81 | ctxs => ['context one', 'context two'], 82 | want => ("LBL: [context one][context two]> foo\n" . 83 | "LBL: [context one][context two] bar\n"), 84 | }, 85 | { 86 | desc => 'string ctx arg', 87 | args => [label => 'LBL', ctx => 'three', "foo\nbar"], 88 | ctxs => ['one', 'two'], 89 | want => ("LBL: [one][two][three]> foo\n" . 90 | "LBL: [one][two][three] bar\n"), 91 | }, 92 | { 93 | desc => 'arrayref ctx arg', 94 | args => [label => 'LBL', ctx => ['three', 'four'], "foo\nbar"], 95 | ctxs => ['one', 'two'], 96 | want => ("LBL: [one][two][three][four]> foo\n" . 97 | "LBL: [one][two][three][four] bar\n"), 98 | }, 99 | { 100 | desc => 'undef ctx', 101 | args => [label => 'LBL', "foo"], 102 | ctxs => ['one', undef], 103 | want => "LBL: [one]> foo\n", 104 | }, 105 | { 106 | desc => 'arrayref ctx', 107 | args => [label => 'LBL', "foo"], 108 | ctxs => ['one', ['two', 'three']], 109 | want => "LBL: [one][two][three]> foo\n", 110 | }, 111 | ); 112 | 113 | for my $tc (@test_cases) { 114 | subtest $tc->{desc} => sub { 115 | $tc->{wantemail} //= ''; 116 | my $output; 117 | open(my $fh, '>', \$output); 118 | local $ddclient::emailbody = $tc->{init_email} // ''; 119 | local $ddclient::_l = $ddclient::_l; 120 | $ddclient::_l = ddclient::pushlogctx($_) for @{$tc->{ctxs} // []}; 121 | { 122 | local *STDERR = $fh; 123 | ddclient::logmsg(@{$tc->{args}}); 124 | } 125 | close($fh); 126 | is($output, $tc->{want}, 'output text matches'); 127 | is($ddclient::emailbody, $tc->{want_email} // '', 'email content matches'); 128 | } 129 | } 130 | 131 | my @logfmt_test_cases = ( 132 | { 133 | desc => 'single argument is printed directly, not via sprintf', 134 | args => ['%%'], 135 | want => "DEBUG: > %%\n", 136 | }, 137 | { 138 | desc => 'multiple arguments are formatted via sprintf', 139 | args => ['%s', 'foo'], 140 | want => "DEBUG: > foo\n", 141 | }, 142 | { 143 | desc => 'single argument with context', 144 | args => [ctx => 'context', '%%'], 145 | want => "DEBUG: [context]> %%\n", 146 | }, 147 | { 148 | desc => 'multiple arguments with context', 149 | args => [ctx => 'context', '%s', 'foo'], 150 | want => "DEBUG: [context]> foo\n", 151 | }, 152 | ); 153 | 154 | for my $tc (@logfmt_test_cases) { 155 | my $got; 156 | open(my $fh, '>', \$got); 157 | local $ddclient::globals{debug} = 1; 158 | %ddclient::globals if 0; 159 | { 160 | local *STDERR = $fh; 161 | ddclient::debug(@{$tc->{args}}); 162 | } 163 | close($fh); 164 | is($got, $tc->{want}, $tc->{desc}); 165 | } 166 | 167 | done_testing(); 168 | -------------------------------------------------------------------------------- /t/lib/Test2/API/Stack.pm: -------------------------------------------------------------------------------- 1 | package Test2::API::Stack; 2 | use strict; 3 | use warnings; 4 | 5 | our $VERSION = '1.302175'; 6 | 7 | 8 | use Test2::Hub(); 9 | 10 | use Carp qw/confess/; 11 | 12 | sub new { 13 | my $class = shift; 14 | return bless [], $class; 15 | } 16 | 17 | sub new_hub { 18 | my $self = shift; 19 | my %params = @_; 20 | 21 | my $class = delete $params{class} || 'Test2::Hub'; 22 | 23 | my $hub = $class->new(%params); 24 | 25 | if (@$self) { 26 | $hub->inherit($self->[-1], %params); 27 | } 28 | else { 29 | require Test2::API; 30 | $hub->format(Test2::API::test2_formatter()->new_root) 31 | unless $hub->format || exists($params{formatter}); 32 | 33 | my $ipc = Test2::API::test2_ipc(); 34 | if ($ipc && !$hub->ipc && !exists($params{ipc})) { 35 | $hub->set_ipc($ipc); 36 | $ipc->add_hub($hub->hid); 37 | } 38 | } 39 | 40 | push @$self => $hub; 41 | 42 | $hub; 43 | } 44 | 45 | sub top { 46 | my $self = shift; 47 | return $self->new_hub unless @$self; 48 | return $self->[-1]; 49 | } 50 | 51 | sub peek { 52 | my $self = shift; 53 | return @$self ? $self->[-1] : undef; 54 | } 55 | 56 | sub cull { 57 | my $self = shift; 58 | $_->cull for reverse @$self; 59 | } 60 | 61 | sub all { 62 | my $self = shift; 63 | return @$self; 64 | } 65 | 66 | sub root { 67 | my $self = shift; 68 | return unless @$self; 69 | return $self->[0]; 70 | } 71 | 72 | sub clear { 73 | my $self = shift; 74 | @$self = (); 75 | } 76 | 77 | # Do these last without keywords in order to prevent them from getting used 78 | # when we want the real push/pop. 79 | 80 | { 81 | no warnings 'once'; 82 | 83 | *push = sub { 84 | my $self = shift; 85 | my ($hub) = @_; 86 | $hub->inherit($self->[-1]) if @$self; 87 | push @$self => $hub; 88 | }; 89 | 90 | *pop = sub { 91 | my $self = shift; 92 | my ($hub) = @_; 93 | confess "No hubs on the stack" 94 | unless @$self; 95 | confess "You cannot pop the root hub" 96 | if 1 == @$self; 97 | confess "Hub stack mismatch, attempted to pop incorrect hub" 98 | unless $self->[-1] == $hub; 99 | pop @$self; 100 | }; 101 | } 102 | 103 | 1; 104 | 105 | __END__ 106 | 107 | =pod 108 | 109 | =encoding UTF-8 110 | 111 | =head1 NAME 112 | 113 | Test2::API::Stack - Object to manage a stack of L 114 | instances. 115 | 116 | =head1 ***INTERNALS NOTE*** 117 | 118 | B The public 119 | methods provided will not change in backwards incompatible ways, but the 120 | underlying implementation details might. B 121 | 122 | =head1 DESCRIPTION 123 | 124 | This module is used to represent and manage a stack of L 125 | objects. Hubs are usually in a stack so that you can push a new hub into place 126 | that can intercept and handle events differently than the primary hub. 127 | 128 | =head1 SYNOPSIS 129 | 130 | my $stack = Test2::API::Stack->new; 131 | my $hub = $stack->top; 132 | 133 | =head1 METHODS 134 | 135 | =over 4 136 | 137 | =item $stack = Test2::API::Stack->new() 138 | 139 | This will create a new empty stack instance. All arguments are ignored. 140 | 141 | =item $hub = $stack->new_hub() 142 | 143 | =item $hub = $stack->new_hub(%params) 144 | 145 | =item $hub = $stack->new_hub(%params, class => $class) 146 | 147 | This will generate a new hub and push it to the top of the stack. Optionally 148 | you can provide arguments that will be passed into the constructor for the 149 | L object. 150 | 151 | If you specify the C<< 'class' => $class >> argument, the new hub will be an 152 | instance of the specified class. 153 | 154 | Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the 155 | formatter and IPC instance will be inherited from the current top hub. You can 156 | set the parameters to C to avoid having a formatter or IPC instance. 157 | 158 | If there is no top hub, and you do not ask to leave IPC and formatter undef, 159 | then a new formatter will be created, and the IPC instance from 160 | L will be used. 161 | 162 | =item $hub = $stack->top() 163 | 164 | This will return the top hub from the stack. If there is no top hub yet this 165 | will create it. 166 | 167 | =item $hub = $stack->peek() 168 | 169 | This will return the top hub from the stack. If there is no top hub yet this 170 | will return undef. 171 | 172 | =item $stack->cull 173 | 174 | This will call C<< $hub->cull >> on all hubs in the stack. 175 | 176 | =item @hubs = $stack->all 177 | 178 | This will return all the hubs in the stack as a list. 179 | 180 | =item $stack->clear 181 | 182 | This will completely remove all hubs from the stack. Normally you do not want 183 | to do this, but there are a few valid reasons for it. 184 | 185 | =item $stack->push($hub) 186 | 187 | This will push the new hub onto the stack. 188 | 189 | =item $stack->pop($hub) 190 | 191 | This will pop a hub from the stack, if the hub at the top of the stack does not 192 | match the hub you expect (passed in as an argument) it will throw an exception. 193 | 194 | =back 195 | 196 | =head1 SOURCE 197 | 198 | The source code repository for Test2 can be found at 199 | F. 200 | 201 | =head1 MAINTAINERS 202 | 203 | =over 4 204 | 205 | =item Chad Granum Eexodist@cpan.orgE 206 | 207 | =back 208 | 209 | =head1 AUTHORS 210 | 211 | =over 4 212 | 213 | =item Chad Granum Eexodist@cpan.orgE 214 | 215 | =back 216 | 217 | =head1 COPYRIGHT 218 | 219 | Copyright 2019 Chad Granum Eexodist@cpan.orgE. 220 | 221 | This program is free software; you can redistribute it and/or 222 | modify it under the same terms as Perl itself. 223 | 224 | See F 225 | 226 | =cut 227 | --------------------------------------------------------------------------------